This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Integrate PerlIO: duping fixes.
[perl5.git] / pp_sys.c
CommitLineData
a0d0e21e
LW		 1/* pp_sys.c
2 *
bc89e66f 3 * Copyright (c) 1991-2001, Larry Wall
a0d0e21e
LW		 4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
8 */
9
10/*
11 * But only a short way ahead its floor and the walls on either side were
12 * cloven by a great fissure, out of which the red glare came, now leaping
13 * up, now dying down into darkness; and all the while far below there was
14 * a rumour and a trouble as of great engines throbbing and labouring.
15 */
16
17#include "EXTERN.h"
864dbfa3 18#define PERL_IN_PP_SYS_C
a0d0e21e
LW		 19#include "perl.h"
20
f1066039
JH		 21#ifdef I_SHADOW
22/* Shadow password support for solaris - pdo@cs.umd.edu
23 * Not just Solaris: at least HP-UX, IRIX, Linux.
3813c136
JH		 24 * The API is from SysV.
25 *
26 * There are at least two more shadow interfaces,
27 * see the comments in pp_gpwent().
28 *
29 * --jhi */
30# ifdef __hpux__
c529f79d 31/* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
301e8125 32 * and another MAXINT from "perl.h" <- <sys/param.h>. */
3813c136
JH		 33# undef MAXINT
34# endif
35# include <shadow.h>
8c0bfa08
PB		 36#endif
37
301e8125
NIS		 38#ifdef HAS_SYSCALL
39#ifdef __cplusplus
8ac85365
NIS		 40extern "C" int syscall(unsigned long,...);
41#endif
42#endif
43
76c32331 44#ifdef I_SYS_WAIT
45# include <sys/wait.h>
46#endif
47
48#ifdef I_SYS_RESOURCE
49# include <sys/resource.h>
16d20bd9 50#endif
a0d0e21e 51
2986a63f
JH		 52#ifdef NETWARE
53NETDB_DEFINE_CONTEXT
54#endif
55
a0d0e21e 56#ifdef HAS_SELECT
1e743fda
JH		 57# ifdef I_SYS_SELECT
58# include <sys/select.h>
59# endif
a0d0e21e 60#endif
a0d0e21e 61
dc45a647
MB		 62/* XXX Configure test needed.
63 h_errno might not be a simple 'int', especially for multi-threaded
5ff3f7a4
GS		 64 applications, see "extern int errno in perl.h". Creating such
65 a test requires taking into account the differences between
66 compiling multithreaded and singlethreaded ($ccflags et al).
67 HOST_NOT_FOUND is typically defined in <netdb.h>.
dc45a647 68*/
cb50131a 69#if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
a0d0e21e
LW		 70extern int h_errno;
71#endif
72
73#ifdef HAS_PASSWD
74# ifdef I_PWD
75# include <pwd.h>
76# else
fd8cd3a3 77# if !defined(VMS)
20ce7b12
GS		 78 struct passwd *getpwnam (char *);
79 struct passwd *getpwuid (Uid_t);
fd8cd3a3 80# endif
a0d0e21e 81# endif
28e8609d 82# ifdef HAS_GETPWENT
20ce7b12 83 struct passwd *getpwent (void);
28e8609d 84# endif
a0d0e21e
LW		 85#endif
86
87#ifdef HAS_GROUP
88# ifdef I_GRP
89# include <grp.h>
90# else
20ce7b12
GS		 91 struct group *getgrnam (char *);
92 struct group *getgrgid (Gid_t);
a0d0e21e 93# endif
28e8609d 94# ifdef HAS_GETGRENT
20ce7b12 95 struct group *getgrent (void);
28e8609d 96# endif
a0d0e21e
LW		 97#endif
98
99#ifdef I_UTIME
3730b96e 100# if defined(_MSC_VER) || defined(__MINGW32__)
3fe9a6f1 101# include <sys/utime.h>
102# else
103# include <utime.h>
104# endif
a0d0e21e 105#endif
a0d0e21e 106
cbdc8872 107#ifdef HAS_CHSIZE
cd52b7b2 108# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
109# undef my_chsize
110# endif
6ad3d225 111# define my_chsize PerlLIO_chsize
cbdc8872 112#endif
113
ff68c719 114#ifdef HAS_FLOCK
115# define FLOCK flock
116#else /* no flock() */
117
36477c24 118 /* fcntl.h might not have been included, even if it exists, because
119 the current Configure only sets I_FCNTL if it's needed to pick up
120 the *_OK constants. Make sure it has been included before testing
121 the fcntl() locking constants. */
122# if defined(HAS_FCNTL) && !defined(I_FCNTL)
123# include <fcntl.h>
124# endif
125
9d9004a9 126# if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
ff68c719 127# define FLOCK fcntl_emulate_flock
128# define FCNTL_EMULATE_FLOCK
129# else /* no flock() or fcntl(F_SETLK,...) */
130# ifdef HAS_LOCKF
131# define FLOCK lockf_emulate_flock
132# define LOCKF_EMULATE_FLOCK
133# endif /* lockf */
134# endif /* no flock() or fcntl(F_SETLK,...) */
135
136# ifdef FLOCK
20ce7b12 137 static int FLOCK (int, int);
ff68c719 138
139 /*
140 * These are the flock() constants. Since this sytems doesn't have
141 * flock(), the values of the constants are probably not available.
142 */
143# ifndef LOCK_SH
144# define LOCK_SH 1
145# endif
146# ifndef LOCK_EX
147# define LOCK_EX 2
148# endif
149# ifndef LOCK_NB
150# define LOCK_NB 4
151# endif
152# ifndef LOCK_UN
153# define LOCK_UN 8
154# endif
155# endif /* emulating flock() */
156
157#endif /* no flock() */
55497cff 158
85ab1d1d
JH		 159#define ZBTLEN 10
160static char zero_but_true[ZBTLEN + 1] = "0 but true";
161
5ff3f7a4
GS		 162#if defined(I_SYS_ACCESS) && !defined(R_OK)
163# include <sys/access.h>
164#endif
165
c529f79d
CB		 166#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
167# define FD_CLOEXEC 1 /* NeXT needs this */
168#endif
169
5ff3f7a4
GS		 170#undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */
171#undef PERL_EFF_ACCESS_W_OK
172#undef PERL_EFF_ACCESS_X_OK
173
174/* F_OK unused: if stat() cannot find it... */
175
176#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
c955f117 177 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
5ff3f7a4
GS		 178# define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK))
179# define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK))
180# define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK))
181#endif
182
183#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
3813c136 184# ifdef I_SYS_SECURITY
5ff3f7a4
GS		 185# include <sys/security.h>
186# endif
c955f117
JH		 187# ifdef ACC_SELF
188 /* HP SecureWare */
189# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
190# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
191# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
192# else
193 /* SCO */
194# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK))
195# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK))
196# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK))
197# endif
5ff3f7a4
GS		 198#endif
199
200#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF)
c955f117 201 /* AIX */
5ff3f7a4
GS		 202# define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF))
203# define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF))
204# define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF))
205#endif
206
327c3667
GS		 207#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) \
208 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
209 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
5ff3f7a4 210/* The Hard Way. */
327c3667 211STATIC int
7f4774ae 212S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
ba106d47 213{
5ff3f7a4
GS		 214 Uid_t ruid = getuid();
215 Uid_t euid = geteuid();
216 Gid_t rgid = getgid();
217 Gid_t egid = getegid();
218 int res;
219
146174a9 220 LOCK_CRED_MUTEX;
5ff3f7a4 221#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
cea2e8a9 222 Perl_croak(aTHX_ "switching effective uid is not implemented");
5ff3f7a4
GS		 223#else
224#ifdef HAS_SETREUID
225 if (setreuid(euid, ruid))
226#else
227#ifdef HAS_SETRESUID
228 if (setresuid(euid, ruid, (Uid_t)-1))
229#endif
230#endif
cea2e8a9 231 Perl_croak(aTHX_ "entering effective uid failed");
5ff3f7a4
GS		 232#endif
233
234#if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
cea2e8a9 235 Perl_croak(aTHX_ "switching effective gid is not implemented");
5ff3f7a4
GS		 236#else
237#ifdef HAS_SETREGID
238 if (setregid(egid, rgid))
239#else
240#ifdef HAS_SETRESGID
241 if (setresgid(egid, rgid, (Gid_t)-1))
242#endif
243#endif
cea2e8a9 244 Perl_croak(aTHX_ "entering effective gid failed");
5ff3f7a4
GS		 245#endif
246
247 res = access(path, mode);
248
249#ifdef HAS_SETREUID
250 if (setreuid(ruid, euid))
251#else
252#ifdef HAS_SETRESUID
253 if (setresuid(ruid, euid, (Uid_t)-1))
254#endif
255#endif
cea2e8a9 256 Perl_croak(aTHX_ "leaving effective uid failed");
5ff3f7a4
GS		 257
258#ifdef HAS_SETREGID
259 if (setregid(rgid, egid))
260#else
261#ifdef HAS_SETRESGID
262 if (setresgid(rgid, egid, (Gid_t)-1))
263#endif
264#endif
cea2e8a9 265 Perl_croak(aTHX_ "leaving effective gid failed");
146174a9 266 UNLOCK_CRED_MUTEX;
5ff3f7a4
GS		 267
268 return res;
269}
270# define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
271# define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
272# define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
273#endif
274
275#if !defined(PERL_EFF_ACCESS_R_OK)
76ffd3b9
IZ		 276/* With it or without it: anyway you get a warning: either that
277 it is unused, or it is declared static and never defined.
278 */
327c3667 279STATIC int
7f4774ae 280S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
ba106d47 281{
cea2e8a9 282 Perl_croak(aTHX_ "switching effective uid is not implemented");
5ff3f7a4
GS		 283 /*NOTREACHED*/
284 return -1;
285}
286#endif
287
a0d0e21e
LW		 288PP(pp_backtick)
289{
39644a26 290 dSP; dTARGET;
760ac839 291 PerlIO *fp;
2d8e6c8d
GS		 292 STRLEN n_a;
293 char *tmps = POPpx;
54310121 294 I32 gimme = GIMME_V;
16fe6d59 295 char *mode = "r";
54310121 296
a0d0e21e 297 TAINT_PROPER("``");
16fe6d59
GS		 298 if (PL_op->op_private & OPpOPEN_IN_RAW)
299 mode = "rb";
300 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
301 mode = "rt";
302 fp = PerlProc_popen(tmps, mode);
a0d0e21e 303 if (fp) {
ac27b0f5
NIS		 304 char *type = NULL;
305 if (PL_curcop->cop_io) {
306 type = SvPV_nolen(PL_curcop->cop_io);
307 }
ac27b0f5
NIS		 308 if (type && *type)
309 PerlIO_apply_layers(aTHX_ fp,mode,type);
310
54310121 311 if (gimme == G_VOID) {
96827780
MB		 312 char tmpbuf[256];
313 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
54310121 314 /*SUPPRESS 530*/
315 ;
316 }
317 else if (gimme == G_SCALAR) {
aa689395 318 sv_setpv(TARG, ""); /* note that this preserves previous buffer */
a0d0e21e
LW		 319 while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
320 /*SUPPRESS 530*/
321 ;
322 XPUSHs(TARG);
aa689395 323 SvTAINTED_on(TARG);
a0d0e21e
LW		 324 }
325 else {
326 SV *sv;
327
328 for (;;) {
8d6dde3e 329 sv = NEWSV(56, 79);
a0d0e21e
LW		 330 if (sv_gets(sv, fp, 0) == Nullch) {
331 SvREFCNT_dec(sv);
332 break;
333 }
334 XPUSHs(sv_2mortal(sv));
335 if (SvLEN(sv) - SvCUR(sv) > 20) {
336 SvLEN_set(sv, SvCUR(sv)+1);
337 Renew(SvPVX(sv), SvLEN(sv), char);
338 }
aa689395 339 SvTAINTED_on(sv);
a0d0e21e
LW		 340 }
341 }
6ad3d225 342 STATUS_NATIVE_SET(PerlProc_pclose(fp));
aa689395 343 TAINT; /* "I believe that this is not gratuitous!" */
a0d0e21e
LW		 344 }
345 else {
f86702cc 346 STATUS_NATIVE_SET(-1);
54310121 347 if (gimme == G_SCALAR)
a0d0e21e
LW		 348 RETPUSHUNDEF;
349 }
350
351 RETURN;
352}
353
354PP(pp_glob)
355{
356 OP *result;
f5284f61
IZ		 357 tryAMAGICunTARGET(iter, -1);
358
71686f12
GS		 359 /* Note that we only ever get here if File::Glob fails to load
360 * without at the same time croaking, for some reason, or if
361 * perl was built with PERL_EXTERNAL_GLOB */
362
a0d0e21e 363 ENTER;
a0d0e21e 364
c90c0ff4 365#ifndef VMS
3280af22 366 if (PL_tainting) {
7bac28a0 367 /*
368 * The external globbing program may use things we can't control,
369 * so for security reasons we must assume the worst.
370 */
371 TAINT;
22c35a8c 372 taint_proper(PL_no_security, "glob");
7bac28a0 373 }
c90c0ff4 374#endif /* !VMS */
7bac28a0 375
3280af22
NIS		 376 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
377 PL_last_in_gv = (GV*)*PL_stack_sp--;
a0d0e21e 378
3280af22 379 SAVESPTR(PL_rs); /* This is not permanent, either. */
79cb57f6 380 PL_rs = sv_2mortal(newSVpvn("\000", 1));
c07a80fd 381#ifndef DOSISH
382#ifndef CSH
6b88bc9c 383 *SvPVX(PL_rs) = '\n';
a0d0e21e 384#endif /* !CSH */
55497cff 385#endif /* !DOSISH */
c07a80fd 386
a0d0e21e
LW		 387 result = do_readline();
388 LEAVE;
389 return result;
390}
391
a0d0e21e
LW		 392PP(pp_rcatline)
393{
146174a9 394 PL_last_in_gv = cGVOP_gv;
a0d0e21e
LW		 395 return do_readline();
396}
397
398PP(pp_warn)
399{
39644a26 400 dSP; dMARK;
06bf62c7 401 SV *tmpsv;
a0d0e21e 402 char *tmps;
06bf62c7 403 STRLEN len;
a0d0e21e
LW		 404 if (SP - MARK != 1) {
405 dTARGET;
3280af22 406 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7 407 tmpsv = TARG;
a0d0e21e
LW		 408 SP = MARK + 1;
409 }
410 else {
06bf62c7 411 tmpsv = TOPs;
a0d0e21e 412 }
06bf62c7
GS		 413 tmps = SvPV(tmpsv, len);
414 if (!tmps || !len) {
4e6ea2c3
GS		 415 SV *error = ERRSV;
416 (void)SvUPGRADE(error, SVt_PV);
417 if (SvPOK(error) && SvCUR(error))
418 sv_catpv(error, "\t...caught");
06bf62c7
GS		 419 tmpsv = error;
420 tmps = SvPV(tmpsv, len);
a0d0e21e 421 }
06bf62c7
GS		 422 if (!tmps || !len)
423 tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
424
cb50131a 425 Perl_warn(aTHX_ "%"SVf, tmpsv);
a0d0e21e
LW		 426 RETSETYES;
427}
428
429PP(pp_die)
430{
39644a26 431 dSP; dMARK;
a0d0e21e 432 char *tmps;
06bf62c7
GS		 433 SV *tmpsv;
434 STRLEN len;
435 bool multiarg = 0;
96e176bf
CL		 436#ifdef VMS
437 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
438#endif
a0d0e21e
LW		 439 if (SP - MARK != 1) {
440 dTARGET;
3280af22 441 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7
GS		 442 tmpsv = TARG;
443 tmps = SvPV(tmpsv, len);
444 multiarg = 1;
a0d0e21e
LW		 445 SP = MARK + 1;
446 }
447 else {
4e6ea2c3 448 tmpsv = TOPs;
bf484eac 449 tmps = (SvROK(tmpsv) && PL_in_eval) ? Nullch : SvPV(tmpsv, len);
a0d0e21e 450 }
06bf62c7 451 if (!tmps || !len) {
4e6ea2c3
GS		 452 SV *error = ERRSV;
453 (void)SvUPGRADE(error, SVt_PV);
06bf62c7
GS		 454 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
455 if (!multiarg)
4e6ea2c3 456 SvSetSV(error,tmpsv);
06bf62c7 457 else if (sv_isobject(error)) {
05423cc9
GS		 458 HV *stash = SvSTASH(SvRV(error));
459 GV *gv = gv_fetchmethod(stash, "PROPAGATE");
460 if (gv) {
146174a9 461 SV *file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
b448e4fe 462 SV *line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
05423cc9
GS		 463 EXTEND(SP, 3);
464 PUSHMARK(SP);
465 PUSHs(error);
466 PUSHs(file);
467 PUSHs(line);
468 PUTBACK;
864dbfa3
GS		 469 call_sv((SV*)GvCV(gv),
470 G_SCALAR|G_EVAL|G_KEEPERR);
3280af22 471 sv_setsv(error,*PL_stack_sp--);
05423cc9
GS		 472 }
473 }
b3fe4827 474 DIE(aTHX_ Nullformat);
4e6ea2c3
GS		 475 }
476 else {
477 if (SvPOK(error) && SvCUR(error))
478 sv_catpv(error, "\t...propagated");
06bf62c7
GS		 479 tmpsv = error;
480 tmps = SvPV(tmpsv, len);
4e6ea2c3 481 }
a0d0e21e 482 }
06bf62c7
GS		 483 if (!tmps || !len)
484 tmpsv = sv_2mortal(newSVpvn("Died", 4));
485
cb50131a 486 DIE(aTHX_ "%"SVf, tmpsv);
a0d0e21e
LW		 487}
488
489/* I/O. */
490
491PP(pp_open)
492{
39644a26 493 dSP;
a567e93b
NIS		 494 dMARK; dORIGMARK;
495 dTARGET;
a0d0e21e
LW		 496 GV *gv;
497 SV *sv;
5b468f54 498 IO *io;
a0d0e21e
LW		 499 char *tmps;
500 STRLEN len;
4592e6ca 501 MAGIC *mg;
a567e93b 502 bool ok;
a0d0e21e 503
a567e93b 504 gv = (GV *)*++MARK;
5f05dabc 505 if (!isGV(gv))
cea2e8a9 506 DIE(aTHX_ PL_no_usym, "filehandle");
5b468f54 507 if ((io = GvIOp(gv)))
36477c24 508 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
853846ea 509
5b468f54 510 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
a567e93b
NIS		 511 /* Method's args are same as ours ... */
512 /* ... except handle is replaced by the object */
5b468f54 513 *MARK-- = SvTIED_obj((SV*)io, mg);
a567e93b 514 PUSHMARK(MARK);
4592e6ca
NIS		 515 PUTBACK;
516 ENTER;
864dbfa3 517 call_method("OPEN", G_SCALAR);
4592e6ca
NIS		 518 LEAVE;
519 SPAGAIN;
520 RETURN;
521 }
522
a567e93b
NIS		 523 if (MARK < SP) {
524 sv = *++MARK;
525 }
526 else {
527 sv = GvSV(gv);
528 }
529
a0d0e21e 530 tmps = SvPV(sv, len);
a567e93b
NIS		 531 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, MARK+1, (SP-MARK));
532 SP = ORIGMARK;
533 if (ok)
3280af22
NIS		 534 PUSHi( (I32)PL_forkprocess );
535 else if (PL_forkprocess == 0) /* we are a new child */
a0d0e21e
LW		 536 PUSHi(0);
537 else
538 RETPUSHUNDEF;
539 RETURN;
540}
541
542PP(pp_close)
543{
39644a26 544 dSP;
a0d0e21e 545 GV *gv;
5b468f54 546 IO *io;
1d603a67 547 MAGIC *mg;
a0d0e21e
LW		 548
549 if (MAXARG == 0)
3280af22 550 gv = PL_defoutgv;
a0d0e21e
LW		 551 else
552 gv = (GV*)POPs;
1d603a67 553
5b468f54
AMS		 554 if (gv && (io = GvIO(gv))
555 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
556 {
1d603a67 557 PUSHMARK(SP);
5b468f54 558 XPUSHs(SvTIED_obj((SV*)io, mg));
1d603a67
GB		 559 PUTBACK;
560 ENTER;
864dbfa3 561 call_method("CLOSE", G_SCALAR);
1d603a67
GB		 562 LEAVE;
563 SPAGAIN;
564 RETURN;
565 }
a0d0e21e 566 EXTEND(SP, 1);
54310121 567 PUSHs(boolSV(do_close(gv, TRUE)));
a0d0e21e
LW		 568 RETURN;
569}
570
571PP(pp_pipe_op)
572{
a0d0e21e 573#ifdef HAS_PIPE
9cad6237 574 dSP;
a0d0e21e
LW		 575 GV *rgv;
576 GV *wgv;
577 register IO *rstio;
578 register IO *wstio;
579 int fd[2];
580
581 wgv = (GV*)POPs;
582 rgv = (GV*)POPs;
583
584 if (!rgv || !wgv)
585 goto badexit;
586
4633a7c4 587 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
cea2e8a9 588 DIE(aTHX_ PL_no_usym, "filehandle");
a0d0e21e
LW		 589 rstio = GvIOn(rgv);
590 wstio = GvIOn(wgv);
591
592 if (IoIFP(rstio))
593 do_close(rgv, FALSE);
594 if (IoIFP(wstio))
595 do_close(wgv, FALSE);
596
6ad3d225 597 if (PerlProc_pipe(fd) < 0)
a0d0e21e
LW		 598 goto badexit;
599
760ac839
LW		 600 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
601 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
a0d0e21e 602 IoIFP(wstio) = IoOFP(wstio);
50952442
JH		 603 IoTYPE(rstio) = IoTYPE_RDONLY;
604 IoTYPE(wstio) = IoTYPE_WRONLY;
a0d0e21e
LW		 605
606 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 607 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
6ad3d225 608 else PerlLIO_close(fd[0]);
760ac839 609 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
6ad3d225 610 else PerlLIO_close(fd[1]);
a0d0e21e
LW		 611 goto badexit;
612 }
4771b018
GS		 613#if defined(HAS_FCNTL) && defined(F_SETFD)
614 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
615 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
616#endif
a0d0e21e
LW		 617 RETPUSHYES;
618
619badexit:
620 RETPUSHUNDEF;
621#else
cea2e8a9 622 DIE(aTHX_ PL_no_func, "pipe");
a0d0e21e
LW		 623#endif
624}
625
626PP(pp_fileno)
627{
39644a26 628 dSP; dTARGET;
a0d0e21e
LW		 629 GV *gv;
630 IO *io;
760ac839 631 PerlIO *fp;
4592e6ca
NIS		 632 MAGIC *mg;
633
a0d0e21e
LW		 634 if (MAXARG < 1)
635 RETPUSHUNDEF;
636 gv = (GV*)POPs;
4592e6ca 637
5b468f54
AMS		 638 if (gv && (io = GvIO(gv))
639 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
640 {
4592e6ca 641 PUSHMARK(SP);
5b468f54 642 XPUSHs(SvTIED_obj((SV*)io, mg));
4592e6ca
NIS		 643 PUTBACK;
644 ENTER;
864dbfa3 645 call_method("FILENO", G_SCALAR);
4592e6ca
NIS		 646 LEAVE;
647 SPAGAIN;
648 RETURN;
649 }
650
c289d2f7
JH		 651 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
652 /* Can't do this because people seem to do things like
653 defined(fileno($foo)) to check whether $foo is a valid fh.
654 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
655 report_evil_fh(gv, io, PL_op->op_type);
656 */
a0d0e21e 657 RETPUSHUNDEF;
c289d2f7
JH		 658 }
659
760ac839 660 PUSHi(PerlIO_fileno(fp));
a0d0e21e
LW		 661 RETURN;
662}
663
664PP(pp_umask)
665{
39644a26 666 dSP; dTARGET;
d7e492a4 667#ifdef HAS_UMASK
761237fe 668 Mode_t anum;
a0d0e21e 669
a0d0e21e 670 if (MAXARG < 1) {
6ad3d225
GS		 671 anum = PerlLIO_umask(0);
672 (void)PerlLIO_umask(anum);
a0d0e21e
LW		 673 }
674 else
6ad3d225 675 anum = PerlLIO_umask(POPi);
a0d0e21e
LW		 676 TAINT_PROPER("umask");
677 XPUSHi(anum);
678#else
eec2d3df
GS		 679 /* Only DIE if trying to restrict permissions on `user' (self).
680 * Otherwise it's harmless and more useful to just return undef
681 * since 'group' and 'other' concepts probably don't exist here. */
682 if (MAXARG >= 1 && (POPi & 0700))
cea2e8a9 683 DIE(aTHX_ "umask not implemented");
6b88bc9c 684 XPUSHs(&PL_sv_undef);
a0d0e21e
LW		 685#endif
686 RETURN;
687}
688
689PP(pp_binmode)
690{
39644a26 691 dSP;
a0d0e21e
LW		 692 GV *gv;
693 IO *io;
760ac839 694 PerlIO *fp;
4592e6ca 695 MAGIC *mg;
16fe6d59 696 SV *discp = Nullsv;
a0d0e21e
LW		 697
698 if (MAXARG < 1)
699 RETPUSHUNDEF;
60382766 700 if (MAXARG > 1) {
16fe6d59 701 discp = POPs;
60382766 702 }
a0d0e21e 703
301e8125 704 gv = (GV*)POPs;
4592e6ca 705
5b468f54
AMS		 706 if (gv && (io = GvIO(gv))
707 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
708 {
4592e6ca 709 PUSHMARK(SP);
5b468f54 710 XPUSHs(SvTIED_obj((SV*)io, mg));
16fe6d59
GS		 711 if (discp)
712 XPUSHs(discp);
4592e6ca
NIS		 713 PUTBACK;
714 ENTER;
864dbfa3 715 call_method("BINMODE", G_SCALAR);
4592e6ca
NIS		 716 LEAVE;
717 SPAGAIN;
718 RETURN;
719 }
a0d0e21e
LW		 720
721 EXTEND(SP, 1);
50f846a7 722 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
c289d2f7
JH		 723 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
724 report_evil_fh(gv, io, PL_op->op_type);
50f846a7
SC		 725 RETPUSHUNDEF;
726 }
a0d0e21e 727
60382766
NIS		 728 if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
729 (discp) ? SvPV_nolen(discp) : Nullch))
a0d0e21e
LW		 730 RETPUSHYES;
731 else
732 RETPUSHUNDEF;
a0d0e21e
LW		 733}
734
735PP(pp_tie)
736{
39644a26 737 dSP;
e336de0d 738 dMARK;
a0d0e21e
LW		 739 SV *varsv;
740 HV* stash;
741 GV *gv;
a0d0e21e 742 SV *sv;
3280af22 743 I32 markoff = MARK - PL_stack_base;
a0d0e21e 744 char *methname;
14befaf4 745 int how = PERL_MAGIC_tied;
e336de0d 746 U32 items;
2d8e6c8d 747 STRLEN n_a;
a0d0e21e 748
e336de0d 749 varsv = *++MARK;
6b05c17a
NIS		 750 switch(SvTYPE(varsv)) {
751 case SVt_PVHV:
752 methname = "TIEHASH";
03c6e78a 753 HvEITER((HV *)varsv) = Null(HE *);
6b05c17a
NIS		 754 break;
755 case SVt_PVAV:
756 methname = "TIEARRAY";
757 break;
758 case SVt_PVGV:
7fb37951
AMS		 759#ifdef GV_UNIQUE_CHECK
760 if (GvUNIQUE((GV*)varsv)) {
761 Perl_croak(aTHX_ "Attempt to tie unique GV");
5bd07a3d
DM		 762 }
763#endif
6b05c17a 764 methname = "TIEHANDLE";
14befaf4 765 how = PERL_MAGIC_tiedscalar;
5b468f54
AMS		 766 /* For tied filehandles, we apply tiedscalar magic to the IO
767 slot of the GP rather than the GV itself. AMS 20010812 */
768 if (!GvIOp(varsv))
769 GvIOp(varsv) = newIO();
770 varsv = (SV *)GvIOp(varsv);
6b05c17a
NIS		 771 break;
772 default:
773 methname = "TIESCALAR";
14befaf4 774 how = PERL_MAGIC_tiedscalar;
6b05c17a
NIS		 775 break;
776 }
e336de0d
GS		 777 items = SP - MARK++;
778 if (sv_isobject(*MARK)) {
6b05c17a 779 ENTER;
e788e7d3 780 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS		 781 PUSHMARK(SP);
782 EXTEND(SP,items);
783 while (items--)
784 PUSHs(*MARK++);
785 PUTBACK;
864dbfa3 786 call_method(methname, G_SCALAR);
301e8125 787 }
6b05c17a 788 else {
864dbfa3 789 /* Not clear why we don't call call_method here too.
6b05c17a
NIS		 790 * perhaps to get different error message ?
791 */
e336de0d 792 stash = gv_stashsv(*MARK, FALSE);
6b05c17a 793 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
cea2e8a9 794 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"",
301e8125 795 methname, SvPV(*MARK,n_a));
6b05c17a
NIS		 796 }
797 ENTER;
e788e7d3 798 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS		 799 PUSHMARK(SP);
800 EXTEND(SP,items);
801 while (items--)
802 PUSHs(*MARK++);
803 PUTBACK;
864dbfa3 804 call_sv((SV*)GvCV(gv), G_SCALAR);
6b05c17a 805 }
a0d0e21e
LW		 806 SPAGAIN;
807
808 sv = TOPs;
d3acc0f7 809 POPSTACK;
a0d0e21e 810 if (sv_isobject(sv)) {
33c27489 811 sv_unmagic(varsv, how);
ae21d580
JH		 812 /* Croak if a self-tie on an aggregate is attempted. */
813 if (varsv == SvRV(sv) &&
814 (SvTYPE(sv) == SVt_PVAV ||
815 SvTYPE(sv) == SVt_PVHV))
816 Perl_croak(aTHX_
817 "Self-ties of arrays and hashes are not supported");
68a4a7e4 818 sv_magic(varsv, sv, how, Nullch, 0);
a0d0e21e
LW		 819 }
820 LEAVE;
3280af22 821 SP = PL_stack_base + markoff;
a0d0e21e
LW		 822 PUSHs(sv);
823 RETURN;
824}
825
826PP(pp_untie)
827{
39644a26 828 dSP;
5b468f54 829 MAGIC *mg;
33c27489 830 SV *sv = POPs;
14befaf4
DM		 831 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
832 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
55497cff 833
5b468f54
AMS		 834 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
835 RETPUSHYES;
836
837 if ((mg = SvTIED_mg(sv, how))) {
a29a5827
NIS		 838 SV *obj = SvRV(mg->mg_obj);
839 GV *gv;
840 CV *cv = NULL;
a29a5827
NIS		 841 if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) &&
842 isGV(gv) && (cv = GvCV(gv))) {
843 PUSHMARK(SP);
844 XPUSHs(SvTIED_obj((SV*)gv, mg));
301e8125 845 XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
a29a5827
NIS		 846 PUTBACK;
847 ENTER;
848 call_sv((SV *)cv, G_VOID);
849 LEAVE;
850 SPAGAIN;
cbdc8872 851 }
301e8125
NIS		 852 else if (ckWARN(WARN_UNTIE)) {
853 if (mg && SvREFCNT(obj) > 1)
854 Perl_warner(aTHX_ WARN_UNTIE,
855 "untie attempted while %"UVuf" inner references still exist",
856 (UV)SvREFCNT(obj) - 1 ) ;
857 }
5b468f54 858 sv_unmagic(sv, how);
cbdc8872 859 }
55497cff 860 RETPUSHYES;
a0d0e21e
LW		 861}
862
c07a80fd 863PP(pp_tied)
864{
39644a26 865 dSP;
5b468f54 866 MAGIC *mg;
33c27489 867 SV *sv = POPs;
14befaf4
DM		 868 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
869 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
5b468f54
AMS		 870
871 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
872 RETPUSHUNDEF;
c07a80fd 873
155aba94 874 if ((mg = SvTIED_mg(sv, how))) {
33c27489
GS		 875 SV *osv = SvTIED_obj(sv, mg);
876 if (osv == mg->mg_obj)
877 osv = sv_mortalcopy(osv);
878 PUSHs(osv);
879 RETURN;
c07a80fd 880 }
c07a80fd 881 RETPUSHUNDEF;
882}
883
a0d0e21e
LW		 884PP(pp_dbmopen)
885{
39644a26 886 dSP;
a0d0e21e
LW		 887 HV *hv;
888 dPOPPOPssrl;
889 HV* stash;
890 GV *gv;
a0d0e21e
LW		 891 SV *sv;
892
893 hv = (HV*)POPs;
894
3280af22 895 sv = sv_mortalcopy(&PL_sv_no);
a0d0e21e
LW		 896 sv_setpv(sv, "AnyDBM_File");
897 stash = gv_stashsv(sv, FALSE);
8ebc5c01 898 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
a0d0e21e 899 PUTBACK;
864dbfa3 900 require_pv("AnyDBM_File.pm");
a0d0e21e 901 SPAGAIN;
8ebc5c01 902 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
cea2e8a9 903 DIE(aTHX_ "No dbm on this machine");
a0d0e21e
LW		 904 }
905
57d3b86d 906 ENTER;
924508f0 907 PUSHMARK(SP);
6b05c17a 908
924508f0 909 EXTEND(SP, 5);
a0d0e21e
LW		 910 PUSHs(sv);
911 PUSHs(left);
912 if (SvIV(right))
b448e4fe 913 PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
a0d0e21e 914 else
b448e4fe 915 PUSHs(sv_2mortal(newSVuv(O_RDWR)));
a0d0e21e 916 PUSHs(right);
57d3b86d 917 PUTBACK;
864dbfa3 918 call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW		 919 SPAGAIN;
920
921 if (!sv_isobject(TOPs)) {
924508f0
GS		 922 SP--;
923 PUSHMARK(SP);
a0d0e21e
LW		 924 PUSHs(sv);
925 PUSHs(left);
b448e4fe 926 PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
a0d0e21e 927 PUSHs(right);
a0d0e21e 928 PUTBACK;
864dbfa3 929 call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW		 930 SPAGAIN;
931 }
932
6b05c17a 933 if (sv_isobject(TOPs)) {
14befaf4
DM		 934 sv_unmagic((SV *) hv, PERL_MAGIC_tied);
935 sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, Nullch, 0);
6b05c17a 936 }
a0d0e21e
LW		 937 LEAVE;
938 RETURN;
939}
940
941PP(pp_dbmclose)
942{
cea2e8a9 943 return pp_untie();
a0d0e21e
LW		 944}
945
946PP(pp_sselect)
947{
a0d0e21e 948#ifdef HAS_SELECT
9cad6237 949 dSP; dTARGET;
a0d0e21e
LW		 950 register I32 i;
951 register I32 j;
952 register char *s;
953 register SV *sv;
65202027 954 NV value;
a0d0e21e
LW		 955 I32 maxlen = 0;
956 I32 nfound;
957 struct timeval timebuf;
958 struct timeval *tbuf = &timebuf;
959 I32 growsize;
960 char *fd_sets[4];
2d8e6c8d 961 STRLEN n_a;
a0d0e21e
LW		 962#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
963 I32 masksize;
964 I32 offset;
965 I32 k;
966
967# if BYTEORDER & 0xf0000
968# define ORDERBYTE (0x88888888 - BYTEORDER)
969# else
970# define ORDERBYTE (0x4444 - BYTEORDER)
971# endif
972
973#endif
974
975 SP -= 4;
976 for (i = 1; i <= 3; i++) {
977 if (!SvPOK(SP[i]))
978 continue;
979 j = SvCUR(SP[i]);
980 if (maxlen < j)
981 maxlen = j;
982 }
983
5ff3f7a4 984/* little endians can use vecs directly */
a0d0e21e 985#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
5ff3f7a4 986# if SELECT_MIN_BITS > 1
f2da832e
JH		 987 /* If SELECT_MIN_BITS is greater than one we most probably will want
988 * to align the sizes with SELECT_MIN_BITS/8 because for example
989 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
f556e5b9 990 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
8f1f23e8 991 * on (sets/tests/clears bits) is 32 bits. */
f2da832e 992 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
5ff3f7a4 993# else
4633a7c4 994 growsize = sizeof(fd_set);
5ff3f7a4
GS		 995# endif
996# else
997# ifdef NFDBITS
a0d0e21e 998
5ff3f7a4
GS		 999# ifndef NBBY
1000# define NBBY 8
1001# endif
a0d0e21e
LW		 1002
1003 masksize = NFDBITS / NBBY;
5ff3f7a4 1004# else
a0d0e21e 1005 masksize = sizeof(long); /* documented int, everyone seems to use long */
5ff3f7a4 1006# endif
a0d0e21e
LW		 1007 growsize = maxlen + (masksize - (maxlen % masksize));
1008 Zero(&fd_sets[0], 4, char*);
1009#endif
1010
1011 sv = SP[4];
1012 if (SvOK(sv)) {
1013 value = SvNV(sv);
1014 if (value < 0.0)
1015 value = 0.0;
1016 timebuf.tv_sec = (long)value;
65202027 1017 value -= (NV)timebuf.tv_sec;
a0d0e21e
LW		 1018 timebuf.tv_usec = (long)(value * 1000000.0);
1019 }
1020 else
1021 tbuf = Null(struct timeval*);
1022
1023 for (i = 1; i <= 3; i++) {
1024 sv = SP[i];
1025 if (!SvOK(sv)) {
1026 fd_sets[i] = 0;
1027 continue;
1028 }
1029 else if (!SvPOK(sv))
2d8e6c8d 1030 SvPV_force(sv,n_a); /* force string conversion */
a0d0e21e
LW		 1031 j = SvLEN(sv);
1032 if (j < growsize) {
1033 Sv_Grow(sv, growsize);
a0d0e21e 1034 }
c07a80fd 1035 j = SvCUR(sv);
1036 s = SvPVX(sv) + j;
1037 while (++j <= growsize) {
1038 *s++ = '\0';
1039 }
1040
a0d0e21e
LW		 1041#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1042 s = SvPVX(sv);
1043 New(403, fd_sets[i], growsize, char);
1044 for (offset = 0; offset < growsize; offset += masksize) {
1045 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1046 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1047 }
1048#else
1049 fd_sets[i] = SvPVX(sv);
1050#endif
1051 }
1052
6ad3d225 1053 nfound = PerlSock_select(
a0d0e21e
LW		 1054 maxlen * 8,
1055 (Select_fd_set_t) fd_sets[1],
1056 (Select_fd_set_t) fd_sets[2],
1057 (Select_fd_set_t) fd_sets[3],
1058 tbuf);
1059 for (i = 1; i <= 3; i++) {
1060 if (fd_sets[i]) {
1061 sv = SP[i];
1062#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1063 s = SvPVX(sv);
1064 for (offset = 0; offset < growsize; offset += masksize) {
1065 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1066 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1067 }
1068 Safefree(fd_sets[i]);
1069#endif
1070 SvSETMAGIC(sv);
1071 }
1072 }
1073
1074 PUSHi(nfound);
1075 if (GIMME == G_ARRAY && tbuf) {
65202027
DS		 1076 value = (NV)(timebuf.tv_sec) +
1077 (NV)(timebuf.tv_usec) / 1000000.0;
3280af22 1078 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 1079 sv_setnv(sv, value);
1080 }
1081 RETURN;
1082#else
cea2e8a9 1083 DIE(aTHX_ "select not implemented");
a0d0e21e
LW		 1084#endif
1085}
1086
4633a7c4 1087void
864dbfa3 1088Perl_setdefout(pTHX_ GV *gv)
4633a7c4
LW		 1089{
1090 if (gv)
1091 (void)SvREFCNT_inc(gv);
3280af22
NIS		 1092 if (PL_defoutgv)
1093 SvREFCNT_dec(PL_defoutgv);
1094 PL_defoutgv = gv;
4633a7c4
LW		 1095}
1096
a0d0e21e
LW		 1097PP(pp_select)
1098{
39644a26 1099 dSP; dTARGET;
4633a7c4
LW		 1100 GV *newdefout, *egv;
1101 HV *hv;
1102
533c011a 1103 newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
4633a7c4 1104
3280af22 1105 egv = GvEGV(PL_defoutgv);
4633a7c4 1106 if (!egv)
3280af22 1107 egv = PL_defoutgv;
4633a7c4
LW		 1108 hv = GvSTASH(egv);
1109 if (! hv)
3280af22 1110 XPUSHs(&PL_sv_undef);
4633a7c4 1111 else {
cbdc8872 1112 GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
f86702cc 1113 if (gvp && *gvp == egv) {
f7aaccc2 1114 gv_efullname4(TARG, PL_defoutgv, Nullch, TRUE);
f86702cc 1115 XPUSHTARG;
1116 }
1117 else {
1118 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1119 }
4633a7c4
LW		 1120 }
1121
1122 if (newdefout) {
ded8aa31
GS		 1123 if (!GvIO(newdefout))
1124 gv_IOadd(newdefout);
4633a7c4
LW		 1125 setdefout(newdefout);
1126 }
1127
a0d0e21e
LW		 1128 RETURN;
1129}
1130
1131PP(pp_getc)
1132{
39644a26 1133 dSP; dTARGET;
a0d0e21e 1134 GV *gv;
5b468f54 1135 IO *io;
2ae324a7 1136 MAGIC *mg;
a0d0e21e 1137
32da55ab 1138 if (MAXARG == 0)
3280af22 1139 gv = PL_stdingv;
a0d0e21e
LW		 1140 else
1141 gv = (GV*)POPs;
2ae324a7 1142
5b468f54
AMS		 1143 if (gv && (io = GvIO(gv))
1144 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1145 {
54310121 1146 I32 gimme = GIMME_V;
2ae324a7 1147 PUSHMARK(SP);
5b468f54 1148 XPUSHs(SvTIED_obj((SV*)io, mg));
2ae324a7 1149 PUTBACK;
1150 ENTER;
864dbfa3 1151 call_method("GETC", gimme);
2ae324a7 1152 LEAVE;
1153 SPAGAIN;
54310121 1154 if (gimme == G_SCALAR)
1155 SvSetMagicSV_nosteal(TARG, TOPs);
2ae324a7 1156 RETURN;
1157 }
9bc64814 1158 if (!gv || do_eof(gv)) /* make sure we have fp with something */
a0d0e21e 1159 RETPUSHUNDEF;
bbce6d69 1160 TAINT;
a0d0e21e 1161 sv_setpv(TARG, " ");
9bc64814 1162 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
7d59b7e4
NIS		 1163 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1164 /* Find out how many bytes the char needs */
1165 Size_t len = UTF8SKIP(SvPVX(TARG));
1166 if (len > 1) {
1167 SvGROW(TARG,len+1);
1168 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1169 SvCUR_set(TARG,1+len);
1170 }
1171 SvUTF8_on(TARG);
1172 }
a0d0e21e
LW		 1173 PUSHTARG;
1174 RETURN;
1175}
1176
1177PP(pp_read)
1178{
cea2e8a9 1179 return pp_sysread();
a0d0e21e
LW		 1180}
1181
76e3520e 1182STATIC OP *
cea2e8a9 1183S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
a0d0e21e 1184{
c09156bb 1185 register PERL_CONTEXT *cx;
54310121 1186 I32 gimme = GIMME_V;
a0d0e21e
LW		 1187 AV* padlist = CvPADLIST(cv);
1188 SV** svp = AvARRAY(padlist);
1189
1190 ENTER;
1191 SAVETMPS;
1192
1193 push_return(retop);
146174a9 1194 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
a0d0e21e 1195 PUSHFORMAT(cx);
146174a9 1196 SAVEVPTR(PL_curpad);
3280af22 1197 PL_curpad = AvARRAY((AV*)svp[1]);
a0d0e21e 1198
4633a7c4 1199 setdefout(gv); /* locally select filehandle so $% et al work */
a0d0e21e
LW		 1200 return CvSTART(cv);
1201}
1202
1203PP(pp_enterwrite)
1204{
39644a26 1205 dSP;
a0d0e21e
LW		 1206 register GV *gv;
1207 register IO *io;
1208 GV *fgv;
1209 CV *cv;
1210
1211 if (MAXARG == 0)
3280af22 1212 gv = PL_defoutgv;
a0d0e21e
LW		 1213 else {
1214 gv = (GV*)POPs;
1215 if (!gv)
3280af22 1216 gv = PL_defoutgv;
a0d0e21e
LW		 1217 }
1218 EXTEND(SP, 1);
1219 io = GvIO(gv);
1220 if (!io) {
1221 RETPUSHNO;
1222 }
1223 if (IoFMT_GV(io))
1224 fgv = IoFMT_GV(io);
1225 else
1226 fgv = gv;
1227
1228 cv = GvFORM(fgv);
a0d0e21e 1229 if (!cv) {
2dd78f96 1230 char *name = NULL;
a0d0e21e 1231 if (fgv) {
748a9306 1232 SV *tmpsv = sv_newmortal();
43693395 1233 gv_efullname4(tmpsv, fgv, Nullch, FALSE);
2dd78f96 1234 name = SvPV_nolen(tmpsv);
a0d0e21e 1235 }
2dd78f96
JH		 1236 if (name && *name)
1237 DIE(aTHX_ "Undefined format \"%s\" called", name);
cea2e8a9 1238 DIE(aTHX_ "Not a format reference");
a0d0e21e 1239 }
44a8e56a 1240 if (CvCLONE(cv))
1241 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
a0d0e21e 1242
44a8e56a 1243 IoFLAGS(io) &= ~IOf_DIDTOP;
533c011a 1244 return doform(cv,gv,PL_op->op_next);
a0d0e21e
LW		 1245}
1246
1247PP(pp_leavewrite)
1248{
39644a26 1249 dSP;
a0d0e21e
LW		 1250 GV *gv = cxstack[cxstack_ix].blk_sub.gv;
1251 register IO *io = GvIOp(gv);
760ac839
LW		 1252 PerlIO *ofp = IoOFP(io);
1253 PerlIO *fp;
a0d0e21e
LW		 1254 SV **newsp;
1255 I32 gimme;
c09156bb 1256 register PERL_CONTEXT *cx;
a0d0e21e 1257
760ac839 1258 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
3280af22 1259 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
7ef822cd
JH		 1260 if (!io || !ofp)
1261 goto forget_top;
3280af22
NIS		 1262 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1263 PL_formtarget != PL_toptarget)
a0d0e21e 1264 {
4633a7c4
LW		 1265 GV *fgv;
1266 CV *cv;
a0d0e21e
LW		 1267 if (!IoTOP_GV(io)) {
1268 GV *topgv;
46fc3d4c 1269 SV *topname;
a0d0e21e
LW		 1270
1271 if (!IoTOP_NAME(io)) {
1272 if (!IoFMT_NAME(io))
1273 IoFMT_NAME(io) = savepv(GvNAME(gv));
cea2e8a9 1274 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", IoFMT_NAME(io)));
46fc3d4c 1275 topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
748a9306 1276 if ((topgv && GvFORM(topgv)) ||
a0d0e21e 1277 !gv_fetchpv("top",FALSE,SVt_PVFM))
46fc3d4c 1278 IoTOP_NAME(io) = savepv(SvPVX(topname));
a0d0e21e
LW		 1279 else
1280 IoTOP_NAME(io) = savepv("top");
1281 }
1282 topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1283 if (!topgv || !GvFORM(topgv)) {
1284 IoLINES_LEFT(io) = 100000000;
1285 goto forget_top;
1286 }
1287 IoTOP_GV(io) = topgv;
1288 }
748a9306
LW		 1289 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1290 I32 lines = IoLINES_LEFT(io);
3280af22 1291 char *s = SvPVX(PL_formtarget);
8e07c86e
AD		 1292 if (lines <= 0) /* Yow, header didn't even fit!!! */
1293 goto forget_top;
748a9306
LW		 1294 while (lines-- > 0) {
1295 s = strchr(s, '\n');
1296 if (!s)
1297 break;
1298 s++;
1299 }
1300 if (s) {
d75029d0
NIS		 1301 STRLEN save = SvCUR(PL_formtarget);
1302 SvCUR_set(PL_formtarget, s - SvPVX(PL_formtarget));
1303 do_print(PL_formtarget, ofp);
1304 SvCUR_set(PL_formtarget, save);
3280af22
NIS		 1305 sv_chop(PL_formtarget, s);
1306 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
748a9306
LW		 1307 }
1308 }
a0d0e21e 1309 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
d75029d0 1310 do_print(PL_formfeed, ofp);
a0d0e21e
LW		 1311 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1312 IoPAGE(io)++;
3280af22 1313 PL_formtarget = PL_toptarget;
748a9306 1314 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4
LW		 1315 fgv = IoTOP_GV(io);
1316 if (!fgv)
cea2e8a9 1317 DIE(aTHX_ "bad top format reference");
4633a7c4 1318 cv = GvFORM(fgv);
2dd78f96
JH		 1319 {
1320 char *name = NULL;
1321 if (!cv) {
1322 SV *sv = sv_newmortal();
1323 gv_efullname4(sv, fgv, Nullch, FALSE);
1324 name = SvPV_nolen(sv);
1325 }
1326 if (name && *name)
1327 DIE(aTHX_ "Undefined top format \"%s\" called",name);
1328 /* why no:
1329 else
1330 DIE(aTHX_ "Undefined top format called");
1331 ?*/
4633a7c4 1332 }
44a8e56a 1333 if (CvCLONE(cv))
1334 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
533c011a 1335 return doform(cv,gv,PL_op);
a0d0e21e
LW		 1336 }
1337
1338 forget_top:
3280af22 1339 POPBLOCK(cx,PL_curpm);
a0d0e21e
LW		 1340 POPFORMAT(cx);
1341 LEAVE;
1342
1343 fp = IoOFP(io);
1344 if (!fp) {
599cee73 1345 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
cb50131a 1346 if (IoIFP(io)) {
2dd78f96
JH		 1347 /* integrate with report_evil_fh()? */
1348 char *name = NULL;
1349 if (isGV(gv)) {
1350 SV* sv = sv_newmortal();
1351 gv_efullname4(sv, gv, Nullch, FALSE);
1352 name = SvPV_nolen(sv);
1353 }
1354 if (name && *name)
1355 Perl_warner(aTHX_ WARN_IO,
1356 "Filehandle %s opened only for input", name);
1357 else
1358 Perl_warner(aTHX_ WARN_IO,
1359 "Filehandle opened only for input");
cb50131a 1360 }
599cee73 1361 else if (ckWARN(WARN_CLOSED))
bc37a18f 1362 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 1363 }
3280af22 1364 PUSHs(&PL_sv_no);
a0d0e21e
LW		 1365 }
1366 else {
3280af22 1367 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
599cee73 1368 if (ckWARN(WARN_IO))
cea2e8a9 1369 Perl_warner(aTHX_ WARN_IO, "page overflow");
a0d0e21e 1370 }
d75029d0 1371 if (!do_print(PL_formtarget, fp))
3280af22 1372 PUSHs(&PL_sv_no);
a0d0e21e 1373 else {
3280af22
NIS		 1374 FmLINES(PL_formtarget) = 0;
1375 SvCUR_set(PL_formtarget, 0);
1376 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1377 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1378 (void)PerlIO_flush(fp);
3280af22 1379 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1380 }
1381 }
9cbac4c7 1382 /* bad_ofp: */
3280af22 1383 PL_formtarget = PL_bodytarget;
a0d0e21e
LW		 1384 PUTBACK;
1385 return pop_return();
1386}
1387
1388PP(pp_prtf)
1389{
39644a26 1390 dSP; dMARK; dORIGMARK;
a0d0e21e
LW		 1391 GV *gv;
1392 IO *io;
760ac839 1393 PerlIO *fp;
26db47c4 1394 SV *sv;
46fc3d4c 1395 MAGIC *mg;
a0d0e21e 1396
533c011a 1397 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW		 1398 gv = (GV*)*++MARK;
1399 else
3280af22 1400 gv = PL_defoutgv;
46fc3d4c 1401
5b468f54
AMS		 1402 if (gv && (io = GvIO(gv))
1403 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1404 {
46fc3d4c 1405 if (MARK == ORIGMARK) {
4352c267 1406 MEXTEND(SP, 1);
46fc3d4c 1407 ++MARK;
1408 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1409 ++SP;
1410 }
1411 PUSHMARK(MARK - 1);
5b468f54 1412 *MARK = SvTIED_obj((SV*)io, mg);
46fc3d4c 1413 PUTBACK;
1414 ENTER;
864dbfa3 1415 call_method("PRINTF", G_SCALAR);
46fc3d4c 1416 LEAVE;
1417 SPAGAIN;
1418 MARK = ORIGMARK + 1;
1419 *MARK = *SP;
1420 SP = MARK;
1421 RETURN;
1422 }
1423
26db47c4 1424 sv = NEWSV(0,0);
a0d0e21e 1425 if (!(io = GvIO(gv))) {
2dd78f96
JH		 1426 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1427 report_evil_fh(gv, io, PL_op->op_type);
91487cfc 1428 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1429 goto just_say_no;
1430 }
1431 else if (!(fp = IoOFP(io))) {
599cee73 1432 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
2dd78f96 1433 /* integrate with report_evil_fh()? */
cb50131a 1434 if (IoIFP(io)) {
2dd78f96
JH		 1435 char *name = NULL;
1436 if (isGV(gv)) {
1437 gv_efullname4(sv, gv, Nullch, FALSE);
1438 name = SvPV_nolen(sv);
1439 }
1440 if (name && *name)
1441 Perl_warner(aTHX_ WARN_IO,
1442 "Filehandle %s opened only for input", name);
1443 else
1444 Perl_warner(aTHX_ WARN_IO,
1445 "Filehandle opened only for input");
cb50131a 1446 }
599cee73 1447 else if (ckWARN(WARN_CLOSED))
bc37a18f 1448 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 1449 }
91487cfc 1450 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
a0d0e21e
LW		 1451 goto just_say_no;
1452 }
1453 else {
1454 do_sprintf(sv, SP - MARK, MARK + 1);
1455 if (!do_print(sv, fp))
1456 goto just_say_no;
1457
1458 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1459 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW		 1460 goto just_say_no;
1461 }
1462 SvREFCNT_dec(sv);
1463 SP = ORIGMARK;
3280af22 1464 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1465 RETURN;
1466
1467 just_say_no:
1468 SvREFCNT_dec(sv);
1469 SP = ORIGMARK;
3280af22 1470 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 1471 RETURN;
1472}
1473
c07a80fd 1474PP(pp_sysopen)
1475{
39644a26 1476 dSP;
c07a80fd 1477 GV *gv;
c07a80fd 1478 SV *sv;
1479 char *tmps;
1480 STRLEN len;
1481 int mode, perm;
1482
1483 if (MAXARG > 3)
1484 perm = POPi;
1485 else
1486 perm = 0666;
1487 mode = POPi;
1488 sv = POPs;
1489 gv = (GV *)POPs;
1490
4592e6ca
NIS		 1491 /* Need TIEHANDLE method ? */
1492
c07a80fd 1493 tmps = SvPV(sv, len);
1494 if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1495 IoLINES(GvIOp(gv)) = 0;
3280af22 1496 PUSHs(&PL_sv_yes);
c07a80fd 1497 }
1498 else {
3280af22 1499 PUSHs(&PL_sv_undef);
c07a80fd 1500 }
1501 RETURN;
1502}
1503
a0d0e21e
LW		 1504PP(pp_sysread)
1505{
39644a26 1506 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1507 int offset;
1508 GV *gv;
1509 IO *io;
1510 char *buffer;
5b54f415 1511 SSize_t length;
eb5c063a 1512 SSize_t count;
1e422769 1513 Sock_size_t bufsize;
748a9306 1514 SV *bufsv;
a0d0e21e 1515 STRLEN blen;
2ae324a7 1516 MAGIC *mg;
eb5c063a
NIS		 1517 int fp_utf8;
1518 Size_t got = 0;
1519 Size_t wanted;
1d636c13 1520 bool charstart = FALSE;
87330c3c
JH		 1521 STRLEN charskip = 0;
1522 STRLEN skip = 0;
a0d0e21e
LW		 1523
1524 gv = (GV*)*++MARK;
5b468f54
AMS		 1525 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1526 && gv && (io = GvIO(gv))
1527 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
137443ea 1528 {
2ae324a7 1529 SV *sv;
1530
1531 PUSHMARK(MARK-1);
5b468f54 1532 *MARK = SvTIED_obj((SV*)io, mg);
2ae324a7 1533 ENTER;
864dbfa3 1534 call_method("READ", G_SCALAR);
2ae324a7 1535 LEAVE;
1536 SPAGAIN;
1537 sv = POPs;
1538 SP = ORIGMARK;
1539 PUSHs(sv);
1540 RETURN;
1541 }
1542
a0d0e21e
LW		 1543 if (!gv)
1544 goto say_undef;
748a9306 1545 bufsv = *++MARK;
ff68c719 1546 if (! SvOK(bufsv))
1547 sv_setpvn(bufsv, "", 0);
a0d0e21e 1548 length = SvIVx(*++MARK);
748a9306 1549 SETERRNO(0,0);
a0d0e21e
LW		 1550 if (MARK < SP)
1551 offset = SvIVx(*++MARK);
1552 else
1553 offset = 0;
1554 io = GvIO(gv);
1555 if (!io || !IoIFP(io))
1556 goto say_undef;
0064a8a9 1557 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
7d59b7e4 1558 buffer = SvPVutf8_force(bufsv, blen);
eb5c063a
NIS		 1559 /* UTF8 may not have been set if they are all low bytes */
1560 SvUTF8_on(bufsv);
7d59b7e4
NIS		 1561 }
1562 else {
1563 buffer = SvPV_force(bufsv, blen);
1564 }
1565 if (length < 0)
1566 DIE(aTHX_ "Negative length");
eb5c063a 1567 wanted = length;
7d59b7e4 1568
d0965105
JH		 1569 charstart = TRUE;
1570 charskip = 0;
87330c3c 1571 skip = 0;
d0965105 1572
a0d0e21e 1573#ifdef HAS_SOCKET
533c011a 1574 if (PL_op->op_type == OP_RECV) {
46fc3d4c 1575 char namebuf[MAXPATHLEN];
eec2d3df 1576#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
490ab354
JH		 1577 bufsize = sizeof (struct sockaddr_in);
1578#else
46fc3d4c 1579 bufsize = sizeof namebuf;
490ab354 1580#endif
abf95952
IZ		 1581#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1582 if (bufsize >= 256)
1583 bufsize = 255;
1584#endif
748a9306 1585 buffer = SvGROW(bufsv, length+1);
bbce6d69 1586 /* 'offset' means 'flags' here */
eb5c063a 1587 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
46fc3d4c 1588 (struct sockaddr *)namebuf, &bufsize);
eb5c063a 1589 if (count < 0)
a0d0e21e 1590 RETPUSHUNDEF;
4107cc59
OF		 1591#ifdef EPOC
1592 /* Bogus return without padding */
1593 bufsize = sizeof (struct sockaddr_in);
1594#endif
eb5c063a 1595 SvCUR_set(bufsv, count);
748a9306
LW		 1596 *SvEND(bufsv) = '\0';
1597 (void)SvPOK_only(bufsv);
eb5c063a
NIS		 1598 if (fp_utf8)
1599 SvUTF8_on(bufsv);
748a9306 1600 SvSETMAGIC(bufsv);
aac0dd9a 1601 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1602 if (!(IoFLAGS(io) & IOf_UNTAINT))
1603 SvTAINTED_on(bufsv);
a0d0e21e 1604 SP = ORIGMARK;
46fc3d4c 1605 sv_setpvn(TARG, namebuf, bufsize);
a0d0e21e
LW		 1606 PUSHs(TARG);
1607 RETURN;
1608 }
1609#else
911d147d 1610 if (PL_op->op_type == OP_RECV)
cea2e8a9 1611 DIE(aTHX_ PL_no_sock_func, "recv");
a0d0e21e 1612#endif
eb5c063a
NIS		 1613 if (DO_UTF8(bufsv)) {
1614 /* offset adjust in characters not bytes */
1615 blen = sv_len_utf8(bufsv);
7d59b7e4 1616 }
bbce6d69 1617 if (offset < 0) {
1618 if (-offset > blen)
cea2e8a9 1619 DIE(aTHX_ "Offset outside string");
bbce6d69 1620 offset += blen;
1621 }
eb5c063a
NIS		 1622 if (DO_UTF8(bufsv)) {
1623 /* convert offset-as-chars to offset-as-bytes */
1624 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1625 }
1626 more_bytes:
cd52b7b2 1627 bufsize = SvCUR(bufsv);
eb5c063a 1628 buffer = SvGROW(bufsv, length+offset+1);
cd52b7b2 1629 if (offset > bufsize) { /* Zero any newly allocated space */
1630 Zero(buffer+bufsize, offset-bufsize, char);
1631 }
eb5c063a
NIS		 1632 buffer = buffer + offset;
1633
533c011a 1634 if (PL_op->op_type == OP_SYSREAD) {
a7092146 1635#ifdef PERL_SOCK_SYSREAD_IS_RECV
50952442 1636 if (IoTYPE(io) == IoTYPE_SOCKET) {
eb5c063a
NIS		 1637 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1638 buffer, length, 0);
a7092146
GS		 1639 }
1640 else
1641#endif
1642 {
eb5c063a
NIS		 1643 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1644 buffer, length);
a7092146 1645 }
a0d0e21e
LW		 1646 }
1647 else
1648#ifdef HAS_SOCKET__bad_code_maybe
50952442 1649 if (IoTYPE(io) == IoTYPE_SOCKET) {
46fc3d4c 1650 char namebuf[MAXPATHLEN];
490ab354
JH		 1651#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1652 bufsize = sizeof (struct sockaddr_in);
1653#else
46fc3d4c 1654 bufsize = sizeof namebuf;
490ab354 1655#endif
eb5c063a 1656 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
46fc3d4c 1657 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1658 }
1659 else
1660#endif
3b02c43c 1661 {
eb5c063a
NIS		 1662 count = PerlIO_read(IoIFP(io), buffer, length);
1663 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1664 if (count == 0 && PerlIO_error(IoIFP(io)))
1665 count = -1;
3b02c43c 1666 }
eb5c063a 1667 if (count < 0) {
a00b5bd3 1668 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
af8c498a 1669 {
2dd78f96
JH		 1670 /* integrate with report_evil_fh()? */
1671 char *name = NULL;
1672 if (isGV(gv)) {
1673 SV* sv = sv_newmortal();
1674 gv_efullname4(sv, gv, Nullch, FALSE);
1675 name = SvPV_nolen(sv);
1676 }
1677 if (name && *name)
1678 Perl_warner(aTHX_ WARN_IO,
1679 "Filehandle %s opened only for output", name);
1680 else
1681 Perl_warner(aTHX_ WARN_IO,
1682 "Filehandle opened only for output");
af8c498a 1683 }
a0d0e21e 1684 goto say_undef;
af8c498a 1685 }
eb5c063a 1686 SvCUR_set(bufsv, count+(buffer - SvPVX(bufsv)));
748a9306
LW		 1687 *SvEND(bufsv) = '\0';
1688 (void)SvPOK_only(bufsv);
0064a8a9 1689 if (fp_utf8 && !IN_BYTES) {
eb5c063a
NIS		 1690 /* Look at utf8 we got back and count the characters */
1691 char *bend = buffer + count;
1692 while (buffer < bend) {
d0965105
JH		 1693 if (charstart) {
1694 skip = UTF8SKIP(buffer);
1695 charskip = 0;
1696 }
1697 if (buffer - charskip + skip > bend) {
eb5c063a
NIS		 1698 /* partial character - try for rest of it */
1699 length = skip - (bend-buffer);
1700 offset = bend - SvPVX(bufsv);
d0965105
JH		 1701 charstart = FALSE;
1702 charskip += count;
eb5c063a
NIS		 1703 goto more_bytes;
1704 }
1705 else {
1706 got++;
1707 buffer += skip;
d0965105
JH		 1708 charstart = TRUE;
1709 charskip = 0;
eb5c063a
NIS		 1710 }
1711 }
1712 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1713 provided amount read (count) was what was requested (length)
1714 */
1715 if (got < wanted && count == length) {
d0965105 1716 length = wanted - got;
eb5c063a
NIS		 1717 offset = bend - SvPVX(bufsv);
1718 goto more_bytes;
1719 }
1720 /* return value is character count */
1721 count = got;
1722 SvUTF8_on(bufsv);
1723 }
748a9306 1724 SvSETMAGIC(bufsv);
aac0dd9a 1725 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1726 if (!(IoFLAGS(io) & IOf_UNTAINT))
1727 SvTAINTED_on(bufsv);
a0d0e21e 1728 SP = ORIGMARK;
eb5c063a 1729 PUSHi(count);
a0d0e21e
LW		 1730 RETURN;
1731
1732 say_undef:
1733 SP = ORIGMARK;
1734 RETPUSHUNDEF;
1735}
1736
1737PP(pp_syswrite)
1738{
39644a26 1739 dSP;
092bebab
JH		 1740 int items = (SP - PL_stack_base) - TOPMARK;
1741 if (items == 2) {
9f089d78 1742 SV *sv;
092bebab 1743 EXTEND(SP, 1);
9f089d78
SB		 1744 sv = sv_2mortal(newSViv(sv_len(*SP)));
1745 PUSHs(sv);
092bebab
JH		 1746 PUTBACK;
1747 }
cea2e8a9 1748 return pp_send();
a0d0e21e
LW		 1749}
1750
1751PP(pp_send)
1752{
39644a26 1753 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1754 GV *gv;
1755 IO *io;
748a9306 1756 SV *bufsv;
a0d0e21e 1757 char *buffer;
8c99d73e
GS		 1758 Size_t length;
1759 SSize_t retval;
a0d0e21e 1760 STRLEN blen;
1d603a67 1761 MAGIC *mg;
a0d0e21e
LW		 1762
1763 gv = (GV*)*++MARK;
14befaf4 1764 if (PL_op->op_type == OP_SYSWRITE
5b468f54
AMS		 1765 && gv && (io = GvIO(gv))
1766 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
14befaf4 1767 {
1d603a67
GB		 1768 SV *sv;
1769
1770 PUSHMARK(MARK-1);
5b468f54 1771 *MARK = SvTIED_obj((SV*)io, mg);
1d603a67 1772 ENTER;
864dbfa3 1773 call_method("WRITE", G_SCALAR);
1d603a67
GB		 1774 LEAVE;
1775 SPAGAIN;
1776 sv = POPs;
1777 SP = ORIGMARK;
1778 PUSHs(sv);
1779 RETURN;
1780 }
a0d0e21e
LW		 1781 if (!gv)
1782 goto say_undef;
748a9306 1783 bufsv = *++MARK;
8c99d73e 1784#if Size_t_size > IVSIZE
3c001241 1785 length = (Size_t)SvNVx(*++MARK);
146174a9 1786#else
3c001241 1787 length = (Size_t)SvIVx(*++MARK);
146174a9 1788#endif
3c001241 1789 if ((SSize_t)length < 0)
cea2e8a9 1790 DIE(aTHX_ "Negative length");
748a9306 1791 SETERRNO(0,0);
a0d0e21e
LW		 1792 io = GvIO(gv);
1793 if (!io || !IoIFP(io)) {
8c99d73e 1794 retval = -1;
bc37a18f
RG		 1795 if (ckWARN(WARN_CLOSED))
1796 report_evil_fh(gv, io, PL_op->op_type);
7d59b7e4
NIS		 1797 goto say_undef;
1798 }
1799
1800 if (PerlIO_isutf8(IoIFP(io))) {
1801 buffer = SvPVutf8(bufsv, blen);
a0d0e21e 1802 }
7d59b7e4
NIS		 1803 else {
1804 if (DO_UTF8(bufsv))
1805 sv_utf8_downgrade(bufsv, FALSE);
1806 buffer = SvPV(bufsv, blen);
1807 }
1808
1809 if (PL_op->op_type == OP_SYSWRITE) {
1810 IV offset;
1811 if (DO_UTF8(bufsv)) {
1812 /* length and offset are in chars */
1813 blen = sv_len_utf8(bufsv);
1814 }
bbce6d69 1815 if (MARK < SP) {
a0d0e21e 1816 offset = SvIVx(*++MARK);
bbce6d69 1817 if (offset < 0) {
1818 if (-offset > blen)
cea2e8a9 1819 DIE(aTHX_ "Offset outside string");
bbce6d69 1820 offset += blen;
fb73857a 1821 } else if (offset >= blen && blen > 0)
cea2e8a9 1822 DIE(aTHX_ "Offset outside string");
bbce6d69 1823 } else
a0d0e21e
LW		 1824 offset = 0;
1825 if (length > blen - offset)
1826 length = blen - offset;
7d59b7e4 1827 if (DO_UTF8(bufsv)) {
c8d31a35 1828 buffer = (char*)utf8_hop((U8 *)buffer, offset);
7d59b7e4
NIS		 1829 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1830 }
1831 else {
1832 buffer = buffer+offset;
1833 }
a7092146 1834#ifdef PERL_SOCK_SYSWRITE_IS_SEND
50952442 1835 if (IoTYPE(io) == IoTYPE_SOCKET) {
8c99d73e 1836 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
7d59b7e4 1837 buffer, length, 0);
a7092146
GS		 1838 }
1839 else
1840#endif
1841 {
94e4c244 1842 /* See the note at doio.c:do_print about filesize limits. --jhi */
8c99d73e 1843 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
7d59b7e4 1844 buffer, length);
c88828dc
JH		 1845 if (DO_UTF8(bufsv))
1846 retval = utf8_length((U8*)SvPVX(bufsv),
1847 (U8*)SvPVX(bufsv) + retval);
a7092146 1848 }
a0d0e21e
LW		 1849 }
1850#ifdef HAS_SOCKET
1851 else if (SP > MARK) {
1852 char *sockbuf;
1853 STRLEN mlen;
1854 sockbuf = SvPVx(*++MARK, mlen);
7d59b7e4 1855 /* length is really flags */
8c99d73e
GS		 1856 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1857 length, (struct sockaddr *)sockbuf, mlen);
a0d0e21e
LW		 1858 }
1859 else
7d59b7e4 1860 /* length is really flags */
8c99d73e 1861 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
a0d0e21e
LW		 1862#else
1863 else
cea2e8a9 1864 DIE(aTHX_ PL_no_sock_func, "send");
a0d0e21e 1865#endif
8c99d73e 1866 if (retval < 0)
a0d0e21e
LW		 1867 goto say_undef;
1868 SP = ORIGMARK;
8c99d73e
GS		 1869#if Size_t_size > IVSIZE
1870 PUSHn(retval);
1871#else
1872 PUSHi(retval);
1873#endif
a0d0e21e
LW		 1874 RETURN;
1875
1876 say_undef:
1877 SP = ORIGMARK;
1878 RETPUSHUNDEF;
1879}
1880
1881PP(pp_recv)
1882{
cea2e8a9 1883 return pp_sysread();
a0d0e21e
LW		 1884}
1885
1886PP(pp_eof)
1887{
39644a26 1888 dSP;
a0d0e21e 1889 GV *gv;
5b468f54 1890 IO *io;
4592e6ca 1891 MAGIC *mg;
a0d0e21e 1892
32da55ab 1893 if (MAXARG == 0) {
146174a9
CB		 1894 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
1895 IO *io;
1896 gv = PL_last_in_gv = PL_argvgv;
1897 io = GvIO(gv);
1898 if (io && !IoIFP(io)) {
1899 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
1900 IoLINES(io) = 0;
1901 IoFLAGS(io) &= ~IOf_START;
1902 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, Nullfp);
1903 sv_setpvn(GvSV(gv), "-", 1);
1904 SvSETMAGIC(GvSV(gv));
1905 }
1906 else if (!nextargv(gv))
1907 RETPUSHYES;
1908 }
1909 }
1910 else
1911 gv = PL_last_in_gv; /* eof */
1912 }
a0d0e21e 1913 else
146174a9 1914 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
4592e6ca 1915
5b468f54
AMS		 1916 if (gv && (io = GvIO(gv))
1917 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1918 {
4592e6ca 1919 PUSHMARK(SP);
5b468f54 1920 XPUSHs(SvTIED_obj((SV*)io, mg));
4592e6ca
NIS		 1921 PUTBACK;
1922 ENTER;
864dbfa3 1923 call_method("EOF", G_SCALAR);
4592e6ca
NIS		 1924 LEAVE;
1925 SPAGAIN;
1926 RETURN;
1927 }
1928
54310121 1929 PUSHs(boolSV(!gv || do_eof(gv)));
a0d0e21e
LW		 1930 RETURN;
1931}
1932
1933PP(pp_tell)
1934{
39644a26 1935 dSP; dTARGET;
301e8125 1936 GV *gv;
5b468f54 1937 IO *io;
4592e6ca 1938 MAGIC *mg;
a0d0e21e 1939
32da55ab 1940 if (MAXARG == 0)
3280af22 1941 gv = PL_last_in_gv;
a0d0e21e 1942 else
3280af22 1943 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca 1944
5b468f54
AMS		 1945 if (gv && (io = GvIO(gv))
1946 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1947 {
4592e6ca 1948 PUSHMARK(SP);
5b468f54 1949 XPUSHs(SvTIED_obj((SV*)io, mg));
4592e6ca
NIS		 1950 PUTBACK;
1951 ENTER;
864dbfa3 1952 call_method("TELL", G_SCALAR);
4592e6ca
NIS		 1953 LEAVE;
1954 SPAGAIN;
1955 RETURN;
1956 }
1957
146174a9
CB		 1958#if LSEEKSIZE > IVSIZE
1959 PUSHn( do_tell(gv) );
1960#else
a0d0e21e 1961 PUSHi( do_tell(gv) );
146174a9 1962#endif
a0d0e21e
LW		 1963 RETURN;
1964}
1965
1966PP(pp_seek)
1967{
cea2e8a9 1968 return pp_sysseek();
137443ea 1969}
1970
1971PP(pp_sysseek)
1972{
39644a26 1973 dSP;
a0d0e21e 1974 GV *gv;
5b468f54 1975 IO *io;
a0d0e21e 1976 int whence = POPi;
146174a9
CB		 1977#if LSEEKSIZE > IVSIZE
1978 Off_t offset = (Off_t)SvNVx(POPs);
1979#else
d9b3e12d 1980 Off_t offset = (Off_t)SvIVx(POPs);
146174a9 1981#endif
4592e6ca 1982 MAGIC *mg;
a0d0e21e 1983
3280af22 1984 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca 1985
5b468f54
AMS		 1986 if (gv && (io = GvIO(gv))
1987 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1988 {
4592e6ca 1989 PUSHMARK(SP);
5b468f54 1990 XPUSHs(SvTIED_obj((SV*)io, mg));
cb50131a
CB		 1991#if LSEEKSIZE > IVSIZE
1992 XPUSHs(sv_2mortal(newSVnv((NV) offset)));
1993#else
b448e4fe 1994 XPUSHs(sv_2mortal(newSViv(offset)));
cb50131a 1995#endif
b448e4fe 1996 XPUSHs(sv_2mortal(newSViv(whence)));
4592e6ca
NIS		 1997 PUTBACK;
1998 ENTER;
864dbfa3 1999 call_method("SEEK", G_SCALAR);
4592e6ca
NIS		 2000 LEAVE;
2001 SPAGAIN;
2002 RETURN;
2003 }
2004
533c011a 2005 if (PL_op->op_type == OP_SEEK)
8903cb82 2006 PUSHs(boolSV(do_seek(gv, offset, whence)));
2007 else {
b448e4fe
JH		 2008 Off_t sought = do_sysseek(gv, offset, whence);
2009 if (sought < 0)
146174a9
CB		 2010 PUSHs(&PL_sv_undef);
2011 else {
b448e4fe 2012 SV* sv = sought ?
146174a9 2013#if LSEEKSIZE > IVSIZE
b448e4fe 2014 newSVnv((NV)sought)
146174a9 2015#else
b448e4fe 2016 newSViv(sought)
146174a9
CB		 2017#endif
2018 : newSVpvn(zero_but_true, ZBTLEN);
2019 PUSHs(sv_2mortal(sv));
2020 }
8903cb82 2021 }
a0d0e21e
LW		 2022 RETURN;
2023}
2024
2025PP(pp_truncate)
2026{
39644a26 2027 dSP;
8c99d73e
GS		 2028 /* There seems to be no consensus on the length type of truncate()
2029 * and ftruncate(), both off_t and size_t have supporters. In
2030 * general one would think that when using large files, off_t is
2031 * at least as wide as size_t, so using an off_t should be okay. */
2032 /* XXX Configure probe for the length type of *truncate() needed XXX */
2033 Off_t len;
a0d0e21e 2034
8c99d73e
GS		 2035#if Size_t_size > IVSIZE
2036 len = (Off_t)POPn;
2037#else
2038 len = (Off_t)POPi;
2039#endif
2040 /* Checking for length < 0 is problematic as the type might or
301e8125 2041 * might not be signed: if it is not, clever compilers will moan. */
8c99d73e 2042 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
748a9306 2043 SETERRNO(0,0);
5d94fbed 2044#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
d05c1ba0
JH		 2045 {
2046 STRLEN n_a;
2047 int result = 1;
2048 GV *tmpgv;
2049
2050 if (PL_op->op_flags & OPf_SPECIAL) {
2051 tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
2052
2053 do_ftruncate:
2054 TAINT_PROPER("truncate");
2055 if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
2056 result = 0;
2057 else {
2058 PerlIO_flush(IoIFP(GvIOp(tmpgv)));
cbdc8872 2059#ifdef HAS_TRUNCATE
d05c1ba0 2060 if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
301e8125 2061#else
d05c1ba0 2062 if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 2063#endif
d05c1ba0
JH		 2064 result = 0;
2065 }
cbdc8872 2066 }
d05c1ba0
JH		 2067 else {
2068 SV *sv = POPs;
2069 char *name;
2070
2071 if (SvTYPE(sv) == SVt_PVGV) {
2072 tmpgv = (GV*)sv; /* *main::FRED for example */
2073 goto do_ftruncate;
2074 }
2075 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2076 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
2077 goto do_ftruncate;
2078 }
1e422769 2079
d05c1ba0
JH		 2080 name = SvPV(sv, n_a);
2081 TAINT_PROPER("truncate");
cbdc8872 2082#ifdef HAS_TRUNCATE
d05c1ba0
JH		 2083 if (truncate(name, len) < 0)
2084 result = 0;
cbdc8872 2085#else
d05c1ba0
JH		 2086 {
2087 int tmpfd;
2088
2089 if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
cbdc8872 2090 result = 0;
d05c1ba0
JH		 2091 else {
2092 if (my_chsize(tmpfd, len) < 0)
2093 result = 0;
2094 PerlLIO_close(tmpfd);
2095 }
cbdc8872 2096 }
a0d0e21e 2097#endif
d05c1ba0 2098 }
a0d0e21e 2099
d05c1ba0
JH		 2100 if (result)
2101 RETPUSHYES;
2102 if (!errno)
91487cfc 2103 SETERRNO(EBADF,RMS$_IFI);
d05c1ba0
JH		 2104 RETPUSHUNDEF;
2105 }
a0d0e21e 2106#else
cea2e8a9 2107 DIE(aTHX_ "truncate not implemented");
a0d0e21e
LW		 2108#endif
2109}
2110
2111PP(pp_fcntl)
2112{
cea2e8a9 2113 return pp_ioctl();
a0d0e21e
LW		 2114}
2115
2116PP(pp_ioctl)
2117{
39644a26 2118 dSP; dTARGET;
748a9306 2119 SV *argsv = POPs;
3bb7c1b4 2120 unsigned int func = POPu;
533c011a 2121 int optype = PL_op->op_type;
a0d0e21e 2122 char *s;
324aa91a 2123 IV retval;
a0d0e21e 2124 GV *gv = (GV*)POPs;
c289d2f7 2125 IO *io = gv ? GvIOn(gv) : 0;
a0d0e21e 2126
748a9306 2127 if (!io || !argsv || !IoIFP(io)) {
c289d2f7
JH		 2128 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2129 report_evil_fh(gv, io, PL_op->op_type);
91487cfc 2130 SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
a0d0e21e
LW		 2131 RETPUSHUNDEF;
2132 }
2133
748a9306 2134 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 2135 STRLEN len;
324aa91a 2136 STRLEN need;
748a9306 2137 s = SvPV_force(argsv, len);
324aa91a
HF		 2138 need = IOCPARM_LEN(func);
2139 if (len < need) {
2140 s = Sv_Grow(argsv, need + 1);
2141 SvCUR_set(argsv, need);
a0d0e21e
LW		 2142 }
2143
748a9306 2144 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW		 2145 }
2146 else {
748a9306 2147 retval = SvIV(argsv);
c529f79d 2148 s = INT2PTR(char*,retval); /* ouch */
a0d0e21e
LW		 2149 }
2150
2151 TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
2152
2153 if (optype == OP_IOCTL)
2154#ifdef HAS_IOCTL
76e3520e 2155 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e 2156#else
cea2e8a9 2157 DIE(aTHX_ "ioctl is not implemented");
a0d0e21e
LW		 2158#endif
2159 else
55497cff 2160#ifdef HAS_FCNTL
2161#if defined(OS2) && defined(__EMX__)
760ac839 2162 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 2163#else
760ac839 2164 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
301e8125 2165#endif
55497cff 2166#else
cea2e8a9 2167 DIE(aTHX_ "fcntl is not implemented");
a0d0e21e
LW		 2168#endif
2169
748a9306
LW		 2170 if (SvPOK(argsv)) {
2171 if (s[SvCUR(argsv)] != 17)
cea2e8a9 2172 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
53e06cf0 2173 OP_NAME(PL_op));
748a9306
LW		 2174 s[SvCUR(argsv)] = 0; /* put our null back */
2175 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW		 2176 }
2177
2178 if (retval == -1)
2179 RETPUSHUNDEF;
2180 if (retval != 0) {
2181 PUSHi(retval);
2182 }
2183 else {
8903cb82 2184 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 2185 }
2186 RETURN;
2187}
2188
2189PP(pp_flock)
2190{
9cad6237 2191#ifdef FLOCK
39644a26 2192 dSP; dTARGET;
a0d0e21e
LW		 2193 I32 value;
2194 int argtype;
2195 GV *gv;
bc37a18f 2196 IO *io = NULL;
760ac839 2197 PerlIO *fp;
16d20bd9 2198
a0d0e21e 2199 argtype = POPi;
32da55ab 2200 if (MAXARG == 0)
3280af22 2201 gv = PL_last_in_gv;
a0d0e21e
LW		 2202 else
2203 gv = (GV*)POPs;
bc37a18f
RG		 2204 if (gv && (io = GvIO(gv)))
2205 fp = IoIFP(io);
2206 else {
a0d0e21e 2207 fp = Nullfp;
bc37a18f
RG		 2208 io = NULL;
2209 }
a0d0e21e 2210 if (fp) {
68dc0745 2211 (void)PerlIO_flush(fp);
76e3520e 2212 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e 2213 }
cb50131a 2214 else {
bc37a18f
RG		 2215 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2216 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 2217 value = 0;
91487cfc 2218 SETERRNO(EBADF,RMS$_IFI);
cb50131a 2219 }
a0d0e21e
LW		 2220 PUSHi(value);
2221 RETURN;
2222#else
cea2e8a9 2223 DIE(aTHX_ PL_no_func, "flock()");
a0d0e21e
LW		 2224#endif
2225}
2226
2227/* Sockets. */
2228
2229PP(pp_socket)
2230{
a0d0e21e 2231#ifdef HAS_SOCKET
9cad6237 2232 dSP;
a0d0e21e
LW		 2233 GV *gv;
2234 register IO *io;
2235 int protocol = POPi;
2236 int type = POPi;
2237 int domain = POPi;
2238 int fd;
2239
2240 gv = (GV*)POPs;
c289d2f7 2241 io = gv ? GvIOn(gv) : NULL;
a0d0e21e 2242
c289d2f7
JH		 2243 if (!gv || !io) {
2244 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2245 report_evil_fh(gv, io, PL_op->op_type);
2246 if (IoIFP(io))
2247 do_close(gv, FALSE);
91487cfc 2248 SETERRNO(EBADF,LIB$_INVARG);
a0d0e21e
LW		 2249 RETPUSHUNDEF;
2250 }
2251
57171420
BS		 2252 if (IoIFP(io))
2253 do_close(gv, FALSE);
2254
a0d0e21e 2255 TAINT_PROPER("socket");
6ad3d225 2256 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW		 2257 if (fd < 0)
2258 RETPUSHUNDEF;
760ac839
LW		 2259 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
2260 IoOFP(io) = PerlIO_fdopen(fd, "w");
50952442 2261 IoTYPE(io) = IoTYPE_SOCKET;
a0d0e21e 2262 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW		 2263 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2264 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 2265 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW		 2266 RETPUSHUNDEF;
2267 }
8d2a6795
GS		 2268#if defined(HAS_FCNTL) && defined(F_SETFD)
2269 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2270#endif
a0d0e21e 2271
d5ff79b3
OF		 2272#ifdef EPOC
2273 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2274#endif
2275
a0d0e21e
LW		 2276 RETPUSHYES;
2277#else
cea2e8a9 2278 DIE(aTHX_ PL_no_sock_func, "socket");
a0d0e21e
LW		 2279#endif
2280}
2281
2282PP(pp_sockpair)
2283{
a0d0e21e 2284#ifdef HAS_SOCKETPAIR
76ffd3b9 2285 dSP;
a0d0e21e
LW		 2286 GV *gv1;
2287 GV *gv2;
2288 register IO *io1;
2289 register IO *io2;
2290 int protocol = POPi;
2291 int type = POPi;
2292 int domain = POPi;
2293 int fd[2];
2294
2295 gv2 = (GV*)POPs;
2296 gv1 = (GV*)POPs;
c289d2f7
JH		 2297 io1 = gv1 ? GvIOn(gv1) : NULL;
2298 io2 = gv2 ? GvIOn(gv2) : NULL;
2299 if (!gv1 || !gv2 || !io1 || !io2) {
2300 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2301 if (!gv1 || !io1)
2302 report_evil_fh(gv1, io1, PL_op->op_type);
2303 if (!gv2 || !io2)
2304 report_evil_fh(gv1, io2, PL_op->op_type);
2305 }
2306 if (IoIFP(io1))
2307 do_close(gv1, FALSE);
2308 if (IoIFP(io2))
2309 do_close(gv2, FALSE);
a0d0e21e 2310 RETPUSHUNDEF;
c289d2f7 2311 }
a0d0e21e 2312
dc0d0a5f
JH		 2313 if (IoIFP(io1))
2314 do_close(gv1, FALSE);
2315 if (IoIFP(io2))
2316 do_close(gv2, FALSE);
57171420 2317
a0d0e21e 2318 TAINT_PROPER("socketpair");
6ad3d225 2319 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 2320 RETPUSHUNDEF;
760ac839
LW		 2321 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2322 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
50952442 2323 IoTYPE(io1) = IoTYPE_SOCKET;
760ac839
LW		 2324 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2325 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
50952442 2326 IoTYPE(io2) = IoTYPE_SOCKET;
a0d0e21e 2327 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW		 2328 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2329 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 2330 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW		 2331 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2332 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 2333 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW		 2334 RETPUSHUNDEF;
2335 }
8d2a6795
GS		 2336#if defined(HAS_FCNTL) && defined(F_SETFD)
2337 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2338 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2339#endif
a0d0e21e
LW		 2340
2341 RETPUSHYES;
2342#else
cea2e8a9 2343 DIE(aTHX_ PL_no_sock_func, "socketpair");
a0d0e21e
LW		 2344#endif
2345}
2346
2347PP(pp_bind)
2348{
a0d0e21e 2349#ifdef HAS_SOCKET
9cad6237 2350 dSP;
eec2d3df 2351#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
82b3da69
JH		 2352 extern void GETPRIVMODE();
2353 extern void GETUSERMODE();
eec2d3df 2354#endif
748a9306 2355 SV *addrsv = POPs;
a0d0e21e
LW		 2356 char *addr;
2357 GV *gv = (GV*)POPs;
2358 register IO *io = GvIOn(gv);
2359 STRLEN len;
eec2d3df
GS		 2360 int bind_ok = 0;
2361#ifdef MPE
2362 int mpeprivmode = 0;
2363#endif
a0d0e21e
LW		 2364
2365 if (!io || !IoIFP(io))
2366 goto nuts;
2367
748a9306 2368 addr = SvPV(addrsv, len);
a0d0e21e 2369 TAINT_PROPER("bind");
eec2d3df
GS		 2370#ifdef MPE /* Deal with MPE bind() peculiarities */
2371 if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2372 /* The address *MUST* stupidly be zero. */
2373 ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2374 /* PRIV mode is required to bind() to ports < 1024. */
2375 if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2376 ((struct sockaddr_in *)addr)->sin_port > 0) {
2377 GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2378 mpeprivmode = 1;
2379 }
2380 }
2381#endif /* MPE */
2382 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2383 (struct sockaddr *)addr, len) >= 0)
2384 bind_ok = 1;
2385
2386#ifdef MPE /* Switch back to USER mode */
2387 if (mpeprivmode)
2388 GETUSERMODE();
2389#endif /* MPE */
2390
2391 if (bind_ok)
a0d0e21e
LW		 2392 RETPUSHYES;
2393 else
2394 RETPUSHUNDEF;
2395
2396nuts:
599cee73 2397 if (ckWARN(WARN_CLOSED))
bc37a18f 2398 report_evil_fh(gv, io, PL_op->op_type);
91487cfc 2399 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2400 RETPUSHUNDEF;
2401#else
cea2e8a9 2402 DIE(aTHX_ PL_no_sock_func, "bind");
a0d0e21e
LW		 2403#endif
2404}
2405
2406PP(pp_connect)
2407{
a0d0e21e 2408#ifdef HAS_SOCKET
9cad6237 2409 dSP;
748a9306 2410 SV *addrsv = POPs;
a0d0e21e
LW		 2411 char *addr;
2412 GV *gv = (GV*)POPs;
2413 register IO *io = GvIOn(gv);
2414 STRLEN len;
2415
2416 if (!io || !IoIFP(io))
2417 goto nuts;
2418
748a9306 2419 addr = SvPV(addrsv, len);
a0d0e21e 2420 TAINT_PROPER("connect");
6ad3d225 2421 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 2422 RETPUSHYES;
2423 else
2424 RETPUSHUNDEF;
2425
2426nuts:
599cee73 2427 if (ckWARN(WARN_CLOSED))
bc37a18f 2428 report_evil_fh(gv, io, PL_op->op_type);
91487cfc 2429 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2430 RETPUSHUNDEF;
2431#else
cea2e8a9 2432 DIE(aTHX_ PL_no_sock_func, "connect");
a0d0e21e
LW		 2433#endif
2434}
2435
2436PP(pp_listen)
2437{
a0d0e21e 2438#ifdef HAS_SOCKET
9cad6237 2439 dSP;
a0d0e21e
LW		 2440 int backlog = POPi;
2441 GV *gv = (GV*)POPs;
c289d2f7 2442 register IO *io = gv ? GvIOn(gv) : NULL;
a0d0e21e 2443
c289d2f7 2444 if (!gv || !io || !IoIFP(io))
a0d0e21e
LW		 2445 goto nuts;
2446
6ad3d225 2447 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW		 2448 RETPUSHYES;
2449 else
2450 RETPUSHUNDEF;
2451
2452nuts:
599cee73 2453 if (ckWARN(WARN_CLOSED))
bc37a18f 2454 report_evil_fh(gv, io, PL_op->op_type);
91487cfc 2455 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2456 RETPUSHUNDEF;
2457#else
cea2e8a9 2458 DIE(aTHX_ PL_no_sock_func, "listen");
a0d0e21e
LW		 2459#endif
2460}
2461
2462PP(pp_accept)
2463{
a0d0e21e 2464#ifdef HAS_SOCKET
9cad6237 2465 dSP; dTARGET;
a0d0e21e
LW		 2466 GV *ngv;
2467 GV *ggv;
2468 register IO *nstio;
2469 register IO *gstio;
4633a7c4 2470 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 2471 Sock_size_t len = sizeof saddr;
a0d0e21e
LW		 2472 int fd;
2473
2474 ggv = (GV*)POPs;
2475 ngv = (GV*)POPs;
2476
2477 if (!ngv)
2478 goto badexit;
2479 if (!ggv)
2480 goto nuts;
2481
2482 gstio = GvIO(ggv);
2483 if (!gstio || !IoIFP(gstio))
2484 goto nuts;
2485
2486 nstio = GvIOn(ngv);
6ad3d225 2487 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW		 2488 if (fd < 0)
2489 goto badexit;
a70048fb
AB		 2490 if (IoIFP(nstio))
2491 do_close(ngv, FALSE);
760ac839
LW		 2492 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2493 IoOFP(nstio) = PerlIO_fdopen(fd, "w");
50952442 2494 IoTYPE(nstio) = IoTYPE_SOCKET;
a0d0e21e 2495 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW		 2496 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2497 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2498 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW		 2499 goto badexit;
2500 }
8d2a6795
GS		 2501#if defined(HAS_FCNTL) && defined(F_SETFD)
2502 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2503#endif
a0d0e21e 2504
ed79a026 2505#ifdef EPOC
a9f1f6b0
OF		 2506 len = sizeof saddr; /* EPOC somehow truncates info */
2507 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
ed79a026
OF		 2508#endif
2509
748a9306 2510 PUSHp((char *)&saddr, len);
a0d0e21e
LW		 2511 RETURN;
2512
2513nuts:
599cee73 2514 if (ckWARN(WARN_CLOSED))
bc37a18f 2515 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
91487cfc 2516 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2517
2518badexit:
2519 RETPUSHUNDEF;
2520
2521#else
cea2e8a9 2522 DIE(aTHX_ PL_no_sock_func, "accept");
a0d0e21e
LW		 2523#endif
2524}
2525
2526PP(pp_shutdown)
2527{
a0d0e21e 2528#ifdef HAS_SOCKET
9cad6237 2529 dSP; dTARGET;
a0d0e21e
LW		 2530 int how = POPi;
2531 GV *gv = (GV*)POPs;
2532 register IO *io = GvIOn(gv);
2533
2534 if (!io || !IoIFP(io))
2535 goto nuts;
2536
6ad3d225 2537 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW		 2538 RETURN;
2539
2540nuts:
599cee73 2541 if (ckWARN(WARN_CLOSED))
bc37a18f 2542 report_evil_fh(gv, io, PL_op->op_type);
91487cfc 2543 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2544 RETPUSHUNDEF;
2545#else
cea2e8a9 2546 DIE(aTHX_ PL_no_sock_func, "shutdown");
a0d0e21e
LW		 2547#endif
2548}
2549
2550PP(pp_gsockopt)
2551{
2552#ifdef HAS_SOCKET
cea2e8a9 2553 return pp_ssockopt();
a0d0e21e 2554#else
cea2e8a9 2555 DIE(aTHX_ PL_no_sock_func, "getsockopt");
a0d0e21e
LW		 2556#endif
2557}
2558
2559PP(pp_ssockopt)
2560{
a0d0e21e 2561#ifdef HAS_SOCKET
9cad6237 2562 dSP;
533c011a 2563 int optype = PL_op->op_type;
a0d0e21e
LW		 2564 SV *sv;
2565 int fd;
2566 unsigned int optname;
2567 unsigned int lvl;
2568 GV *gv;
2569 register IO *io;
1e422769 2570 Sock_size_t len;
a0d0e21e
LW		 2571
2572 if (optype == OP_GSOCKOPT)
2573 sv = sv_2mortal(NEWSV(22, 257));
2574 else
2575 sv = POPs;
2576 optname = (unsigned int) POPi;
2577 lvl = (unsigned int) POPi;
2578
2579 gv = (GV*)POPs;
2580 io = GvIOn(gv);
2581 if (!io || !IoIFP(io))
2582 goto nuts;
2583
760ac839 2584 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2585 switch (optype) {
2586 case OP_GSOCKOPT:
748a9306 2587 SvGROW(sv, 257);
a0d0e21e 2588 (void)SvPOK_only(sv);
748a9306
LW		 2589 SvCUR_set(sv,256);
2590 *SvEND(sv) ='\0';
1e422769 2591 len = SvCUR(sv);
6ad3d225 2592 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2593 goto nuts2;
1e422769 2594 SvCUR_set(sv, len);
748a9306 2595 *SvEND(sv) ='\0';
a0d0e21e
LW		 2596 PUSHs(sv);
2597 break;
2598 case OP_SSOCKOPT: {
1e422769 2599 char *buf;
2600 int aint;
2601 if (SvPOKp(sv)) {
2d8e6c8d
GS		 2602 STRLEN l;
2603 buf = SvPV(sv, l);
2604 len = l;
1e422769 2605 }
56ee1660 2606 else {
a0d0e21e
LW		 2607 aint = (int)SvIV(sv);
2608 buf = (char*)&aint;
2609 len = sizeof(int);
2610 }
6ad3d225 2611 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2612 goto nuts2;
3280af22 2613 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 2614 }
2615 break;
2616 }
2617 RETURN;
2618
2619nuts:
599cee73 2620 if (ckWARN(WARN_CLOSED))
bc37a18f 2621 report_evil_fh(gv, io, optype);
91487cfc 2622 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2623nuts2:
2624 RETPUSHUNDEF;
2625
2626#else
cea2e8a9 2627 DIE(aTHX_ PL_no_sock_func, "setsockopt");
a0d0e21e
LW		 2628#endif
2629}
2630
2631PP(pp_getsockname)
2632{
2633#ifdef HAS_SOCKET
cea2e8a9 2634 return pp_getpeername();
a0d0e21e 2635#else
cea2e8a9 2636 DIE(aTHX_ PL_no_sock_func, "getsockname");
a0d0e21e
LW		 2637#endif
2638}
2639
2640PP(pp_getpeername)
2641{
a0d0e21e 2642#ifdef HAS_SOCKET
9cad6237 2643 dSP;
533c011a 2644 int optype = PL_op->op_type;
a0d0e21e
LW		 2645 SV *sv;
2646 int fd;
2647 GV *gv = (GV*)POPs;
2648 register IO *io = GvIOn(gv);
1e422769 2649 Sock_size_t len;
a0d0e21e
LW		 2650
2651 if (!io || !IoIFP(io))
2652 goto nuts;
2653
2654 sv = sv_2mortal(NEWSV(22, 257));
748a9306 2655 (void)SvPOK_only(sv);
1e422769 2656 len = 256;
2657 SvCUR_set(sv, len);
748a9306 2658 *SvEND(sv) ='\0';
760ac839 2659 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2660 switch (optype) {
2661 case OP_GETSOCKNAME:
6ad3d225 2662 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 2663 goto nuts2;
2664 break;
2665 case OP_GETPEERNAME:
6ad3d225 2666 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2667 goto nuts2;
490ab354
JH		 2668#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2669 {
2670 static const char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
2671 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2672 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2673 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2674 sizeof(u_short) + sizeof(struct in_addr))) {
301e8125 2675 goto nuts2;
490ab354
JH		 2676 }
2677 }
2678#endif
a0d0e21e
LW		 2679 break;
2680 }
13826f2c
CS		 2681#ifdef BOGUS_GETNAME_RETURN
2682 /* Interactive Unix, getpeername() and getsockname()
2683 does not return valid namelen */
1e422769 2684 if (len == BOGUS_GETNAME_RETURN)
2685 len = sizeof(struct sockaddr);
13826f2c 2686#endif
1e422769 2687 SvCUR_set(sv, len);
748a9306 2688 *SvEND(sv) ='\0';
a0d0e21e
LW		 2689 PUSHs(sv);
2690 RETURN;
2691
2692nuts:
599cee73 2693 if (ckWARN(WARN_CLOSED))
bc37a18f 2694 report_evil_fh(gv, io, optype);
91487cfc 2695 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2696nuts2:
2697 RETPUSHUNDEF;
2698
2699#else
cea2e8a9 2700 DIE(aTHX_ PL_no_sock_func, "getpeername");
a0d0e21e
LW		 2701#endif
2702}
2703
2704/* Stat calls. */
2705
2706PP(pp_lstat)
2707{
cea2e8a9 2708 return pp_stat();
a0d0e21e
LW		 2709}
2710
2711PP(pp_stat)
2712{
39644a26 2713 dSP;
2dd78f96 2714 GV *gv;
54310121 2715 I32 gimme;
a0d0e21e 2716 I32 max = 13;
2d8e6c8d 2717 STRLEN n_a;
a0d0e21e 2718
533c011a 2719 if (PL_op->op_flags & OPf_REF) {
2dd78f96 2720 gv = cGVOP_gv;
8a4e5b40
DD		 2721 if (PL_op->op_type == OP_LSTAT) {
2722 if (PL_laststype != OP_LSTAT)
2723 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2724 if (ckWARN(WARN_IO) && gv != PL_defgv)
2725 Perl_warner(aTHX_ WARN_IO,
2dd78f96 2726 "lstat() on filehandle %s", GvENAME(gv));
8a4e5b40
DD		 2727 /* Perl_my_lstat (-l) croak's on filehandle, why warn here? */
2728 }
2729
748a9306 2730 do_fstat:
2dd78f96 2731 if (gv != PL_defgv) {
3280af22 2732 PL_laststype = OP_STAT;
2dd78f96 2733 PL_statgv = gv;
3280af22 2734 sv_setpv(PL_statname, "");
2dd78f96
JH		 2735 PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
2736 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
a0d0e21e 2737 }
9ddeeac9 2738 if (PL_laststatval < 0) {
2dd78f96
JH		 2739 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2740 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
a0d0e21e 2741 max = 0;
9ddeeac9 2742 }
a0d0e21e
LW		 2743 }
2744 else {
748a9306
LW		 2745 SV* sv = POPs;
2746 if (SvTYPE(sv) == SVt_PVGV) {
2dd78f96 2747 gv = (GV*)sv;
748a9306
LW		 2748 goto do_fstat;
2749 }
2750 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2dd78f96 2751 gv = (GV*)SvRV(sv);
748a9306
LW		 2752 goto do_fstat;
2753 }
2d8e6c8d 2754 sv_setpv(PL_statname, SvPV(sv,n_a));
3280af22 2755 PL_statgv = Nullgv;
a0d0e21e 2756#ifdef HAS_LSTAT
533c011a
NIS		 2757 PL_laststype = PL_op->op_type;
2758 if (PL_op->op_type == OP_LSTAT)
2d8e6c8d 2759 PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
a0d0e21e
LW		 2760 else
2761#endif
2d8e6c8d 2762 PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
3280af22 2763 if (PL_laststatval < 0) {
2d8e6c8d 2764 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
cea2e8a9 2765 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
a0d0e21e
LW		 2766 max = 0;
2767 }
2768 }
2769
54310121 2770 gimme = GIMME_V;
2771 if (gimme != G_ARRAY) {
2772 if (gimme != G_VOID)
2773 XPUSHs(boolSV(max));
2774 RETURN;
a0d0e21e
LW		 2775 }
2776 if (max) {
36477c24 2777 EXTEND(SP, max);
2778 EXTEND_MORTAL(max);
1ff81528
PL		 2779 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2780 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
b448e4fe
JH		 2781 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2782 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
146174a9
CB		 2783#if Uid_t_size > IVSIZE
2784 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2785#else
23dcd6c8 2786# if Uid_t_sign <= 0
1ff81528 2787 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
23dcd6c8
JH		 2788# else
2789 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2790# endif
146174a9 2791#endif
301e8125 2792#if Gid_t_size > IVSIZE
146174a9
CB		 2793 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2794#else
23dcd6c8 2795# if Gid_t_sign <= 0
1ff81528 2796 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
23dcd6c8
JH		 2797# else
2798 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2799# endif
146174a9 2800#endif
cbdc8872 2801#ifdef USE_STAT_RDEV
1ff81528 2802 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
cbdc8872 2803#else
79cb57f6 2804 PUSHs(sv_2mortal(newSVpvn("", 0)));
cbdc8872 2805#endif
146174a9
CB		 2806#if Off_t_size > IVSIZE
2807 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2808#else
1ff81528 2809 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
146174a9 2810#endif
cbdc8872 2811#ifdef BIG_TIME
172ae379
JH		 2812 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2813 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2814 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
cbdc8872 2815#else
1ff81528
PL		 2816 PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2817 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2818 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
cbdc8872 2819#endif
a0d0e21e 2820#ifdef USE_STAT_BLOCKS
b448e4fe
JH		 2821 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2822 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
a0d0e21e 2823#else
79cb57f6
GS		 2824 PUSHs(sv_2mortal(newSVpvn("", 0)));
2825 PUSHs(sv_2mortal(newSVpvn("", 0)));
a0d0e21e
LW		 2826#endif
2827 }
2828 RETURN;
2829}
2830
2831PP(pp_ftrread)
2832{
9cad6237 2833 I32 result;
2a3ff820 2834 dSP;
5ff3f7a4 2835#if defined(HAS_ACCESS) && defined(R_OK)
2d8e6c8d 2836 STRLEN n_a;
5ff3f7a4 2837 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2838 result = access(TOPpx, R_OK);
5ff3f7a4
GS		 2839 if (result == 0)
2840 RETPUSHYES;
2841 if (result < 0)
2842 RETPUSHUNDEF;
2843 RETPUSHNO;
22865c03
GS		 2844 }
2845 else
cea2e8a9 2846 result = my_stat();
5ff3f7a4 2847#else
cea2e8a9 2848 result = my_stat();
5ff3f7a4 2849#endif
22865c03 2850 SPAGAIN;
a0d0e21e
LW		 2851 if (result < 0)
2852 RETPUSHUNDEF;
3280af22 2853 if (cando(S_IRUSR, 0, &PL_statcache))
a0d0e21e
LW		 2854 RETPUSHYES;
2855 RETPUSHNO;
2856}
2857
2858PP(pp_ftrwrite)
2859{
9cad6237 2860 I32 result;
2a3ff820 2861 dSP;
5ff3f7a4 2862#if defined(HAS_ACCESS) && defined(W_OK)
2d8e6c8d 2863 STRLEN n_a;
5ff3f7a4 2864 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2865 result = access(TOPpx, W_OK);
5ff3f7a4
GS		 2866 if (result == 0)
2867 RETPUSHYES;
2868 if (result < 0)
2869 RETPUSHUNDEF;
2870 RETPUSHNO;
22865c03
GS		 2871 }
2872 else
cea2e8a9 2873 result = my_stat();
5ff3f7a4 2874#else
cea2e8a9 2875 result = my_stat();
5ff3f7a4 2876#endif
22865c03 2877 SPAGAIN;
a0d0e21e
LW		 2878 if (result < 0)
2879 RETPUSHUNDEF;
3280af22 2880 if (cando(S_IWUSR, 0, &PL_statcache))
a0d0e21e
LW		 2881 RETPUSHYES;
2882 RETPUSHNO;
2883}
2884
2885PP(pp_ftrexec)
2886{
9cad6237 2887 I32 result;
2a3ff820 2888 dSP;
5ff3f7a4 2889#if defined(HAS_ACCESS) && defined(X_OK)
2d8e6c8d 2890 STRLEN n_a;
5ff3f7a4 2891 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2892 result = access(TOPpx, X_OK);
5ff3f7a4
GS		 2893 if (result == 0)
2894 RETPUSHYES;
2895 if (result < 0)
2896 RETPUSHUNDEF;
2897 RETPUSHNO;
22865c03
GS		 2898 }
2899 else
cea2e8a9 2900 result = my_stat();
5ff3f7a4 2901#else
cea2e8a9 2902 result = my_stat();
5ff3f7a4 2903#endif
22865c03 2904 SPAGAIN;
a0d0e21e
LW		 2905 if (result < 0)
2906 RETPUSHUNDEF;
3280af22 2907 if (cando(S_IXUSR, 0, &PL_statcache))
a0d0e21e
LW		 2908 RETPUSHYES;
2909 RETPUSHNO;
2910}
2911
2912PP(pp_fteread)
2913{
9cad6237 2914 I32 result;
2a3ff820 2915 dSP;
5ff3f7a4 2916#ifdef PERL_EFF_ACCESS_R_OK
2d8e6c8d 2917 STRLEN n_a;
5ff3f7a4 2918 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2919 result = PERL_EFF_ACCESS_R_OK(TOPpx);
5ff3f7a4
GS		 2920 if (result == 0)
2921 RETPUSHYES;
2922 if (result < 0)
2923 RETPUSHUNDEF;
2924 RETPUSHNO;
22865c03
GS		 2925 }
2926 else
cea2e8a9 2927 result = my_stat();
5ff3f7a4 2928#else
cea2e8a9 2929 result = my_stat();
5ff3f7a4 2930#endif
22865c03 2931 SPAGAIN;
a0d0e21e
LW		 2932 if (result < 0)
2933 RETPUSHUNDEF;
3280af22 2934 if (cando(S_IRUSR, 1, &PL_statcache))
a0d0e21e
LW		 2935 RETPUSHYES;
2936 RETPUSHNO;
2937}
2938
2939PP(pp_ftewrite)
2940{
9cad6237 2941 I32 result;
2a3ff820 2942 dSP;
5ff3f7a4 2943#ifdef PERL_EFF_ACCESS_W_OK
2d8e6c8d 2944 STRLEN n_a;
5ff3f7a4 2945 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2946 result = PERL_EFF_ACCESS_W_OK(TOPpx);
5ff3f7a4
GS		 2947 if (result == 0)
2948 RETPUSHYES;
2949 if (result < 0)
2950 RETPUSHUNDEF;
2951 RETPUSHNO;
22865c03
GS		 2952 }
2953 else
cea2e8a9 2954 result = my_stat();
5ff3f7a4 2955#else
cea2e8a9 2956 result = my_stat();
5ff3f7a4 2957#endif
22865c03 2958 SPAGAIN;
a0d0e21e
LW		 2959 if (result < 0)
2960 RETPUSHUNDEF;
3280af22 2961 if (cando(S_IWUSR, 1, &PL_statcache))
a0d0e21e
LW		 2962 RETPUSHYES;
2963 RETPUSHNO;
2964}
2965
2966PP(pp_fteexec)
2967{
9cad6237 2968 I32 result;
2a3ff820 2969 dSP;
5ff3f7a4 2970#ifdef PERL_EFF_ACCESS_X_OK
2d8e6c8d 2971 STRLEN n_a;
5ff3f7a4 2972 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2973 result = PERL_EFF_ACCESS_X_OK(TOPpx);
5ff3f7a4
GS		 2974 if (result == 0)
2975 RETPUSHYES;
2976 if (result < 0)
2977 RETPUSHUNDEF;
2978 RETPUSHNO;
22865c03
GS		 2979 }
2980 else
cea2e8a9 2981 result = my_stat();
5ff3f7a4 2982#else
cea2e8a9 2983 result = my_stat();
5ff3f7a4 2984#endif
22865c03 2985 SPAGAIN;
a0d0e21e
LW		 2986 if (result < 0)
2987 RETPUSHUNDEF;
3280af22 2988 if (cando(S_IXUSR, 1, &PL_statcache))
a0d0e21e
LW		 2989 RETPUSHYES;
2990 RETPUSHNO;
2991}
2992
2993PP(pp_ftis)
2994{
9cad6237 2995 I32 result = my_stat();
2a3ff820 2996 dSP;
a0d0e21e
LW		 2997 if (result < 0)
2998 RETPUSHUNDEF;
2999 RETPUSHYES;
3000}
3001
3002PP(pp_fteowned)
3003{
cea2e8a9 3004 return pp_ftrowned();
a0d0e21e
LW		 3005}
3006
3007PP(pp_ftrowned)
3008{
9cad6237 3009 I32 result = my_stat();
2a3ff820 3010 dSP;
a0d0e21e
LW		 3011 if (result < 0)
3012 RETPUSHUNDEF;
146174a9
CB		 3013 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
3014 PL_euid : PL_uid) )
a0d0e21e
LW		 3015 RETPUSHYES;
3016 RETPUSHNO;
3017}
3018
3019PP(pp_ftzero)
3020{
9cad6237 3021 I32 result = my_stat();
2a3ff820 3022 dSP;
a0d0e21e
LW		 3023 if (result < 0)
3024 RETPUSHUNDEF;
146174a9 3025 if (PL_statcache.st_size == 0)
a0d0e21e
LW		 3026 RETPUSHYES;
3027 RETPUSHNO;
3028}
3029
3030PP(pp_ftsize)
3031{
9cad6237 3032 I32 result = my_stat();
2a3ff820 3033 dSP; dTARGET;
a0d0e21e
LW		 3034 if (result < 0)
3035 RETPUSHUNDEF;
146174a9
CB		 3036#if Off_t_size > IVSIZE
3037 PUSHn(PL_statcache.st_size);
3038#else
3280af22 3039 PUSHi(PL_statcache.st_size);
146174a9 3040#endif
a0d0e21e
LW		 3041 RETURN;
3042}
3043
3044PP(pp_ftmtime)
3045{
9cad6237 3046 I32 result = my_stat();
2a3ff820 3047 dSP; dTARGET;
a0d0e21e
LW		 3048 if (result < 0)
3049 RETPUSHUNDEF;
c6419e06 3050 PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
a0d0e21e
LW		 3051 RETURN;
3052}
3053
3054PP(pp_ftatime)
3055{
9cad6237 3056 I32 result = my_stat();
2a3ff820 3057 dSP; dTARGET;
a0d0e21e
LW		 3058 if (result < 0)
3059 RETPUSHUNDEF;
c6419e06 3060 PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
a0d0e21e
LW		 3061 RETURN;
3062}
3063
3064PP(pp_ftctime)
3065{
9cad6237 3066 I32 result = my_stat();
2a3ff820 3067 dSP; dTARGET;
a0d0e21e
LW		 3068 if (result < 0)
3069 RETPUSHUNDEF;
c6419e06 3070 PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
a0d0e21e
LW		 3071 RETURN;
3072}
3073
3074PP(pp_ftsock)
3075{
9cad6237 3076 I32 result = my_stat();
2a3ff820 3077 dSP;
a0d0e21e
LW		 3078 if (result < 0)
3079 RETPUSHUNDEF;
3280af22 3080 if (S_ISSOCK(PL_statcache.st_mode))
a0d0e21e
LW		 3081 RETPUSHYES;
3082 RETPUSHNO;
3083}
3084
3085PP(pp_ftchr)
3086{
9cad6237 3087 I32 result = my_stat();
2a3ff820 3088 dSP;
a0d0e21e
LW		 3089 if (result < 0)
3090 RETPUSHUNDEF;
3280af22 3091 if (S_ISCHR(PL_statcache.st_mode))
a0d0e21e
LW		 3092 RETPUSHYES;
3093 RETPUSHNO;
3094}
3095
3096PP(pp_ftblk)
3097{
9cad6237 3098 I32 result = my_stat();
2a3ff820 3099 dSP;
a0d0e21e
LW		 3100 if (result < 0)
3101 RETPUSHUNDEF;
3280af22 3102 if (S_ISBLK(PL_statcache.st_mode))
a0d0e21e
LW		 3103 RETPUSHYES;
3104 RETPUSHNO;
3105}
3106
3107PP(pp_ftfile)
3108{
9cad6237 3109 I32 result = my_stat();
2a3ff820 3110 dSP;
a0d0e21e
LW		 3111 if (result < 0)
3112 RETPUSHUNDEF;
3280af22 3113 if (S_ISREG(PL_statcache.st_mode))
a0d0e21e
LW		 3114 RETPUSHYES;
3115 RETPUSHNO;
3116}
3117
3118PP(pp_ftdir)
3119{
9cad6237 3120 I32 result = my_stat();
2a3ff820 3121 dSP;
a0d0e21e
LW		 3122 if (result < 0)
3123 RETPUSHUNDEF;
3280af22 3124 if (S_ISDIR(PL_statcache.st_mode))
a0d0e21e
LW		 3125 RETPUSHYES;
3126 RETPUSHNO;
3127}
3128
3129PP(pp_ftpipe)
3130{
9cad6237 3131 I32 result = my_stat();
2a3ff820 3132 dSP;
a0d0e21e
LW		 3133 if (result < 0)
3134 RETPUSHUNDEF;
3280af22 3135 if (S_ISFIFO(PL_statcache.st_mode))
a0d0e21e
LW		 3136 RETPUSHYES;
3137 RETPUSHNO;
3138}
3139
3140PP(pp_ftlink)
3141{
9cad6237 3142 I32 result = my_lstat();
2a3ff820 3143 dSP;
a0d0e21e
LW		 3144 if (result < 0)
3145 RETPUSHUNDEF;
3280af22 3146 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e
LW		 3147 RETPUSHYES;
3148 RETPUSHNO;
3149}
3150
3151PP(pp_ftsuid)
3152{
39644a26 3153 dSP;
a0d0e21e 3154#ifdef S_ISUID
cea2e8a9 3155 I32 result = my_stat();
a0d0e21e
LW		 3156 SPAGAIN;
3157 if (result < 0)
3158 RETPUSHUNDEF;
3280af22 3159 if (PL_statcache.st_mode & S_ISUID)
a0d0e21e
LW		 3160 RETPUSHYES;
3161#endif
3162 RETPUSHNO;
3163}
3164
3165PP(pp_ftsgid)
3166{
39644a26 3167 dSP;
a0d0e21e 3168#ifdef S_ISGID
cea2e8a9 3169 I32 result = my_stat();
a0d0e21e
LW		 3170 SPAGAIN;
3171 if (result < 0)
3172 RETPUSHUNDEF;
3280af22 3173 if (PL_statcache.st_mode & S_ISGID)
a0d0e21e
LW		 3174 RETPUSHYES;
3175#endif
3176 RETPUSHNO;
3177}
3178
3179PP(pp_ftsvtx)
3180{
39644a26 3181 dSP;
a0d0e21e 3182#ifdef S_ISVTX
cea2e8a9 3183 I32 result = my_stat();
a0d0e21e
LW		 3184 SPAGAIN;
3185 if (result < 0)
3186 RETPUSHUNDEF;
3280af22 3187 if (PL_statcache.st_mode & S_ISVTX)
a0d0e21e
LW		 3188 RETPUSHYES;
3189#endif
3190 RETPUSHNO;
3191}
3192
3193PP(pp_fttty)
3194{
39644a26 3195 dSP;
a0d0e21e
LW		 3196 int fd;
3197 GV *gv;
fb73857a 3198 char *tmps = Nullch;
2d8e6c8d 3199 STRLEN n_a;
fb73857a 3200
533c011a 3201 if (PL_op->op_flags & OPf_REF)
146174a9 3202 gv = cGVOP_gv;
fb73857a 3203 else if (isGV(TOPs))
3204 gv = (GV*)POPs;
3205 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3206 gv = (GV*)SvRV(POPs);
a0d0e21e 3207 else
2d8e6c8d 3208 gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
fb73857a 3209
a0d0e21e 3210 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 3211 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 3212 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW		 3213 fd = atoi(tmps);
3214 else
3215 RETPUSHUNDEF;
6ad3d225 3216 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 3217 RETPUSHYES;
3218 RETPUSHNO;
3219}
3220
16d20bd9
AD		 3221#if defined(atarist) /* this will work with atariST. Configure will
3222 make guesses for other systems. */
3223# define FILE_base(f) ((f)->_base)
3224# define FILE_ptr(f) ((f)->_ptr)
3225# define FILE_cnt(f) ((f)->_cnt)
3226# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 3227#endif
3228
3229PP(pp_fttext)
3230{
39644a26 3231 dSP;
a0d0e21e
LW		 3232 I32 i;
3233 I32 len;
3234 I32 odd = 0;
3235 STDCHAR tbuf[512];
3236 register STDCHAR *s;
3237 register IO *io;
5f05dabc 3238 register SV *sv;
3239 GV *gv;
2d8e6c8d 3240 STRLEN n_a;
146174a9 3241 PerlIO *fp;
a0d0e21e 3242
533c011a 3243 if (PL_op->op_flags & OPf_REF)
146174a9 3244 gv = cGVOP_gv;
5f05dabc 3245 else if (isGV(TOPs))
3246 gv = (GV*)POPs;
3247 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3248 gv = (GV*)SvRV(POPs);
3249 else
3250 gv = Nullgv;
3251
3252 if (gv) {
a0d0e21e 3253 EXTEND(SP, 1);
3280af22
NIS		 3254 if (gv == PL_defgv) {
3255 if (PL_statgv)
3256 io = GvIO(PL_statgv);
a0d0e21e 3257 else {
3280af22 3258 sv = PL_statname;
a0d0e21e
LW		 3259 goto really_filename;
3260 }
3261 }
3262 else {
3280af22
NIS		 3263 PL_statgv = gv;
3264 PL_laststatval = -1;
3265 sv_setpv(PL_statname, "");
3266 io = GvIO(PL_statgv);
a0d0e21e
LW		 3267 }
3268 if (io && IoIFP(io)) {
5f05dabc 3269 if (! PerlIO_has_base(IoIFP(io)))
cea2e8a9 3270 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280af22
NIS		 3271 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3272 if (PL_laststatval < 0)
5f05dabc 3273 RETPUSHUNDEF;
9cbac4c7 3274 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
533c011a 3275 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3276 RETPUSHNO;
3277 else
3278 RETPUSHYES;
9cbac4c7 3279 }
a20bf0c3 3280 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
760ac839 3281 i = PerlIO_getc(IoIFP(io));
a0d0e21e 3282 if (i != EOF)
760ac839 3283 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 3284 }
a20bf0c3 3285 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 3286 RETPUSHYES;
a20bf0c3
JH		 3287 len = PerlIO_get_bufsiz(IoIFP(io));
3288 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
760ac839
LW		 3289 /* sfio can have large buffers - limit to 512 */
3290 if (len > 512)
3291 len = 512;
a0d0e21e
LW		 3292 }
3293 else {
2dd78f96 3294 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
146174a9 3295 gv = cGVOP_gv;
2dd78f96 3296 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
146174a9 3297 }
91487cfc 3298 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3299 RETPUSHUNDEF;
3300 }
3301 }
3302 else {
3303 sv = POPs;
5f05dabc 3304 really_filename:
3280af22
NIS		 3305 PL_statgv = Nullgv;
3306 PL_laststatval = -1;
2d8e6c8d 3307 sv_setpv(PL_statname, SvPV(sv, n_a));
146174a9 3308 if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
2d8e6c8d 3309 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
cea2e8a9 3310 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
a0d0e21e
LW		 3311 RETPUSHUNDEF;
3312 }
146174a9
CB		 3313 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3314 if (PL_laststatval < 0) {
3315 (void)PerlIO_close(fp);
5f05dabc 3316 RETPUSHUNDEF;
146174a9 3317 }
60382766 3318 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, Nullch);
146174a9
CB		 3319 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3320 (void)PerlIO_close(fp);
a0d0e21e 3321 if (len <= 0) {
533c011a 3322 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3323 RETPUSHNO; /* special case NFS directories */
3324 RETPUSHYES; /* null file is anything */
3325 }
3326 s = tbuf;
3327 }
3328
3329 /* now scan s to look for textiness */
4633a7c4 3330 /* XXX ASCII dependent code */
a0d0e21e 3331
146174a9
CB		 3332#if defined(DOSISH) || defined(USEMYBINMODE)
3333 /* ignore trailing ^Z on short files */
3334 if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3335 --len;
3336#endif
3337
a0d0e21e
LW		 3338 for (i = 0; i < len; i++, s++) {
3339 if (!*s) { /* null never allowed in text */
3340 odd += len;
3341 break;
3342 }
9d116dd7 3343#ifdef EBCDIC
301e8125 3344 else if (!(isPRINT(*s) || isSPACE(*s)))
9d116dd7
JH		 3345 odd++;
3346#else
146174a9
CB		 3347 else if (*s & 128) {
3348#ifdef USE_LOCALE
2de3dbcc 3349 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
b3f66c68
GS		 3350 continue;
3351#endif
3352 /* utf8 characters don't count as odd */
fd400ab9 3353 if (UTF8_IS_START(*s)) {
b3f66c68
GS		 3354 int ulen = UTF8SKIP(s);
3355 if (ulen < len - i) {
3356 int j;
3357 for (j = 1; j < ulen; j++) {
fd400ab9 3358 if (!UTF8_IS_CONTINUATION(s[j]))
b3f66c68
GS		 3359 goto not_utf8;
3360 }
3361 --ulen; /* loop does extra increment */
3362 s += ulen;
3363 i += ulen;
3364 continue;
3365 }
3366 }
3367 not_utf8:
3368 odd++;
146174a9 3369 }
a0d0e21e
LW		 3370 else if (*s < 32 &&
3371 *s != '\n' && *s != '\r' && *s != '\b' &&
3372 *s != '\t' && *s != '\f' && *s != 27)
3373 odd++;
9d116dd7 3374#endif
a0d0e21e
LW		 3375 }
3376
533c011a 3377 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 3378 RETPUSHNO;
3379 else
3380 RETPUSHYES;
3381}
3382
3383PP(pp_ftbinary)
3384{
cea2e8a9 3385 return pp_fttext();
a0d0e21e
LW		 3386}
3387
3388/* File calls. */
3389
3390PP(pp_chdir)
3391{
39644a26 3392 dSP; dTARGET;
a0d0e21e
LW		 3393 char *tmps;
3394 SV **svp;
2d8e6c8d 3395 STRLEN n_a;
a0d0e21e 3396
35ae6b54
MS		 3397 if( MAXARG == 1 )
3398 tmps = POPpx;
3399 else
3400 tmps = 0;
3401
3402 if( !tmps || !*tmps ) {
3403 if ( (svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE))
3404 || (svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE))
491527d0 3405#ifdef VMS
35ae6b54 3406 || (svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE))
491527d0 3407#endif
35ae6b54
MS		 3408 )
3409 {
3410 if( MAXARG == 1 )
3411 deprecate("chdir('') or chdir(undef) as chdir()");
3412 tmps = SvPV(*svp, n_a);
3413 }
3414 else {
389ec635
MS		 3415 PUSHi(0);
3416 RETURN;
3417 }
8ea155d1 3418 }
8ea155d1 3419
a0d0e21e 3420 TAINT_PROPER("chdir");
6ad3d225 3421 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 3422#ifdef VMS
3423 /* Clear the DEFAULT element of ENV so we'll get the new value
3424 * in the future. */
6b88bc9c 3425 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 3426#endif
a0d0e21e
LW		 3427 RETURN;
3428}
3429
3430PP(pp_chown)
3431{
a0d0e21e 3432#ifdef HAS_CHOWN
76ffd3b9
IZ		 3433 dSP; dMARK; dTARGET;
3434 I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3435
a0d0e21e
LW		 3436 SP = MARK;
3437 PUSHi(value);
3438 RETURN;
3439#else
0322a713 3440 DIE(aTHX_ PL_no_func, "chown");
a0d0e21e
LW		 3441#endif
3442}
3443
3444PP(pp_chroot)
3445{
a0d0e21e 3446#ifdef HAS_CHROOT
76ffd3b9 3447 dSP; dTARGET;
2d8e6c8d 3448 STRLEN n_a;
d05c1ba0 3449 char *tmps = POPpx;
a0d0e21e
LW		 3450 TAINT_PROPER("chroot");
3451 PUSHi( chroot(tmps) >= 0 );
3452 RETURN;
3453#else
cea2e8a9 3454 DIE(aTHX_ PL_no_func, "chroot");
a0d0e21e
LW		 3455#endif
3456}
3457
3458PP(pp_unlink)
3459{
39644a26 3460 dSP; dMARK; dTARGET;
a0d0e21e 3461 I32 value;
533c011a 3462 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3463 SP = MARK;
3464 PUSHi(value);
3465 RETURN;
3466}
3467
3468PP(pp_chmod)
3469{
39644a26 3470 dSP; dMARK; dTARGET;
a0d0e21e 3471 I32 value;
533c011a 3472 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3473 SP = MARK;
3474 PUSHi(value);
3475 RETURN;
3476}
3477
3478PP(pp_utime)
3479{
39644a26 3480 dSP; dMARK; dTARGET;
a0d0e21e 3481 I32 value;
533c011a 3482 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3483 SP = MARK;
3484 PUSHi(value);
3485 RETURN;
3486}
3487
3488PP(pp_rename)
3489{
39644a26 3490 dSP; dTARGET;
a0d0e21e 3491 int anum;
2d8e6c8d 3492 STRLEN n_a;
a0d0e21e 3493
2d8e6c8d
GS		 3494 char *tmps2 = POPpx;
3495 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3496 TAINT_PROPER("rename");
3497#ifdef HAS_RENAME
baed7233 3498 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3499#else
6b88bc9c 3500 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
W		 3501 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3502 anum = 1;
3503 else {
3654eb6c 3504 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
W		 3505 (void)UNLINK(tmps2);
3506 if (!(anum = link(tmps, tmps2)))
3507 anum = UNLINK(tmps);
3508 }
a0d0e21e
LW		 3509 }
3510#endif
3511 SETi( anum >= 0 );
3512 RETURN;
3513}
3514
3515PP(pp_link)
3516{
1bce926b 3517 dSP;
a0d0e21e 3518#ifdef HAS_LINK
1bce926b 3519 dTARGET;
2d8e6c8d
GS		 3520 STRLEN n_a;
3521 char *tmps2 = POPpx;
3522 char *tmps = SvPV(TOPs, n_a);
a0d0e21e 3523 TAINT_PROPER("link");
146174a9 3524 SETi( PerlLIO_link(tmps, tmps2) >= 0 );
65850d11 3525 RETURN;
a0d0e21e 3526#else
0322a713 3527 DIE(aTHX_ PL_no_func, "link");
a0d0e21e 3528#endif
a0d0e21e
LW		 3529}
3530
3531PP(pp_symlink)
3532{
a0d0e21e 3533#ifdef HAS_SYMLINK
9cad6237 3534 dSP; dTARGET;
2d8e6c8d
GS		 3535 STRLEN n_a;
3536 char *tmps2 = POPpx;
3537 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3538 TAINT_PROPER("symlink");
3539 SETi( symlink(tmps, tmps2) >= 0 );
3540 RETURN;
3541#else
cea2e8a9 3542 DIE(aTHX_ PL_no_func, "symlink");
a0d0e21e
LW		 3543#endif
3544}
3545
3546PP(pp_readlink)
3547{
76ffd3b9 3548 dSP;
a0d0e21e 3549#ifdef HAS_SYMLINK
76ffd3b9 3550 dTARGET;
a0d0e21e 3551 char *tmps;
46fc3d4c 3552 char buf[MAXPATHLEN];
a0d0e21e 3553 int len;
2d8e6c8d 3554 STRLEN n_a;
46fc3d4c 3555
fb73857a 3556#ifndef INCOMPLETE_TAINTS
3557 TAINT;
3558#endif
2d8e6c8d 3559 tmps = POPpx;
97dcea33 3560 len = readlink(tmps, buf, sizeof(buf) - 1);
a0d0e21e
LW		 3561 EXTEND(SP, 1);
3562 if (len < 0)
3563 RETPUSHUNDEF;
3564 PUSHp(buf, len);
3565 RETURN;
3566#else
3567 EXTEND(SP, 1);
3568 RETSETUNDEF; /* just pretend it's a normal file */
3569#endif
3570}
3571
3572#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
ba106d47 3573STATIC int
cea2e8a9 3574S_dooneliner(pTHX_ char *cmd, char *filename)
a0d0e21e 3575{
1e422769 3576 char *save_filename = filename;
3577 char *cmdline;
3578 char *s;
760ac839 3579 PerlIO *myfp;
1e422769 3580 int anum = 1;
a0d0e21e 3581
1e422769 3582 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3583 strcpy(cmdline, cmd);
3584 strcat(cmdline, " ");
3585 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 3586 *s++ = '\\';
3587 *s++ = *filename++;
3588 }
3589 strcpy(s, " 2>&1");
6ad3d225 3590 myfp = PerlProc_popen(cmdline, "r");
1e422769 3591 Safefree(cmdline);
3592
a0d0e21e 3593 if (myfp) {
1e422769 3594 SV *tmpsv = sv_newmortal();
6b88bc9c 3595 /* Need to save/restore 'PL_rs' ?? */
760ac839 3596 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3597 (void)PerlProc_pclose(myfp);
a0d0e21e 3598 if (s != Nullch) {
1e422769 3599 int e;
3600 for (e = 1;
a0d0e21e 3601#ifdef HAS_SYS_ERRLIST
1e422769 3602 e <= sys_nerr
3603#endif
3604 ; e++)
3605 {
3606 /* you don't see this */
3607 char *errmsg =
3608#ifdef HAS_SYS_ERRLIST
3609 sys_errlist[e]
a0d0e21e 3610#else
1e422769 3611 strerror(e)
a0d0e21e 3612#endif
1e422769 3613 ;
3614 if (!errmsg)
3615 break;
3616 if (instr(s, errmsg)) {
3617 SETERRNO(e,0);
3618 return 0;
3619 }
a0d0e21e 3620 }
748a9306 3621 SETERRNO(0,0);
a0d0e21e
LW		 3622#ifndef EACCES
3623#define EACCES EPERM
3624#endif
1e422769 3625 if (instr(s, "cannot make"))
748a9306 3626 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3627 else if (instr(s, "existing file"))
748a9306 3628 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3629 else if (instr(s, "ile exists"))
748a9306 3630 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3631 else if (instr(s, "non-exist"))
748a9306 3632 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3633 else if (instr(s, "does not exist"))
748a9306 3634 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3635 else if (instr(s, "not empty"))
748a9306 3636 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3637 else if (instr(s, "cannot access"))
748a9306 3638 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3639 else
748a9306 3640 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW		 3641 return 0;
3642 }
3643 else { /* some mkdirs return no failure indication */
6b88bc9c 3644 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3645 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW		 3646 anum = !anum;
3647 if (anum)
748a9306 3648 SETERRNO(0,0);
a0d0e21e 3649 else
748a9306 3650 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW		 3651 }
3652 return anum;
3653 }
3654 else
3655 return 0;
3656}
3657#endif
3658
3659PP(pp_mkdir)
3660{
39644a26 3661 dSP; dTARGET;
5a211162 3662 int mode;
a0d0e21e
LW		 3663#ifndef HAS_MKDIR
3664 int oldumask;
3665#endif
df25ddba 3666 STRLEN len;
5a211162 3667 char *tmps;
df25ddba 3668 bool copy = FALSE;
5a211162
GS		 3669
3670 if (MAXARG > 1)
3671 mode = POPi;
3672 else
3673 mode = 0777;
3674
df25ddba
JH		 3675 tmps = SvPV(TOPs, len);
3676 /* Different operating and file systems take differently to
16ac3975
JH		 3677 * trailing slashes. According to POSIX 1003.1 1996 Edition
3678 * any number of trailing slashes should be allowed.
3679 * Thusly we snip them away so that even non-conforming
3680 * systems are happy. */
3681 /* We should probably do this "filtering" for all
3682 * the functions that expect (potentially) directory names:
3683 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3684 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3685 if (len > 1 && tmps[len-1] == '/') {
3686 while (tmps[len] == '/' && len > 1)
3687 len--;
3688 tmps = savepvn(tmps, len);
df25ddba
JH		 3689 copy = TRUE;
3690 }
a0d0e21e
LW		 3691
3692 TAINT_PROPER("mkdir");
3693#ifdef HAS_MKDIR
6ad3d225 3694 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW		 3695#else
3696 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS		 3697 oldumask = PerlLIO_umask(0);
3698 PerlLIO_umask(oldumask);
3699 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e 3700#endif
df25ddba
JH		 3701 if (copy)
3702 Safefree(tmps);
a0d0e21e
LW		 3703 RETURN;
3704}
3705
3706PP(pp_rmdir)
3707{
39644a26 3708 dSP; dTARGET;
a0d0e21e 3709 char *tmps;
2d8e6c8d 3710 STRLEN n_a;
a0d0e21e 3711
2d8e6c8d 3712 tmps = POPpx;
a0d0e21e
LW		 3713 TAINT_PROPER("rmdir");
3714#ifdef HAS_RMDIR
6ad3d225 3715 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW		 3716#else
3717 XPUSHi( dooneliner("rmdir", tmps) );
3718#endif
3719 RETURN;
3720}
3721
3722/* Directory calls. */
3723
3724PP(pp_open_dir)
3725{
a0d0e21e 3726#if defined(Direntry_t) && defined(HAS_READDIR)
9cad6237 3727 dSP;
2d8e6c8d
GS		 3728 STRLEN n_a;
3729 char *dirname = POPpx;
a0d0e21e
LW		 3730 GV *gv = (GV*)POPs;
3731 register IO *io = GvIOn(gv);
3732
3733 if (!io)
3734 goto nope;
3735
3736 if (IoDIRP(io))
6ad3d225
GS		 3737 PerlDir_close(IoDIRP(io));
3738 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 3739 goto nope;
3740
3741 RETPUSHYES;
3742nope:
3743 if (!errno)
91487cfc 3744 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW		 3745 RETPUSHUNDEF;
3746#else
cea2e8a9 3747 DIE(aTHX_ PL_no_dir_func, "opendir");
a0d0e21e
LW		 3748#endif
3749}
3750
3751PP(pp_readdir)
3752{
a0d0e21e 3753#if defined(Direntry_t) && defined(HAS_READDIR)
9cad6237 3754 dSP;
fd8cd3a3 3755#if !defined(I_DIRENT) && !defined(VMS)
20ce7b12 3756 Direntry_t *readdir (DIR *);
a0d0e21e
LW		 3757#endif
3758 register Direntry_t *dp;
3759 GV *gv = (GV*)POPs;
3760 register IO *io = GvIOn(gv);
fb73857a 3761 SV *sv;
a0d0e21e
LW		 3762
3763 if (!io || !IoDIRP(io))
3764 goto nope;
3765
3766 if (GIMME == G_ARRAY) {
3767 /*SUPPRESS 560*/
155aba94 3768 while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
a0d0e21e 3769#ifdef DIRNAMLEN
79cb57f6 3770 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3771#else
fb73857a 3772 sv = newSVpv(dp->d_name, 0);
3773#endif
3774#ifndef INCOMPLETE_TAINTS
26fb8f1f
GS		 3775 if (!(IoFLAGS(io) & IOf_UNTAINT))
3776 SvTAINTED_on(sv);
a0d0e21e 3777#endif
fb73857a 3778 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3779 }
3780 }
3781 else {
6ad3d225 3782 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW		 3783 goto nope;
3784#ifdef DIRNAMLEN
79cb57f6 3785 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3786#else
fb73857a 3787 sv = newSVpv(dp->d_name, 0);
a0d0e21e 3788#endif
fb73857a 3789#ifndef INCOMPLETE_TAINTS
26fb8f1f
GS		 3790 if (!(IoFLAGS(io) & IOf_UNTAINT))
3791 SvTAINTED_on(sv);
fb73857a 3792#endif
3793 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3794 }
3795 RETURN;
3796
3797nope:
3798 if (!errno)
91487cfc 3799 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3800 if (GIMME == G_ARRAY)
3801 RETURN;
3802 else
3803 RETPUSHUNDEF;
3804#else
cea2e8a9 3805 DIE(aTHX_ PL_no_dir_func, "readdir");
a0d0e21e
LW		 3806#endif
3807}
3808
3809PP(pp_telldir)
3810{
a0d0e21e 3811#if defined(HAS_TELLDIR) || defined(telldir)
9cad6237 3812 dSP; dTARGET;
968dcd91
JH		 3813 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3814 /* XXX netbsd still seemed to.
3815 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3816 --JHI 1999-Feb-02 */
3817# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
20ce7b12 3818 long telldir (DIR *);
dfe9444c 3819# endif
a0d0e21e
LW		 3820 GV *gv = (GV*)POPs;
3821 register IO *io = GvIOn(gv);
3822
3823 if (!io || !IoDIRP(io))
3824 goto nope;
3825
6ad3d225 3826 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 3827 RETURN;
3828nope:
3829 if (!errno)
91487cfc 3830 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3831 RETPUSHUNDEF;
3832#else
cea2e8a9 3833 DIE(aTHX_ PL_no_dir_func, "telldir");
a0d0e21e
LW		 3834#endif
3835}
3836
3837PP(pp_seekdir)
3838{
a0d0e21e 3839#if defined(HAS_SEEKDIR) || defined(seekdir)
9cad6237 3840 dSP;
a0d0e21e
LW		 3841 long along = POPl;
3842 GV *gv = (GV*)POPs;
3843 register IO *io = GvIOn(gv);
3844
3845 if (!io || !IoDIRP(io))
3846 goto nope;
3847
6ad3d225 3848 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 3849
3850 RETPUSHYES;
3851nope:
3852 if (!errno)
91487cfc 3853 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3854 RETPUSHUNDEF;
3855#else
cea2e8a9 3856 DIE(aTHX_ PL_no_dir_func, "seekdir");
a0d0e21e
LW		 3857#endif
3858}
3859
3860PP(pp_rewinddir)
3861{
a0d0e21e 3862#if defined(HAS_REWINDDIR) || defined(rewinddir)
9cad6237 3863 dSP;
a0d0e21e
LW		 3864 GV *gv = (GV*)POPs;
3865 register IO *io = GvIOn(gv);
3866
3867 if (!io || !IoDIRP(io))
3868 goto nope;
3869
6ad3d225 3870 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 3871 RETPUSHYES;
3872nope:
3873 if (!errno)
91487cfc 3874 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3875 RETPUSHUNDEF;
3876#else
cea2e8a9 3877 DIE(aTHX_ PL_no_dir_func, "rewinddir");
a0d0e21e
LW		 3878#endif
3879}
3880
3881PP(pp_closedir)
3882{
a0d0e21e 3883#if defined(Direntry_t) && defined(HAS_READDIR)
9cad6237 3884 dSP;
a0d0e21e
LW		 3885 GV *gv = (GV*)POPs;
3886 register IO *io = GvIOn(gv);
3887
3888 if (!io || !IoDIRP(io))
3889 goto nope;
3890
3891#ifdef VOID_CLOSEDIR
6ad3d225 3892 PerlDir_close(IoDIRP(io));
a0d0e21e 3893#else
6ad3d225 3894 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3895 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3896 goto nope;
748a9306 3897 }
a0d0e21e
LW		 3898#endif
3899 IoDIRP(io) = 0;
3900
3901 RETPUSHYES;
3902nope:
3903 if (!errno)
91487cfc 3904 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3905 RETPUSHUNDEF;
3906#else
cea2e8a9 3907 DIE(aTHX_ PL_no_dir_func, "closedir");
a0d0e21e
LW		 3908#endif
3909}
3910
3911/* Process control. */
3912
3913PP(pp_fork)
3914{
44a8e56a 3915#ifdef HAS_FORK
39644a26 3916 dSP; dTARGET;
761237fe 3917 Pid_t childpid;
a0d0e21e
LW		 3918 GV *tmpgv;
3919
3920 EXTEND(SP, 1);
45bc9206 3921 PERL_FLUSHALL_FOR_CHILD;
52e18b1f 3922 childpid = PerlProc_fork();
a0d0e21e
LW		 3923 if (childpid < 0)
3924 RETSETUNDEF;
3925 if (!childpid) {
3926 /*SUPPRESS 560*/
155aba94 3927 if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
146174a9 3928 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3280af22 3929 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
a0d0e21e
LW		 3930 }
3931 PUSHi(childpid);
3932 RETURN;
3933#else
146174a9 3934# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
39644a26 3935 dSP; dTARGET;
146174a9
CB		 3936 Pid_t childpid;
3937
3938 EXTEND(SP, 1);
3939 PERL_FLUSHALL_FOR_CHILD;
3940 childpid = PerlProc_fork();
60fa28ff
GS		 3941 if (childpid == -1)
3942 RETSETUNDEF;
146174a9
CB		 3943 PUSHi(childpid);
3944 RETURN;
3945# else
0322a713 3946 DIE(aTHX_ PL_no_func, "fork");
146174a9 3947# endif
a0d0e21e
LW		 3948#endif
3949}
3950
3951PP(pp_wait)
3952{
301e8125 3953#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
39644a26 3954 dSP; dTARGET;
761237fe 3955 Pid_t childpid;
a0d0e21e 3956 int argflags;
a0d0e21e 3957
0a0ada86 3958#ifdef PERL_OLD_SIGNALS
44a8e56a 3959 childpid = wait4pid(-1, &argflags, 0);
0a0ada86
NIS		 3960#else
3961 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && errno == EINTR) {
3962 PERL_ASYNC_CHECK();
3963 }
3964#endif
68a29c53
GS		 3965# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3966 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3967 STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3968# else
f86702cc 3969 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
68a29c53 3970# endif
44a8e56a 3971 XPUSHi(childpid);
a0d0e21e
LW		 3972 RETURN;
3973#else
0322a713 3974 DIE(aTHX_ PL_no_func, "wait");
a0d0e21e
LW		 3975#endif
3976}
3977
3978PP(pp_waitpid)
3979{
301e8125 3980#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
39644a26 3981 dSP; dTARGET;
761237fe 3982 Pid_t childpid;
a0d0e21e
LW		 3983 int optype;
3984 int argflags;
a0d0e21e 3985
a0d0e21e
LW		 3986 optype = POPi;
3987 childpid = TOPi;
0a0ada86 3988#ifdef PERL_OLD_SIGNALS
a0d0e21e 3989 childpid = wait4pid(childpid, &argflags, optype);
0a0ada86
NIS		 3990#else
3991 while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 && errno == EINTR) {
3992 PERL_ASYNC_CHECK();
3993 }
3994#endif
68a29c53
GS		 3995# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3996 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3997 STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3998# else
f86702cc 3999 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
68a29c53 4000# endif
44a8e56a 4001 SETi(childpid);
a0d0e21e
LW		 4002 RETURN;
4003#else
0322a713 4004 DIE(aTHX_ PL_no_func, "waitpid");
a0d0e21e
LW		 4005#endif
4006}
4007
4008PP(pp_system)
4009{
39644a26 4010 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 4011 I32 value;
2d8e6c8d 4012 STRLEN n_a;
76ffd3b9 4013 int result;
e7766f89
JH		 4014 int pp[2];
4015 I32 did_pipes = 0;
a0d0e21e 4016
a0d0e21e 4017 if (SP - MARK == 1) {
3280af22 4018 if (PL_tainting) {
516a5887 4019 (void)SvPV_nolen(TOPs); /* stringify for taint check */
a0d0e21e
LW		 4020 TAINT_ENV();
4021 TAINT_PROPER("system");
4022 }
4023 }
45bc9206 4024 PERL_FLUSHALL_FOR_CHILD;
273b0206 4025#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
d7e492a4
JH		 4026 {
4027 Pid_t childpid;
4028 int status;
4029 Sigsave_t ihand,qhand; /* place to save signals during system() */
4030
4031 if (PerlProc_pipe(pp) >= 0)
4032 did_pipes = 1;
52e18b1f 4033 while ((childpid = PerlProc_fork()) == -1) {
d7e492a4
JH		 4034 if (errno != EAGAIN) {
4035 value = -1;
4036 SP = ORIGMARK;
4037 PUSHi(value);
4038 if (did_pipes) {
4039 PerlLIO_close(pp[0]);
4040 PerlLIO_close(pp[1]);
4041 }
4042 RETURN;
4043 }
4044 sleep(5);
4045 }
4046 if (childpid > 0) {
4047 if (did_pipes)
4048 PerlLIO_close(pp[1]);
64ca3a65 4049#ifndef PERL_MICRO
d7e492a4
JH		 4050 rsignal_save(SIGINT, SIG_IGN, &ihand);
4051 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
64ca3a65 4052#endif
d7e492a4
JH		 4053 do {
4054 result = wait4pid(childpid, &status, 0);
4055 } while (result == -1 && errno == EINTR);
64ca3a65 4056#ifndef PERL_MICRO
d7e492a4
JH		 4057 (void)rsignal_restore(SIGINT, &ihand);
4058 (void)rsignal_restore(SIGQUIT, &qhand);
4059#endif
4060 STATUS_NATIVE_SET(result == -1 ? -1 : status);
52e18b1f 4061 do_execfree(); /* free any memory child malloced on fork */
d7e492a4
JH		 4062 SP = ORIGMARK;
4063 if (did_pipes) {
4064 int errkid;
4065 int n = 0, n1;
4066
4067 while (n < sizeof(int)) {
4068 n1 = PerlLIO_read(pp[0],
4069 (void*)(((char*)&errkid)+n),
4070 (sizeof(int)) - n);
4071 if (n1 <= 0)
4072 break;
4073 n += n1;
4074 }
4075 PerlLIO_close(pp[0]);
4076 if (n) { /* Error */
4077 if (n != sizeof(int))
4078 DIE(aTHX_ "panic: kid popen errno read");
4079 errno = errkid; /* Propagate errno from kid */
4080 STATUS_CURRENT = -1;
4081 }
4082 }
4083 PUSHi(STATUS_CURRENT);
4084 RETURN;
4085 }
4086 if (did_pipes) {
4087 PerlLIO_close(pp[0]);
d5a9bfb0 4088#if defined(HAS_FCNTL) && defined(F_SETFD)
d7e492a4 4089 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
d5a9bfb0 4090#endif
d7e492a4 4091 }
d5a9bfb0 4092 }
533c011a 4093 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 4094 SV *really = *++MARK;
d5a9bfb0 4095 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
a0d0e21e
LW		 4096 }
4097 else if (SP - MARK != 1)
d5a9bfb0 4098 value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
a0d0e21e 4099 else {
d5a9bfb0 4100 value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
a0d0e21e 4101 }
6ad3d225 4102 PerlProc__exit(-1);
c3293030 4103#else /* ! FORK or VMS or OS/2 */
922b1888
GS		 4104 PL_statusvalue = 0;
4105 result = 0;
911d147d 4106 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 4107 SV *really = *++MARK;
c5be433b 4108 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW		 4109 }
4110 else if (SP - MARK != 1)
c5be433b 4111 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 4112 else {
c5be433b 4113 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 4114 }
922b1888
GS		 4115 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4116 result = 1;
f86702cc 4117 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 4118 do_execfree();
4119 SP = ORIGMARK;
922b1888 4120 PUSHi(result ? value : STATUS_CURRENT);
a0d0e21e
LW		 4121#endif /* !FORK or VMS */
4122 RETURN;
4123}
4124
4125PP(pp_exec)
4126{
39644a26 4127 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 4128 I32 value;
2d8e6c8d 4129 STRLEN n_a;
a0d0e21e 4130
45bc9206 4131 PERL_FLUSHALL_FOR_CHILD;
533c011a 4132 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 4133 SV *really = *++MARK;
4134 value = (I32)do_aexec(really, MARK, SP);
4135 }
4136 else if (SP - MARK != 1)
4137#ifdef VMS
4138 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
4139#else
092bebab
JH		 4140# ifdef __OPEN_VM
4141 {
c5be433b 4142 (void ) do_aspawn(Nullsv, MARK, SP);
092bebab
JH		 4143 value = 0;
4144 }
4145# else
a0d0e21e 4146 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 4147# endif
a0d0e21e
LW		 4148#endif
4149 else {
3280af22 4150 if (PL_tainting) {
516a5887 4151 (void)SvPV_nolen(*SP); /* stringify for taint check */
a0d0e21e
LW		 4152 TAINT_ENV();
4153 TAINT_PROPER("exec");
4154 }
4155#ifdef VMS
2d8e6c8d 4156 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 4157#else
092bebab 4158# ifdef __OPEN_VM
c5be433b 4159 (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab
JH		 4160 value = 0;
4161# else
2d8e6c8d 4162 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab 4163# endif
a0d0e21e
LW		 4164#endif
4165 }
146174a9 4166
a0d0e21e
LW		 4167 SP = ORIGMARK;
4168 PUSHi(value);
4169 RETURN;
4170}
4171
4172PP(pp_kill)
4173{
9cad6237 4174#ifdef HAS_KILL
39644a26 4175 dSP; dMARK; dTARGET;
a0d0e21e 4176 I32 value;
533c011a 4177 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4178 SP = MARK;
4179 PUSHi(value);
4180 RETURN;
4181#else
0322a713 4182 DIE(aTHX_ PL_no_func, "kill");
a0d0e21e
LW		 4183#endif
4184}
4185
4186PP(pp_getppid)
4187{
4188#ifdef HAS_GETPPID
39644a26 4189 dSP; dTARGET;
a0d0e21e
LW		 4190 XPUSHi( getppid() );
4191 RETURN;
4192#else
cea2e8a9 4193 DIE(aTHX_ PL_no_func, "getppid");
a0d0e21e
LW		 4194#endif
4195}
4196
4197PP(pp_getpgrp)
4198{
4199#ifdef HAS_GETPGRP
39644a26 4200 dSP; dTARGET;
d8a83dd3 4201 Pid_t pid;
9853a804 4202 Pid_t pgrp;
a0d0e21e
LW		 4203
4204 if (MAXARG < 1)
4205 pid = 0;
4206 else
4207 pid = SvIVx(POPs);
c3293030 4208#ifdef BSD_GETPGRP
9853a804 4209 pgrp = (I32)BSD_GETPGRP(pid);
a0d0e21e 4210#else
146174a9 4211 if (pid != 0 && pid != PerlProc_getpid())
cea2e8a9 4212 DIE(aTHX_ "POSIX getpgrp can't take an argument");
9853a804 4213 pgrp = getpgrp();
a0d0e21e 4214#endif
9853a804 4215 XPUSHi(pgrp);
a0d0e21e
LW		 4216 RETURN;
4217#else
cea2e8a9 4218 DIE(aTHX_ PL_no_func, "getpgrp()");
a0d0e21e
LW		 4219#endif
4220}
4221
4222PP(pp_setpgrp)
4223{
4224#ifdef HAS_SETPGRP
39644a26 4225 dSP; dTARGET;
d8a83dd3
JH		 4226 Pid_t pgrp;
4227 Pid_t pid;
a0d0e21e
LW		 4228 if (MAXARG < 2) {
4229 pgrp = 0;
4230 pid = 0;
4231 }
4232 else {
4233 pgrp = POPi;
4234 pid = TOPi;
4235 }
4236
4237 TAINT_PROPER("setpgrp");
c3293030
IZ		 4238#ifdef BSD_SETPGRP
4239 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 4240#else
146174a9
CB		 4241 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4242 || (pid != 0 && pid != PerlProc_getpid()))
4243 {
4244 DIE(aTHX_ "setpgrp can't take arguments");
4245 }
a0d0e21e
LW		 4246 SETi( setpgrp() >= 0 );
4247#endif /* USE_BSDPGRP */
4248 RETURN;
4249#else
cea2e8a9 4250 DIE(aTHX_ PL_no_func, "setpgrp()");
a0d0e21e
LW		 4251#endif
4252}
4253
4254PP(pp_getpriority)
4255{
a0d0e21e 4256#ifdef HAS_GETPRIORITY
9cad6237 4257 dSP; dTARGET;
d05c1ba0
JH		 4258 int who = POPi;
4259 int which = TOPi;
a0d0e21e
LW		 4260 SETi( getpriority(which, who) );
4261 RETURN;
4262#else
cea2e8a9 4263 DIE(aTHX_ PL_no_func, "getpriority()");
a0d0e21e
LW		 4264#endif
4265}
4266
4267PP(pp_setpriority)
4268{
a0d0e21e 4269#ifdef HAS_SETPRIORITY
9cad6237 4270 dSP; dTARGET;
d05c1ba0
JH		 4271 int niceval = POPi;
4272 int who = POPi;
4273 int which = TOPi;
a0d0e21e
LW		 4274 TAINT_PROPER("setpriority");
4275 SETi( setpriority(which, who, niceval) >= 0 );
4276 RETURN;
4277#else
cea2e8a9 4278 DIE(aTHX_ PL_no_func, "setpriority()");
a0d0e21e
LW		 4279#endif
4280}
4281
4282/* Time calls. */
4283
4284PP(pp_time)
4285{
39644a26 4286 dSP; dTARGET;
cbdc8872 4287#ifdef BIG_TIME
4288 XPUSHn( time(Null(Time_t*)) );
4289#else
a0d0e21e 4290 XPUSHi( time(Null(Time_t*)) );
cbdc8872 4291#endif
a0d0e21e
LW		 4292 RETURN;
4293}
4294
cd52b7b2 4295/* XXX The POSIX name is CLK_TCK; it is to be preferred
4296 to HZ. Probably. For now, assume that if the system
4297 defines HZ, it does so correctly. (Will this break
4298 on VMS?)
4299 Probably we ought to use _sysconf(_SC_CLK_TCK), if
4300 it's supported. --AD 9/96.
4301*/
4302
a0d0e21e 4303#ifndef HZ
cd52b7b2 4304# ifdef CLK_TCK
4305# define HZ CLK_TCK
4306# else
4307# define HZ 60
4308# endif
a0d0e21e
LW		 4309#endif
4310
4311PP(pp_tms)
4312{
9cad6237 4313#ifdef HAS_TIMES
39644a26 4314 dSP;
a0d0e21e 4315 EXTEND(SP, 4);
a0d0e21e 4316#ifndef VMS
3280af22 4317 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 4318#else
6b88bc9c 4319 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 4320 /* struct tms, though same data */
4321 /* is returned. */
a0d0e21e
LW		 4322#endif
4323
65202027 4324 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 4325 if (GIMME == G_ARRAY) {
65202027
DS		 4326 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4327 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4328 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW		 4329 }
4330 RETURN;
9cad6237
JH		 4331#else
4332 DIE(aTHX_ "times not implemented");
55497cff 4333#endif /* HAS_TIMES */
a0d0e21e
LW		 4334}
4335
4336PP(pp_localtime)
4337{
cea2e8a9 4338 return pp_gmtime();
a0d0e21e
LW		 4339}
4340
4341PP(pp_gmtime)
4342{
39644a26 4343 dSP;
a0d0e21e
LW		 4344 Time_t when;
4345 struct tm *tmbuf;
4346 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4347 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4348 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4349
4350 if (MAXARG < 1)
4351 (void)time(&when);
4352 else
cbdc8872 4353#ifdef BIG_TIME
4354 when = (Time_t)SvNVx(POPs);
4355#else
a0d0e21e 4356 when = (Time_t)SvIVx(POPs);
cbdc8872 4357#endif
a0d0e21e 4358
533c011a 4359 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW		 4360 tmbuf = localtime(&when);
4361 else
4362 tmbuf = gmtime(&when);
4363
a0d0e21e 4364 if (GIMME != G_ARRAY) {
46fc3d4c 4365 SV *tsv;
9a5ff6d9
AB		 4366 EXTEND(SP, 1);
4367 EXTEND_MORTAL(1);
a0d0e21e
LW		 4368 if (!tmbuf)
4369 RETPUSHUNDEF;
be28567c 4370 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
f5a29b03
RB		 4371 dayname[tmbuf->tm_wday],
4372 monname[tmbuf->tm_mon],
be28567c
GS		 4373 tmbuf->tm_mday,
4374 tmbuf->tm_hour,
4375 tmbuf->tm_min,
4376 tmbuf->tm_sec,
4377 tmbuf->tm_year + 1900);
46fc3d4c 4378 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 4379 }
4380 else if (tmbuf) {
9a5ff6d9
AB		 4381 EXTEND(SP, 9);
4382 EXTEND_MORTAL(9);
4383 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
c6419e06
JH		 4384 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4385 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4386 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4387 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4388 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4389 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4390 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4391 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
a0d0e21e
LW		 4392 }
4393 RETURN;
4394}
4395
4396PP(pp_alarm)
4397{
9cad6237 4398#ifdef HAS_ALARM
39644a26 4399 dSP; dTARGET;
a0d0e21e 4400 int anum;
a0d0e21e
LW		 4401 anum = POPi;
4402 anum = alarm((unsigned int)anum);
4403 EXTEND(SP, 1);
4404 if (anum < 0)
4405 RETPUSHUNDEF;
c6419e06 4406 PUSHi(anum);
a0d0e21e
LW		 4407 RETURN;
4408#else
0322a713 4409 DIE(aTHX_ PL_no_func, "alarm");
a0d0e21e
LW		 4410#endif
4411}
4412
4413PP(pp_sleep)
4414{
39644a26 4415 dSP; dTARGET;
a0d0e21e
LW		 4416 I32 duration;
4417 Time_t lasttime;
4418 Time_t when;
4419
4420 (void)time(&lasttime);
4421 if (MAXARG < 1)
76e3520e 4422 PerlProc_pause();
a0d0e21e
LW		 4423 else {
4424 duration = POPi;
76e3520e 4425 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 4426 }
4427 (void)time(&when);
4428 XPUSHi(when - lasttime);
4429 RETURN;
4430}
4431
4432/* Shared memory. */
4433
4434PP(pp_shmget)
4435{
cea2e8a9 4436 return pp_semget();
a0d0e21e
LW		 4437}
4438
4439PP(pp_shmctl)
4440{
cea2e8a9 4441 return pp_semctl();
a0d0e21e
LW		 4442}
4443
4444PP(pp_shmread)
4445{
cea2e8a9 4446 return pp_shmwrite();
a0d0e21e
LW		 4447}
4448
4449PP(pp_shmwrite)
4450{
4451#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4452 dSP; dMARK; dTARGET;
533c011a 4453 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW		 4454 SP = MARK;
4455 PUSHi(value);
4456 RETURN;
4457#else
cea2e8a9 4458 return pp_semget();
a0d0e21e
LW		 4459#endif
4460}
4461
4462/* Message passing. */
4463
4464PP(pp_msgget)
4465{
cea2e8a9 4466 return pp_semget();
a0d0e21e
LW		 4467}
4468
4469PP(pp_msgctl)
4470{
cea2e8a9 4471 return pp_semctl();
a0d0e21e
LW		 4472}
4473
4474PP(pp_msgsnd)
4475{
4476#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4477 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4478 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4479 SP = MARK;
4480 PUSHi(value);
4481 RETURN;
4482#else
cea2e8a9 4483 return pp_semget();
a0d0e21e
LW		 4484#endif
4485}
4486
4487PP(pp_msgrcv)
4488{
4489#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4490 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4491 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4492 SP = MARK;
4493 PUSHi(value);
4494 RETURN;
4495#else
cea2e8a9 4496 return pp_semget();
a0d0e21e
LW		 4497#endif
4498}
4499
4500/* Semaphores. */
4501
4502PP(pp_semget)
4503{
4504#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4505 dSP; dMARK; dTARGET;
533c011a 4506 int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4507 SP = MARK;
4508 if (anum == -1)
4509 RETPUSHUNDEF;
4510 PUSHi(anum);
4511 RETURN;
4512#else
cea2e8a9 4513 DIE(aTHX_ "System V IPC is not implemented on this machine");
a0d0e21e
LW		 4514#endif
4515}
4516
4517PP(pp_semctl)
4518{
4519#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4520 dSP; dMARK; dTARGET;
533c011a 4521 int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4522 SP = MARK;
4523 if (anum == -1)
4524 RETSETUNDEF;
4525 if (anum != 0) {
4526 PUSHi(anum);
4527 }
4528 else {
8903cb82 4529 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 4530 }
4531 RETURN;
4532#else
cea2e8a9 4533 return pp_semget();
a0d0e21e
LW		 4534#endif
4535}
4536
4537PP(pp_semop)
4538{
4539#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4540 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4541 I32 value = (I32)(do_semop(MARK, SP) >= 0);
4542 SP = MARK;
4543 PUSHi(value);
4544 RETURN;
4545#else
cea2e8a9 4546 return pp_semget();
a0d0e21e
LW		 4547#endif
4548}
4549
4550/* Get system info. */
4551
4552PP(pp_ghbyname)
4553{
693762b4 4554#ifdef HAS_GETHOSTBYNAME
cea2e8a9 4555 return pp_ghostent();
a0d0e21e 4556#else
cea2e8a9 4557 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
a0d0e21e
LW		 4558#endif
4559}
4560
4561PP(pp_ghbyaddr)
4562{
693762b4 4563#ifdef HAS_GETHOSTBYADDR
cea2e8a9 4564 return pp_ghostent();
a0d0e21e 4565#else
cea2e8a9 4566 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
a0d0e21e
LW		 4567#endif
4568}
4569
4570PP(pp_ghostent)
4571{
693762b4 4572#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
9cad6237 4573 dSP;
533c011a 4574 I32 which = PL_op->op_type;
a0d0e21e
LW		 4575 register char **elem;
4576 register SV *sv;
dc45a647 4577#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4578 struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4579 struct hostent *PerlSock_gethostbyname(Netdb_name_t);
6ad3d225 4580 struct hostent *PerlSock_gethostent(void);
a0d0e21e
LW		 4581#endif
4582 struct hostent *hent;
4583 unsigned long len;
2d8e6c8d 4584 STRLEN n_a;
a0d0e21e
LW		 4585
4586 EXTEND(SP, 10);
dc45a647
MB		 4587 if (which == OP_GHBYNAME)
4588#ifdef HAS_GETHOSTBYNAME
595ae481 4589 hent = PerlSock_gethostbyname(POPpbytex);
dc45a647 4590#else
cea2e8a9 4591 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
dc45a647 4592#endif
a0d0e21e 4593 else if (which == OP_GHBYADDR) {
dc45a647 4594#ifdef HAS_GETHOSTBYADDR
a0d0e21e 4595 int addrtype = POPi;
748a9306 4596 SV *addrsv = POPs;
a0d0e21e 4597 STRLEN addrlen;
595ae481 4598 Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
a0d0e21e 4599
4599a1de 4600 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 4601#else
cea2e8a9 4602 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
dc45a647 4603#endif
a0d0e21e
LW		 4604 }
4605 else
4606#ifdef HAS_GETHOSTENT
6ad3d225 4607 hent = PerlSock_gethostent();
a0d0e21e 4608#else
cea2e8a9 4609 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4610#endif
4611
4612#ifdef HOST_NOT_FOUND
4613 if (!hent)
f86702cc 4614 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW		 4615#endif
4616
4617 if (GIMME != G_ARRAY) {
4618 PUSHs(sv = sv_newmortal());
4619 if (hent) {
4620 if (which == OP_GHBYNAME) {
fd0af264 4621 if (hent->h_addr)
4622 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4623 }
4624 else
4625 sv_setpv(sv, (char*)hent->h_name);
4626 }
4627 RETURN;
4628 }
4629
4630 if (hent) {
3280af22 4631 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4632 sv_setpv(sv, (char*)hent->h_name);
3280af22 4633 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4634 for (elem = hent->h_aliases; elem && *elem; elem++) {
4635 sv_catpv(sv, *elem);
4636 if (elem[1])
4637 sv_catpvn(sv, " ", 1);
4638 }
3280af22 4639 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4640 sv_setiv(sv, (IV)hent->h_addrtype);
3280af22 4641 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4642 len = hent->h_length;
1e422769 4643 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 4644#ifdef h_addr
4645 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3280af22 4646 XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4647 sv_setpvn(sv, *elem, len);
4648 }
4649#else
6b88bc9c 4650 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
fd0af264 4651 if (hent->h_addr)
4652 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 4653#endif /* h_addr */
4654 }
4655 RETURN;
4656#else
cea2e8a9 4657 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4658#endif
4659}
4660
4661PP(pp_gnbyname)
4662{
693762b4 4663#ifdef HAS_GETNETBYNAME
cea2e8a9 4664 return pp_gnetent();
a0d0e21e 4665#else
cea2e8a9 4666 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
a0d0e21e
LW		 4667#endif
4668}
4669
4670PP(pp_gnbyaddr)
4671{
693762b4 4672#ifdef HAS_GETNETBYADDR
cea2e8a9 4673 return pp_gnetent();
a0d0e21e 4674#else
cea2e8a9 4675 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
a0d0e21e
LW		 4676#endif
4677}
4678
4679PP(pp_gnetent)
4680{
693762b4 4681#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
9cad6237 4682 dSP;
533c011a 4683 I32 which = PL_op->op_type;
a0d0e21e
LW		 4684 register char **elem;
4685 register SV *sv;
dc45a647
MB		 4686#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4687 struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4688 struct netent *PerlSock_getnetbyname(Netdb_name_t);
4689 struct netent *PerlSock_getnetent(void);
8ac85365 4690#endif
a0d0e21e 4691 struct netent *nent;
2d8e6c8d 4692 STRLEN n_a;
a0d0e21e
LW		 4693
4694 if (which == OP_GNBYNAME)
dc45a647 4695#ifdef HAS_GETNETBYNAME
42e0c139 4696 nent = PerlSock_getnetbyname(POPpbytex);
dc45a647 4697#else
cea2e8a9 4698 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
dc45a647 4699#endif
a0d0e21e 4700 else if (which == OP_GNBYADDR) {
dc45a647 4701#ifdef HAS_GETNETBYADDR
a0d0e21e 4702 int addrtype = POPi;
3bb7c1b4 4703 Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
76e3520e 4704 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4705#else
cea2e8a9 4706 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
dc45a647 4707#endif
a0d0e21e
LW		 4708 }
4709 else
dc45a647 4710#ifdef HAS_GETNETENT
76e3520e 4711 nent = PerlSock_getnetent();
dc45a647 4712#else
cea2e8a9 4713 DIE(aTHX_ PL_no_sock_func, "getnetent");
dc45a647 4714#endif
a0d0e21e
LW		 4715
4716 EXTEND(SP, 4);
4717 if (GIMME != G_ARRAY) {
4718 PUSHs(sv = sv_newmortal());
4719 if (nent) {
4720 if (which == OP_GNBYNAME)
1e422769 4721 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4722 else
4723 sv_setpv(sv, nent->n_name);
4724 }
4725 RETURN;
4726 }
4727
4728 if (nent) {
3280af22 4729 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4730 sv_setpv(sv, nent->n_name);
3280af22 4731 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4732 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4733 sv_catpv(sv, *elem);
4734 if (elem[1])
4735 sv_catpvn(sv, " ", 1);
4736 }
3280af22 4737 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4738 sv_setiv(sv, (IV)nent->n_addrtype);
3280af22 4739 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4740 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4741 }
4742
4743 RETURN;
4744#else
cea2e8a9 4745 DIE(aTHX_ PL_no_sock_func, "getnetent");
a0d0e21e
LW		 4746#endif
4747}
4748
4749PP(pp_gpbyname)
4750{
693762b4 4751#ifdef HAS_GETPROTOBYNAME
cea2e8a9 4752 return pp_gprotoent();
a0d0e21e 4753#else
cea2e8a9 4754 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
a0d0e21e
LW		 4755#endif
4756}
4757
4758PP(pp_gpbynumber)
4759{
693762b4 4760#ifdef HAS_GETPROTOBYNUMBER
cea2e8a9 4761 return pp_gprotoent();
a0d0e21e 4762#else
cea2e8a9 4763 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
a0d0e21e
LW		 4764#endif
4765}
4766
4767PP(pp_gprotoent)
4768{
693762b4 4769#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
9cad6237 4770 dSP;
533c011a 4771 I32 which = PL_op->op_type;
a0d0e21e 4772 register char **elem;
301e8125 4773 register SV *sv;
dc45a647 4774#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4599a1de 4775 struct protoent *PerlSock_getprotobyname(Netdb_name_t);
6ad3d225
GS		 4776 struct protoent *PerlSock_getprotobynumber(int);
4777 struct protoent *PerlSock_getprotoent(void);
8ac85365 4778#endif
a0d0e21e 4779 struct protoent *pent;
2d8e6c8d 4780 STRLEN n_a;
a0d0e21e
LW		 4781
4782 if (which == OP_GPBYNAME)
e5c9fcd0 4783#ifdef HAS_GETPROTOBYNAME
42e0c139 4784 pent = PerlSock_getprotobyname(POPpbytex);
e5c9fcd0 4785#else
cea2e8a9 4786 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
e5c9fcd0 4787#endif
a0d0e21e 4788 else if (which == OP_GPBYNUMBER)
e5c9fcd0 4789#ifdef HAS_GETPROTOBYNUMBER
6ad3d225 4790 pent = PerlSock_getprotobynumber(POPi);
e5c9fcd0 4791#else
cea2e8a9 4792 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4793#endif
a0d0e21e 4794 else
e5c9fcd0 4795#ifdef HAS_GETPROTOENT
6ad3d225 4796 pent = PerlSock_getprotoent();
e5c9fcd0 4797#else
cea2e8a9 4798 DIE(aTHX_ PL_no_sock_func, "getprotoent");
e5c9fcd0 4799#endif
a0d0e21e
LW		 4800
4801 EXTEND(SP, 3);
4802 if (GIMME != G_ARRAY) {
4803 PUSHs(sv = sv_newmortal());
4804 if (pent) {
4805 if (which == OP_GPBYNAME)
1e422769 4806 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4807 else
4808 sv_setpv(sv, pent->p_name);
4809 }
4810 RETURN;
4811 }
4812
4813 if (pent) {
3280af22 4814 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4815 sv_setpv(sv, pent->p_name);
3280af22 4816 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4817 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4818 sv_catpv(sv, *elem);
4819 if (elem[1])
4820 sv_catpvn(sv, " ", 1);
4821 }
3280af22 4822 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4823 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4824 }
4825
4826 RETURN;
4827#else
cea2e8a9 4828 DIE(aTHX_ PL_no_sock_func, "getprotoent");
a0d0e21e
LW		 4829#endif
4830}
4831
4832PP(pp_gsbyname)
4833{
9ec75305 4834#ifdef HAS_GETSERVBYNAME
cea2e8a9 4835 return pp_gservent();
a0d0e21e 4836#else
cea2e8a9 4837 DIE(aTHX_ PL_no_sock_func, "getservbyname");
a0d0e21e
LW		 4838#endif
4839}
4840
4841PP(pp_gsbyport)
4842{
9ec75305 4843#ifdef HAS_GETSERVBYPORT
cea2e8a9 4844 return pp_gservent();
a0d0e21e 4845#else
cea2e8a9 4846 DIE(aTHX_ PL_no_sock_func, "getservbyport");
a0d0e21e
LW		 4847#endif
4848}
4849
4850PP(pp_gservent)
4851{
693762b4 4852#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
9cad6237 4853 dSP;
533c011a 4854 I32 which = PL_op->op_type;
a0d0e21e
LW		 4855 register char **elem;
4856 register SV *sv;
dc45a647 4857#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4858 struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4859 struct servent *PerlSock_getservbyport(int, Netdb_name_t);
6ad3d225 4860 struct servent *PerlSock_getservent(void);
8ac85365 4861#endif
a0d0e21e 4862 struct servent *sent;
2d8e6c8d 4863 STRLEN n_a;
a0d0e21e
LW		 4864
4865 if (which == OP_GSBYNAME) {
dc45a647 4866#ifdef HAS_GETSERVBYNAME
42e0c139
AP		 4867 char *proto = POPpbytex;
4868 char *name = POPpbytex;
a0d0e21e
LW		 4869
4870 if (proto && !*proto)
4871 proto = Nullch;
4872
6ad3d225 4873 sent = PerlSock_getservbyname(name, proto);
dc45a647 4874#else
cea2e8a9 4875 DIE(aTHX_ PL_no_sock_func, "getservbyname");
dc45a647 4876#endif
a0d0e21e
LW		 4877 }
4878 else if (which == OP_GSBYPORT) {
dc45a647 4879#ifdef HAS_GETSERVBYPORT
42e0c139 4880 char *proto = POPpbytex;
36477c24 4881 unsigned short port = POPu;
a0d0e21e 4882
36477c24 4883#ifdef HAS_HTONS
6ad3d225 4884 port = PerlSock_htons(port);
36477c24 4885#endif
6ad3d225 4886 sent = PerlSock_getservbyport(port, proto);
dc45a647 4887#else
cea2e8a9 4888 DIE(aTHX_ PL_no_sock_func, "getservbyport");
dc45a647 4889#endif
a0d0e21e
LW		 4890 }
4891 else
e5c9fcd0 4892#ifdef HAS_GETSERVENT
6ad3d225 4893 sent = PerlSock_getservent();
e5c9fcd0 4894#else
cea2e8a9 4895 DIE(aTHX_ PL_no_sock_func, "getservent");
e5c9fcd0 4896#endif
a0d0e21e
LW		 4897
4898 EXTEND(SP, 4);
4899 if (GIMME != G_ARRAY) {
4900 PUSHs(sv = sv_newmortal());
4901 if (sent) {
4902 if (which == OP_GSBYNAME) {
4903#ifdef HAS_NTOHS
6ad3d225 4904 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4905#else
1e422769 4906 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4907#endif
4908 }
4909 else
4910 sv_setpv(sv, sent->s_name);
4911 }
4912 RETURN;
4913 }
4914
4915 if (sent) {
3280af22 4916 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4917 sv_setpv(sv, sent->s_name);
3280af22 4918 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4919 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4920 sv_catpv(sv, *elem);
4921 if (elem[1])
4922 sv_catpvn(sv, " ", 1);
4923 }
3280af22 4924 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4925#ifdef HAS_NTOHS
76e3520e 4926 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4927#else
1e422769 4928 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e 4929#endif
3280af22 4930 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4931 sv_setpv(sv, sent->s_proto);
4932 }
4933
4934 RETURN;
4935#else
cea2e8a9 4936 DIE(aTHX_ PL_no_sock_func, "getservent");
a0d0e21e
LW		 4937#endif
4938}
4939
4940PP(pp_shostent)
4941{
693762b4 4942#ifdef HAS_SETHOSTENT
9cad6237 4943 dSP;
76e3520e 4944 PerlSock_sethostent(TOPi);
a0d0e21e
LW		 4945 RETSETYES;
4946#else
cea2e8a9 4947 DIE(aTHX_ PL_no_sock_func, "sethostent");
a0d0e21e
LW		 4948#endif
4949}
4950
4951PP(pp_snetent)
4952{
693762b4 4953#ifdef HAS_SETNETENT
9cad6237 4954 dSP;
76e3520e 4955 PerlSock_setnetent(TOPi);
a0d0e21e
LW		 4956 RETSETYES;
4957#else
cea2e8a9 4958 DIE(aTHX_ PL_no_sock_func, "setnetent");
a0d0e21e
LW		 4959#endif
4960}
4961
4962PP(pp_sprotoent)
4963{
693762b4 4964#ifdef HAS_SETPROTOENT
9cad6237 4965 dSP;
76e3520e 4966 PerlSock_setprotoent(TOPi);
a0d0e21e
LW		 4967 RETSETYES;
4968#else
cea2e8a9 4969 DIE(aTHX_ PL_no_sock_func, "setprotoent");
a0d0e21e
LW		 4970#endif
4971}
4972
4973PP(pp_sservent)
4974{
693762b4 4975#ifdef HAS_SETSERVENT
9cad6237 4976 dSP;
76e3520e 4977 PerlSock_setservent(TOPi);
a0d0e21e
LW		 4978 RETSETYES;
4979#else
cea2e8a9 4980 DIE(aTHX_ PL_no_sock_func, "setservent");
a0d0e21e
LW		 4981#endif
4982}
4983
4984PP(pp_ehostent)
4985{
693762b4 4986#ifdef HAS_ENDHOSTENT
9cad6237 4987 dSP;
76e3520e 4988 PerlSock_endhostent();
924508f0 4989 EXTEND(SP,1);
a0d0e21e
LW		 4990 RETPUSHYES;
4991#else
cea2e8a9 4992 DIE(aTHX_ PL_no_sock_func, "endhostent");
a0d0e21e
LW		 4993#endif
4994}
4995
4996PP(pp_enetent)
4997{
693762b4 4998#ifdef HAS_ENDNETENT
9cad6237 4999 dSP;
76e3520e 5000 PerlSock_endnetent();
924508f0 5001 EXTEND(SP,1);
a0d0e21e
LW		 5002 RETPUSHYES;
5003#else
cea2e8a9 5004 DIE(aTHX_ PL_no_sock_func, "endnetent");
a0d0e21e
LW		 5005#endif
5006}
5007
5008PP(pp_eprotoent)
5009{
693762b4 5010#ifdef HAS_ENDPROTOENT
9cad6237 5011 dSP;
76e3520e 5012 PerlSock_endprotoent();
924508f0 5013 EXTEND(SP,1);
a0d0e21e
LW		 5014 RETPUSHYES;
5015#else
cea2e8a9 5016 DIE(aTHX_ PL_no_sock_func, "endprotoent");
a0d0e21e
LW		 5017#endif
5018}
5019
5020PP(pp_eservent)
5021{
693762b4 5022#ifdef HAS_ENDSERVENT
9cad6237 5023 dSP;
76e3520e 5024 PerlSock_endservent();
924508f0 5025 EXTEND(SP,1);
a0d0e21e
LW		 5026 RETPUSHYES;
5027#else
cea2e8a9 5028 DIE(aTHX_ PL_no_sock_func, "endservent");
a0d0e21e
LW		 5029#endif
5030}
5031
5032PP(pp_gpwnam)
5033{
5034#ifdef HAS_PASSWD
cea2e8a9 5035 return pp_gpwent();
a0d0e21e 5036#else
cea2e8a9 5037 DIE(aTHX_ PL_no_func, "getpwnam");
a0d0e21e
LW		 5038#endif
5039}
5040
5041PP(pp_gpwuid)
5042{
5043#ifdef HAS_PASSWD
cea2e8a9 5044 return pp_gpwent();
a0d0e21e 5045#else
cea2e8a9 5046 DIE(aTHX_ PL_no_func, "getpwuid");
a0d0e21e
LW		 5047#endif
5048}
5049
5050PP(pp_gpwent)
5051{
0994c4d0 5052#ifdef HAS_PASSWD
9cad6237 5053 dSP;
533c011a 5054 I32 which = PL_op->op_type;
a0d0e21e 5055 register SV *sv;
2d8e6c8d 5056 STRLEN n_a;
e3aefe8d 5057 struct passwd *pwent = NULL;
301e8125 5058 /*
bcf53261
JH		 5059 * We currently support only the SysV getsp* shadow password interface.
5060 * The interface is declared in <shadow.h> and often one needs to link
5061 * with -lsecurity or some such.
5062 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5063 * (and SCO?)
5064 *
5065 * AIX getpwnam() is clever enough to return the encrypted password
5066 * only if the caller (euid?) is root.
5067 *
5068 * There are at least two other shadow password APIs. Many platforms
5069 * seem to contain more than one interface for accessing the shadow
5070 * password databases, possibly for compatibility reasons.
3813c136 5071 * The getsp*() is by far he simplest one, the other two interfaces
bcf53261
JH		 5072 * are much more complicated, but also very similar to each other.
5073 *
5074 * <sys/types.h>
5075 * <sys/security.h>
5076 * <prot.h>
5077 * struct pr_passwd *getprpw*();
5078 * The password is in
3813c136
JH		 5079 * char getprpw*(...).ufld.fd_encrypt[]
5080 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
bcf53261
JH		 5081 *
5082 * <sys/types.h>
5083 * <sys/security.h>
5084 * <prot.h>
5085 * struct es_passwd *getespw*();
5086 * The password is in
5087 * char *(getespw*(...).ufld.fd_encrypt)
3813c136 5088 * Mention HAS_GETESPWNAM here so that Configure probes for it.
bcf53261 5089 *
3813c136 5090 * Mention I_PROT here so that Configure probes for it.
bcf53261
JH		 5091 *
5092 * In HP-UX for getprpw*() the manual page claims that one should include
5093 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5094 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5095 * and pp_sys.c already includes <shadow.h> if there is such.
3813c136
JH		 5096 *
5097 * Note that <sys/security.h> is already probed for, but currently
5098 * it is only included in special cases.
301e8125 5099 *
bcf53261
JH		 5100 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5101 * be preferred interface, even though also the getprpw*() interface
5102 * is available) one needs to link with -lsecurity -ldb -laud -lm.
3813c136
JH		 5103 * One also needs to call set_auth_parameters() in main() before
5104 * doing anything else, whether one is using getespw*() or getprpw*().
5105 *
5106 * Note that accessing the shadow databases can be magnitudes
5107 * slower than accessing the standard databases.
bcf53261
JH		 5108 *
5109 * --jhi
5110 */
a0d0e21e 5111
e3aefe8d
JH		 5112 switch (which) {
5113 case OP_GPWNAM:
42e0c139 5114 pwent = getpwnam(POPpbytex);
e3aefe8d
JH		 5115 break;
5116 case OP_GPWUID:
5117 pwent = getpwuid((Uid_t)POPi);
5118 break;
5119 case OP_GPWENT:
1883634f 5120# ifdef HAS_GETPWENT
e3aefe8d 5121 pwent = getpwent();
1883634f 5122# else
a45d1c96 5123 DIE(aTHX_ PL_no_func, "getpwent");
1883634f 5124# endif
e3aefe8d
JH		 5125 break;
5126 }
8c0bfa08 5127
a0d0e21e
LW		 5128 EXTEND(SP, 10);
5129 if (GIMME != G_ARRAY) {
5130 PUSHs(sv = sv_newmortal());
5131 if (pwent) {
5132 if (which == OP_GPWNAM)
1883634f 5133# if Uid_t_sign <= 0
1e422769 5134 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5135# else
23dcd6c8 5136 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5137# endif
a0d0e21e
LW		 5138 else
5139 sv_setpv(sv, pwent->pw_name);
5140 }
5141 RETURN;
5142 }
5143
5144 if (pwent) {
3280af22 5145 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5146 sv_setpv(sv, pwent->pw_name);
6ee623d5 5147
3280af22 5148 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3813c136
JH		 5149 SvPOK_off(sv);
5150 /* If we have getspnam(), we try to dig up the shadow
5151 * password. If we are underprivileged, the shadow
5152 * interface will set the errno to EACCES or similar,
5153 * and return a null pointer. If this happens, we will
5154 * use the dummy password (usually "*" or "x") from the
5155 * standard password database.
5156 *
5157 * In theory we could skip the shadow call completely
5158 * if euid != 0 but in practice we cannot know which
5159 * security measures are guarding the shadow databases
5160 * on a random platform.
5161 *
5162 * Resist the urge to use additional shadow interfaces.
5163 * Divert the urge to writing an extension instead.
5164 *
5165 * --jhi */
e3aefe8d 5166# ifdef HAS_GETSPNAM
3813c136
JH		 5167 {
5168 struct spwd *spwent;
5169 int saverrno; /* Save and restore errno so that
5170 * underprivileged attempts seem
5171 * to have never made the unsccessful
5172 * attempt to retrieve the shadow password. */
5173
5174 saverrno = errno;
5175 spwent = getspnam(pwent->pw_name);
5176 errno = saverrno;
5177 if (spwent && spwent->sp_pwdp)
5178 sv_setpv(sv, spwent->sp_pwdp);
5179 }
f1066039 5180# endif
e020c87d 5181# ifdef PWPASSWD
3813c136
JH		 5182 if (!SvPOK(sv)) /* Use the standard password, then. */
5183 sv_setpv(sv, pwent->pw_passwd);
e020c87d 5184# endif
3813c136 5185
1883634f 5186# ifndef INCOMPLETE_TAINTS
3813c136
JH		 5187 /* passwd is tainted because user himself can diddle with it.
5188 * admittedly not much and in a very limited way, but nevertheless. */
2959b6e3 5189 SvTAINTED_on(sv);
1883634f 5190# endif
6ee623d5 5191
3280af22 5192 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5193# if Uid_t_sign <= 0
1e422769 5194 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5195# else
23dcd6c8 5196 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5197# endif
6ee623d5 5198
3280af22 5199 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5200# if Uid_t_sign <= 0
1e422769 5201 sv_setiv(sv, (IV)pwent->pw_gid);
1883634f 5202# else
23dcd6c8 5203 sv_setuv(sv, (UV)pwent->pw_gid);
1883634f 5204# endif
3813c136
JH		 5205 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5206 * because of the poor interface of the Perl getpw*(),
5207 * not because there's some standard/convention saying so.
5208 * A better interface would have been to return a hash,
5209 * but we are accursed by our history, alas. --jhi. */
3280af22 5210 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5211# ifdef PWCHANGE
1e422769 5212 sv_setiv(sv, (IV)pwent->pw_change);
6ee623d5 5213# else
1883634f
JH		 5214# ifdef PWQUOTA
5215 sv_setiv(sv, (IV)pwent->pw_quota);
5216# else
a1757be1 5217# ifdef PWAGE
a0d0e21e 5218 sv_setpv(sv, pwent->pw_age);
a1757be1 5219# endif
6ee623d5
GS		 5220# endif
5221# endif
6ee623d5 5222
3813c136
JH		 5223 /* pw_class and pw_comment are mutually exclusive--.
5224 * see the above note for pw_change, pw_quota, and pw_age. */
3280af22 5225 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5226# ifdef PWCLASS
a0d0e21e 5227 sv_setpv(sv, pwent->pw_class);
1883634f
JH		 5228# else
5229# ifdef PWCOMMENT
a0d0e21e 5230 sv_setpv(sv, pwent->pw_comment);
1883634f 5231# endif
6ee623d5 5232# endif
6ee623d5 5233
3280af22 5234 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5235# ifdef PWGECOS
a0d0e21e 5236 sv_setpv(sv, pwent->pw_gecos);
1883634f
JH		 5237# endif
5238# ifndef INCOMPLETE_TAINTS
d2719217 5239 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 5240 SvTAINTED_on(sv);
1883634f 5241# endif
6ee623d5 5242
3280af22 5243 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5244 sv_setpv(sv, pwent->pw_dir);
6ee623d5 5245
3280af22 5246 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5247 sv_setpv(sv, pwent->pw_shell);
1883634f 5248# ifndef INCOMPLETE_TAINTS
4602f195
JH		 5249 /* pw_shell is tainted because user himself can diddle with it. */
5250 SvTAINTED_on(sv);
1883634f 5251# endif
6ee623d5 5252
1883634f 5253# ifdef PWEXPIRE
6b88bc9c 5254 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5255 sv_setiv(sv, (IV)pwent->pw_expire);
1883634f 5256# endif
a0d0e21e
LW		 5257 }
5258 RETURN;
5259#else
cea2e8a9 5260 DIE(aTHX_ PL_no_func, "getpwent");
a0d0e21e
LW		 5261#endif
5262}
5263
5264PP(pp_spwent)
5265{
d493b042 5266#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
9cad6237 5267 dSP;
a0d0e21e
LW		 5268 setpwent();
5269 RETPUSHYES;
5270#else
cea2e8a9 5271 DIE(aTHX_ PL_no_func, "setpwent");
a0d0e21e
LW		 5272#endif
5273}
5274
5275PP(pp_epwent)
5276{
28e8609d 5277#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
9cad6237 5278 dSP;
a0d0e21e
LW		 5279 endpwent();
5280 RETPUSHYES;
5281#else
cea2e8a9 5282 DIE(aTHX_ PL_no_func, "endpwent");
a0d0e21e
LW		 5283#endif
5284}
5285
5286PP(pp_ggrnam)
5287{
5288#ifdef HAS_GROUP
cea2e8a9 5289 return pp_ggrent();
a0d0e21e 5290#else
cea2e8a9 5291 DIE(aTHX_ PL_no_func, "getgrnam");
a0d0e21e
LW		 5292#endif
5293}
5294
5295PP(pp_ggrgid)
5296{
5297#ifdef HAS_GROUP
cea2e8a9 5298 return pp_ggrent();
a0d0e21e 5299#else
cea2e8a9 5300 DIE(aTHX_ PL_no_func, "getgrgid");
a0d0e21e
LW		 5301#endif
5302}
5303
5304PP(pp_ggrent)
5305{
0994c4d0 5306#ifdef HAS_GROUP
9cad6237 5307 dSP;
533c011a 5308 I32 which = PL_op->op_type;
a0d0e21e
LW		 5309 register char **elem;
5310 register SV *sv;
5311 struct group *grent;
2d8e6c8d 5312 STRLEN n_a;
a0d0e21e
LW		 5313
5314 if (which == OP_GGRNAM)
42e0c139 5315 grent = (struct group *)getgrnam(POPpbytex);
a0d0e21e
LW		 5316 else if (which == OP_GGRGID)
5317 grent = (struct group *)getgrgid(POPi);
5318 else
0994c4d0 5319#ifdef HAS_GETGRENT
a0d0e21e 5320 grent = (struct group *)getgrent();
0994c4d0
JH		 5321#else
5322 DIE(aTHX_ PL_no_func, "getgrent");
5323#endif
a0d0e21e
LW		 5324
5325 EXTEND(SP, 4);
5326 if (GIMME != G_ARRAY) {
5327 PUSHs(sv = sv_newmortal());
5328 if (grent) {
5329 if (which == OP_GGRNAM)
1e422769 5330 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 5331 else
5332 sv_setpv(sv, grent->gr_name);
5333 }
5334 RETURN;
5335 }
5336
5337 if (grent) {
3280af22 5338 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5339 sv_setpv(sv, grent->gr_name);
28e8609d 5340
3280af22 5341 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 5342#ifdef GRPASSWD
a0d0e21e 5343 sv_setpv(sv, grent->gr_passwd);
28e8609d
JH		 5344#endif
5345
3280af22 5346 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5347 sv_setiv(sv, (IV)grent->gr_gid);
28e8609d 5348
3280af22 5349 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 5350 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 5351 sv_catpv(sv, *elem);
5352 if (elem[1])
5353 sv_catpvn(sv, " ", 1);
5354 }
5355 }
5356
5357 RETURN;
5358#else
cea2e8a9 5359 DIE(aTHX_ PL_no_func, "getgrent");
a0d0e21e
LW		 5360#endif
5361}
5362
5363PP(pp_sgrent)
5364{
28e8609d 5365#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
9cad6237 5366 dSP;
a0d0e21e
LW		 5367 setgrent();
5368 RETPUSHYES;
5369#else
cea2e8a9 5370 DIE(aTHX_ PL_no_func, "setgrent");
a0d0e21e
LW		 5371#endif
5372}
5373
5374PP(pp_egrent)
5375{
28e8609d 5376#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
9cad6237 5377 dSP;
a0d0e21e
LW		 5378 endgrent();
5379 RETPUSHYES;
5380#else
cea2e8a9 5381 DIE(aTHX_ PL_no_func, "endgrent");
a0d0e21e
LW		 5382#endif
5383}
5384
5385PP(pp_getlogin)
5386{
a0d0e21e 5387#ifdef HAS_GETLOGIN
9cad6237 5388 dSP; dTARGET;
a0d0e21e
LW		 5389 char *tmps;
5390 EXTEND(SP, 1);
76e3520e 5391 if (!(tmps = PerlProc_getlogin()))
a0d0e21e
LW		 5392 RETPUSHUNDEF;
5393 PUSHp(tmps, strlen(tmps));
5394 RETURN;
5395#else
cea2e8a9 5396 DIE(aTHX_ PL_no_func, "getlogin");
a0d0e21e
LW		 5397#endif
5398}
5399
5400/* Miscellaneous. */
5401
5402PP(pp_syscall)
5403{
d2719217 5404#ifdef HAS_SYSCALL
39644a26 5405 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 5406 register I32 items = SP - MARK;
5407 unsigned long a[20];
5408 register I32 i = 0;
5409 I32 retval = -1;
2d8e6c8d 5410 STRLEN n_a;
a0d0e21e 5411
3280af22 5412 if (PL_tainting) {
a0d0e21e 5413 while (++MARK <= SP) {
bbce6d69 5414 if (SvTAINTED(*MARK)) {
5415 TAINT;
5416 break;
5417 }
a0d0e21e
LW		 5418 }
5419 MARK = ORIGMARK;
5420 TAINT_PROPER("syscall");
5421 }
5422
5423 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5424 * or where sizeof(long) != sizeof(char*). But such machines will
5425 * not likely have syscall implemented either, so who cares?
5426 */
5427 while (++MARK <= SP) {
5428 if (SvNIOK(*MARK) || !i)
5429 a[i++] = SvIV(*MARK);
3280af22 5430 else if (*MARK == &PL_sv_undef)
748a9306 5431 a[i++] = 0;
301e8125 5432 else
2d8e6c8d 5433 a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
a0d0e21e
LW		 5434 if (i > 15)
5435 break;
5436 }
5437 switch (items) {
5438 default:
cea2e8a9 5439 DIE(aTHX_ "Too many args to syscall");
a0d0e21e 5440 case 0:
cea2e8a9 5441 DIE(aTHX_ "Too few args to syscall");
a0d0e21e
LW		 5442 case 1:
5443 retval = syscall(a[0]);
5444 break;
5445 case 2:
5446 retval = syscall(a[0],a[1]);
5447 break;
5448 case 3:
5449 retval = syscall(a[0],a[1],a[2]);
5450 break;
5451 case 4:
5452 retval = syscall(a[0],a[1],a[2],a[3]);
5453 break;
5454 case 5:
5455 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5456 break;
5457 case 6:
5458 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5459 break;
5460 case 7:
5461 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5462 break;
5463 case 8:
5464 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5465 break;
5466#ifdef atarist
5467 case 9:
5468 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5469 break;
5470 case 10:
5471 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5472 break;
5473 case 11:
5474 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5475 a[10]);
5476 break;
5477 case 12:
5478 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5479 a[10],a[11]);
5480 break;
5481 case 13:
5482 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5483 a[10],a[11],a[12]);
5484 break;
5485 case 14:
5486 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5487 a[10],a[11],a[12],a[13]);
5488 break;
5489#endif /* atarist */
5490 }
5491 SP = ORIGMARK;
5492 PUSHi(retval);
5493 RETURN;
5494#else
cea2e8a9 5495 DIE(aTHX_ PL_no_func, "syscall");
a0d0e21e
LW		 5496#endif
5497}
5498
ff68c719 5499#ifdef FCNTL_EMULATE_FLOCK
301e8125 5500
ff68c719 5501/* XXX Emulate flock() with fcntl().
5502 What's really needed is a good file locking module.
5503*/
5504
cea2e8a9
GS		 5505static int
5506fcntl_emulate_flock(int fd, int operation)
ff68c719 5507{
5508 struct flock flock;
301e8125 5509
ff68c719 5510 switch (operation & ~LOCK_NB) {
5511 case LOCK_SH:
5512 flock.l_type = F_RDLCK;
5513 break;
5514 case LOCK_EX:
5515 flock.l_type = F_WRLCK;
5516 break;
5517 case LOCK_UN:
5518 flock.l_type = F_UNLCK;
5519 break;
5520 default:
5521 errno = EINVAL;
5522 return -1;
5523 }
5524 flock.l_whence = SEEK_SET;
d9b3e12d 5525 flock.l_start = flock.l_len = (Off_t)0;
301e8125 5526
ff68c719 5527 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5528}
5529
5530#endif /* FCNTL_EMULATE_FLOCK */
5531
5532#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 5533
5534/* XXX Emulate flock() with lockf(). This is just to increase
5535 portability of scripts. The calls are not completely
5536 interchangeable. What's really needed is a good file
5537 locking module.
5538*/
5539
76c32331 5540/* The lockf() constants might have been defined in <unistd.h>.
5541 Unfortunately, <unistd.h> causes troubles on some mixed
5542 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 5543
5544 Further, the lockf() constants aren't POSIX, so they might not be
5545 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5546 just stick in the SVID values and be done with it. Sigh.
5547*/
5548
5549# ifndef F_ULOCK
5550# define F_ULOCK 0 /* Unlock a previously locked region */
5551# endif
5552# ifndef F_LOCK
5553# define F_LOCK 1 /* Lock a region for exclusive use */
5554# endif
5555# ifndef F_TLOCK
5556# define F_TLOCK 2 /* Test and lock a region for exclusive use */
5557# endif
5558# ifndef F_TEST
5559# define F_TEST 3 /* Test a region for other processes locks */
5560# endif
5561
cea2e8a9
GS		 5562static int
5563lockf_emulate_flock(int fd, int operation)
16d20bd9
AD		 5564{
5565 int i;
84902520
TB		 5566 int save_errno;
5567 Off_t pos;
5568
5569 /* flock locks entire file so for lockf we need to do the same */
5570 save_errno = errno;
6ad3d225 5571 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 5572 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 5573 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 5574 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 5575 errno = save_errno;
5576
16d20bd9
AD		 5577 switch (operation) {
5578
5579 /* LOCK_SH - get a shared lock */
5580 case LOCK_SH:
5581 /* LOCK_EX - get an exclusive lock */
5582 case LOCK_EX:
5583 i = lockf (fd, F_LOCK, 0);
5584 break;
5585
5586 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5587 case LOCK_SH|LOCK_NB:
5588 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5589 case LOCK_EX|LOCK_NB:
5590 i = lockf (fd, F_TLOCK, 0);
5591 if (i == -1)
5592 if ((errno == EAGAIN) || (errno == EACCES))
5593 errno = EWOULDBLOCK;
5594 break;
5595
ff68c719 5596 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 5597 case LOCK_UN:
ff68c719 5598 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 5599 i = lockf (fd, F_ULOCK, 0);
5600 break;
5601
5602 /* Default - can't decipher operation */
5603 default:
5604 i = -1;
5605 errno = EINVAL;
5606 break;
5607 }
84902520
TB		 5608
5609 if (pos > 0) /* need to restore position of the handle */
6ad3d225 5610 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 5611
16d20bd9
AD		 5612 return (i);
5613}
ff68c719 5614
5615#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.