3 * Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 * 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * But only a short way ahead its floor and the walls on either side were
13 * cloven by a great fissure, out of which the red glare came, now leaping
14 * up, now dying down into darkness; and all the while far below there was
15 * a rumour and a trouble as of great engines throbbing and labouring.
17 * [p.945 of _The Lord of the Rings_, VI/iii: "Mount Doom"]
20 /* This file contains system pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
26 * By 'system', we mean ops which interact with the OS, such as pp_open().
30 #define PERL_IN_PP_SYS_C
36 /* Shadow password support for solaris - pdo@cs.umd.edu
37 * Not just Solaris: at least HP-UX, IRIX, Linux.
38 * The API is from SysV.
40 * There are at least two more shadow interfaces,
41 * see the comments in pp_gpwent().
45 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
46 * and another MAXINT from "perl.h" <- <sys/param.h>. */
53 # include <sys/wait.h>
57 # include <sys/resource.h>
66 # include <sys/select.h>
70 /* XXX Configure test needed.
71 h_errno might not be a simple 'int', especially for multi-threaded
72 applications, see "extern int errno in perl.h". Creating such
73 a test requires taking into account the differences between
74 compiling multithreaded and singlethreaded ($ccflags et al).
75 HOST_NOT_FOUND is typically defined in <netdb.h>.
77 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
86 struct passwd *getpwnam (char *);
87 struct passwd *getpwuid (Uid_t);
92 struct passwd *getpwent (void);
93 #elif defined (VMS) && defined (my_getpwent)
94 struct passwd *Perl_my_getpwent (pTHX);
103 struct group *getgrnam (char *);
104 struct group *getgrgid (Gid_t);
108 struct group *getgrent (void);
114 # if defined(_MSC_VER) || defined(__MINGW32__)
115 # include <sys/utime.h>
122 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
125 # define my_chsize PerlLIO_chsize
128 # define my_chsize PerlLIO_chsize
130 I32 my_chsize(int fd, Off_t length);
136 #else /* no flock() */
138 /* fcntl.h might not have been included, even if it exists, because
139 the current Configure only sets I_FCNTL if it's needed to pick up
140 the *_OK constants. Make sure it has been included before testing
141 the fcntl() locking constants. */
142 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
146 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
147 # define FLOCK fcntl_emulate_flock
148 # define FCNTL_EMULATE_FLOCK
149 # else /* no flock() or fcntl(F_SETLK,...) */
151 # define FLOCK lockf_emulate_flock
152 # define LOCKF_EMULATE_FLOCK
154 # endif /* no flock() or fcntl(F_SETLK,...) */
157 static int FLOCK (int, int);
160 * These are the flock() constants. Since this sytems doesn't have
161 * flock(), the values of the constants are probably not available.
175 # endif /* emulating flock() */
177 #endif /* no flock() */
180 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
182 #if defined(I_SYS_ACCESS) && !defined(R_OK)
183 # include <sys/access.h>
186 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
187 # define FD_CLOEXEC 1 /* NeXT needs this */
193 /* Missing protos on LynxOS */
194 void sethostent(int);
195 void endhostent(void);
197 void endnetent(void);
198 void setprotoent(int);
199 void endprotoent(void);
200 void setservent(int);
201 void endservent(void);
204 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
206 /* F_OK unused: if stat() cannot find it... */
208 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
209 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
210 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
213 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
214 # ifdef I_SYS_SECURITY
215 # include <sys/security.h>
219 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
222 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
226 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
228 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
232 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
233 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
234 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
237 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
239 const Uid_t ruid = getuid();
240 const Uid_t euid = geteuid();
241 const Gid_t rgid = getgid();
242 const Gid_t egid = getegid();
246 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
247 Perl_croak(aTHX_ "switching effective uid is not implemented");
250 if (setreuid(euid, ruid))
253 if (setresuid(euid, ruid, (Uid_t)-1))
256 Perl_croak(aTHX_ "entering effective uid failed");
259 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
260 Perl_croak(aTHX_ "switching effective gid is not implemented");
263 if (setregid(egid, rgid))
266 if (setresgid(egid, rgid, (Gid_t)-1))
269 Perl_croak(aTHX_ "entering effective gid failed");
272 res = access(path, mode);
275 if (setreuid(ruid, euid))
278 if (setresuid(ruid, euid, (Uid_t)-1))
281 Perl_croak(aTHX_ "leaving effective uid failed");
284 if (setregid(rgid, egid))
287 if (setresgid(rgid, egid, (Gid_t)-1))
290 Perl_croak(aTHX_ "leaving effective gid failed");
295 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
302 const char * const tmps = POPpconstx;
303 const I32 gimme = GIMME_V;
304 const char *mode = "r";
307 if (PL_op->op_private & OPpOPEN_IN_RAW)
309 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
311 fp = PerlProc_popen(tmps, mode);
313 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
315 PerlIO_apply_layers(aTHX_ fp,mode,type);
317 if (gimme == G_VOID) {
319 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
322 else if (gimme == G_SCALAR) {
325 PL_rs = &PL_sv_undef;
326 sv_setpvs(TARG, ""); /* note that this preserves previous buffer */
327 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
335 SV * const sv = newSV(79);
336 if (sv_gets(sv, fp, 0) == NULL) {
341 if (SvLEN(sv) - SvCUR(sv) > 20) {
342 SvPV_shrink_to_cur(sv);
347 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
348 TAINT; /* "I believe that this is not gratuitous!" */
351 STATUS_NATIVE_CHILD_SET(-1);
352 if (gimme == G_SCALAR)
363 tryAMAGICunTARGET(iter, -1);
365 /* Note that we only ever get here if File::Glob fails to load
366 * without at the same time croaking, for some reason, or if
367 * perl was built with PERL_EXTERNAL_GLOB */
374 * The external globbing program may use things we can't control,
375 * so for security reasons we must assume the worst.
378 taint_proper(PL_no_security, "glob");
382 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
383 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
385 SAVESPTR(PL_rs); /* This is not permanent, either. */
386 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
389 *SvPVX(PL_rs) = '\n';
393 result = do_readline();
401 PL_last_in_gv = cGVOP_gv;
402 return do_readline();
413 do_join(TARG, &PL_sv_no, MARK, SP);
417 else if (SP == MARK) {
425 tmps = SvPV_const(tmpsv, len);
426 if ((!tmps || !len) && PL_errgv) {
427 SV * const error = ERRSV;
428 SvUPGRADE(error, SVt_PV);
429 if (SvPOK(error) && SvCUR(error))
430 sv_catpvs(error, "\t...caught");
432 tmps = SvPV_const(tmpsv, len);
435 tmpsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
437 Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv));
449 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
451 if (SP - MARK != 1) {
453 do_join(TARG, &PL_sv_no, MARK, SP);
455 tmps = SvPV_const(tmpsv, len);
461 tmps = SvROK(tmpsv) ? (const char *)NULL : SvPV_const(tmpsv, len);
464 SV * const error = ERRSV;
465 SvUPGRADE(error, SVt_PV);
466 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
468 SvSetSV(error,tmpsv);
469 else if (sv_isobject(error)) {
470 HV * const stash = SvSTASH(SvRV(error));
471 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
473 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
474 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
481 call_sv(MUTABLE_SV(GvCV(gv)),
482 G_SCALAR|G_EVAL|G_KEEPERR);
483 sv_setsv(error,*PL_stack_sp--);
489 if (SvPOK(error) && SvCUR(error))
490 sv_catpvs(error, "\t...propagated");
493 tmps = SvPV_const(tmpsv, len);
499 tmpsv = newSVpvs_flags("Died", SVs_TEMP);
501 DIE(aTHX_ "%"SVf, SVfARG(tmpsv));
517 GV * const gv = MUTABLE_GV(*++MARK);
520 DIE(aTHX_ PL_no_usym, "filehandle");
522 if ((io = GvIOp(gv))) {
524 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
526 if (IoDIRP(io) && ckWARN2(WARN_IO, WARN_DEPRECATED))
527 Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
528 "Opening dirhandle %s also as a file", GvENAME(gv));
530 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
532 /* Method's args are same as ours ... */
533 /* ... except handle is replaced by the object */
534 *MARK-- = SvTIED_obj(MUTABLE_SV(io), mg);
538 call_method("OPEN", G_SCALAR);
552 tmps = SvPV_const(sv, len);
553 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
556 PUSHi( (I32)PL_forkprocess );
557 else if (PL_forkprocess == 0) /* we are a new child */
567 GV * const gv = (MAXARG == 0) ? PL_defoutgv : MUTABLE_GV(POPs);
570 IO * const io = GvIO(gv);
572 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
575 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
578 call_method("CLOSE", G_SCALAR);
586 PUSHs(boolSV(do_close(gv, TRUE)));
599 GV * const wgv = MUTABLE_GV(POPs);
600 GV * const rgv = MUTABLE_GV(POPs);
605 if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
606 DIE(aTHX_ PL_no_usym, "filehandle");
611 do_close(rgv, FALSE);
613 do_close(wgv, FALSE);
615 if (PerlProc_pipe(fd) < 0)
618 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
619 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
620 IoOFP(rstio) = IoIFP(rstio);
621 IoIFP(wstio) = IoOFP(wstio);
622 IoTYPE(rstio) = IoTYPE_RDONLY;
623 IoTYPE(wstio) = IoTYPE_WRONLY;
625 if (!IoIFP(rstio) || !IoOFP(wstio)) {
627 PerlIO_close(IoIFP(rstio));
629 PerlLIO_close(fd[0]);
631 PerlIO_close(IoOFP(wstio));
633 PerlLIO_close(fd[1]);
636 #if defined(HAS_FCNTL) && defined(F_SETFD)
637 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
638 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
645 DIE(aTHX_ PL_no_func, "pipe");
659 gv = MUTABLE_GV(POPs);
661 if (gv && (io = GvIO(gv))
662 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
665 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
668 call_method("FILENO", G_SCALAR);
674 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
675 /* Can't do this because people seem to do things like
676 defined(fileno($foo)) to check whether $foo is a valid fh.
677 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
678 report_evil_fh(gv, io, PL_op->op_type);
683 PUSHi(PerlIO_fileno(fp));
696 anum = PerlLIO_umask(022);
697 /* setting it to 022 between the two calls to umask avoids
698 * to have a window where the umask is set to 0 -- meaning
699 * that another thread could create world-writeable files. */
701 (void)PerlLIO_umask(anum);
704 anum = PerlLIO_umask(POPi);
705 TAINT_PROPER("umask");
708 /* Only DIE if trying to restrict permissions on "user" (self).
709 * Otherwise it's harmless and more useful to just return undef
710 * since 'group' and 'other' concepts probably don't exist here. */
711 if (MAXARG >= 1 && (POPi & 0700))
712 DIE(aTHX_ "umask not implemented");
713 XPUSHs(&PL_sv_undef);
732 gv = MUTABLE_GV(POPs);
734 if (gv && (io = GvIO(gv))) {
735 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
738 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
743 call_method("BINMODE", G_SCALAR);
751 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
752 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
753 report_evil_fh(gv, io, PL_op->op_type);
754 SETERRNO(EBADF,RMS_IFI);
761 const char *d = NULL;
764 d = SvPV_const(discp, len);
765 mode = mode_from_discipline(d, len);
766 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
767 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
768 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
789 const I32 markoff = MARK - PL_stack_base;
790 const char *methname;
791 int how = PERL_MAGIC_tied;
795 switch(SvTYPE(varsv)) {
797 methname = "TIEHASH";
798 HvEITER_set(MUTABLE_HV(varsv), 0);
801 methname = "TIEARRAY";
804 if (isGV_with_GP(varsv)) {
805 #ifdef GV_UNIQUE_CHECK
806 if (GvUNIQUE((const GV *)varsv)) {
807 Perl_croak(aTHX_ "Attempt to tie unique GV");
810 methname = "TIEHANDLE";
811 how = PERL_MAGIC_tiedscalar;
812 /* For tied filehandles, we apply tiedscalar magic to the IO
813 slot of the GP rather than the GV itself. AMS 20010812 */
815 GvIOp(varsv) = newIO();
816 varsv = MUTABLE_SV(GvIOp(varsv));
821 methname = "TIESCALAR";
822 how = PERL_MAGIC_tiedscalar;
826 if (sv_isobject(*MARK)) { /* Calls GET magic. */
828 PUSHSTACKi(PERLSI_MAGIC);
830 EXTEND(SP,(I32)items);
834 call_method(methname, G_SCALAR);
837 /* Not clear why we don't call call_method here too.
838 * perhaps to get different error message ?
841 const char *name = SvPV_nomg_const(*MARK, len);
842 stash = gv_stashpvn(name, len, 0);
843 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
844 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
845 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
848 PUSHSTACKi(PERLSI_MAGIC);
850 EXTEND(SP,(I32)items);
854 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
860 if (sv_isobject(sv)) {
861 sv_unmagic(varsv, how);
862 /* Croak if a self-tie on an aggregate is attempted. */
863 if (varsv == SvRV(sv) &&
864 (SvTYPE(varsv) == SVt_PVAV ||
865 SvTYPE(varsv) == SVt_PVHV))
867 "Self-ties of arrays and hashes are not supported");
868 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
871 SP = PL_stack_base + markoff;
881 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
882 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
884 if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
887 if ((mg = SvTIED_mg(sv, how))) {
888 SV * const obj = SvRV(SvTIED_obj(sv, mg));
890 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
892 if (gv && isGV(gv) && (cv = GvCV(gv))) {
894 XPUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
895 mXPUSHi(SvREFCNT(obj) - 1);
898 call_sv(MUTABLE_SV(cv), G_VOID);
902 else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
903 Perl_warner(aTHX_ packWARN(WARN_UNTIE),
904 "untie attempted while %"UVuf" inner references still exist",
905 (UV)SvREFCNT(obj) - 1 ) ;
909 sv_unmagic(sv, how) ;
919 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
920 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
922 if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
925 if ((mg = SvTIED_mg(sv, how))) {
926 SV *osv = SvTIED_obj(sv, mg);
927 if (osv == mg->mg_obj)
928 osv = sv_mortalcopy(osv);
942 HV * const hv = MUTABLE_HV(POPs);
943 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
944 stash = gv_stashsv(sv, 0);
945 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
947 require_pv("AnyDBM_File.pm");
949 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
950 DIE(aTHX_ "No dbm on this machine");
960 mPUSHu(O_RDWR|O_CREAT);
965 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
968 if (!sv_isobject(TOPs)) {
976 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
980 if (sv_isobject(TOPs)) {
981 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
982 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
999 struct timeval timebuf;
1000 struct timeval *tbuf = &timebuf;
1003 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1008 # if BYTEORDER & 0xf0000
1009 # define ORDERBYTE (0x88888888 - BYTEORDER)
1011 # define ORDERBYTE (0x4444 - BYTEORDER)
1017 for (i = 1; i <= 3; i++) {
1018 SV * const sv = SP[i];
1021 if (SvREADONLY(sv)) {
1023 sv_force_normal_flags(sv, 0);
1024 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1025 DIE(aTHX_ "%s", PL_no_modify);
1028 if (ckWARN(WARN_MISC))
1029 Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1030 SvPV_force_nolen(sv); /* force string conversion */
1037 /* little endians can use vecs directly */
1038 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1045 masksize = NFDBITS / NBBY;
1047 masksize = sizeof(long); /* documented int, everyone seems to use long */
1049 Zero(&fd_sets[0], 4, char*);
1052 # if SELECT_MIN_BITS == 1
1053 growsize = sizeof(fd_set);
1055 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1056 # undef SELECT_MIN_BITS
1057 # define SELECT_MIN_BITS __FD_SETSIZE
1059 /* If SELECT_MIN_BITS is greater than one we most probably will want
1060 * to align the sizes with SELECT_MIN_BITS/8 because for example
1061 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1062 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1063 * on (sets/tests/clears bits) is 32 bits. */
1064 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1072 timebuf.tv_sec = (long)value;
1073 value -= (NV)timebuf.tv_sec;
1074 timebuf.tv_usec = (long)(value * 1000000.0);
1079 for (i = 1; i <= 3; i++) {
1081 if (!SvOK(sv) || SvCUR(sv) == 0) {
1088 Sv_Grow(sv, growsize);
1092 while (++j <= growsize) {
1096 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1098 Newx(fd_sets[i], growsize, char);
1099 for (offset = 0; offset < growsize; offset += masksize) {
1100 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1101 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1104 fd_sets[i] = SvPVX(sv);
1108 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1109 /* Can't make just the (void*) conditional because that would be
1110 * cpp #if within cpp macro, and not all compilers like that. */
1111 nfound = PerlSock_select(
1113 (Select_fd_set_t) fd_sets[1],
1114 (Select_fd_set_t) fd_sets[2],
1115 (Select_fd_set_t) fd_sets[3],
1116 (void*) tbuf); /* Workaround for compiler bug. */
1118 nfound = PerlSock_select(
1120 (Select_fd_set_t) fd_sets[1],
1121 (Select_fd_set_t) fd_sets[2],
1122 (Select_fd_set_t) fd_sets[3],
1125 for (i = 1; i <= 3; i++) {
1128 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1130 for (offset = 0; offset < growsize; offset += masksize) {
1131 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1132 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1134 Safefree(fd_sets[i]);
1141 if (GIMME == G_ARRAY && tbuf) {
1142 value = (NV)(timebuf.tv_sec) +
1143 (NV)(timebuf.tv_usec) / 1000000.0;
1148 DIE(aTHX_ "select not implemented");
1153 =for apidoc setdefout
1155 Sets PL_defoutgv, the default file handle for output, to the passed in
1156 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1157 count of the passed in typeglob is increased by one, and the reference count
1158 of the typeglob that PL_defoutgv points to is decreased by one.
1164 Perl_setdefout(pTHX_ GV *gv)
1167 SvREFCNT_inc_simple_void(gv);
1169 SvREFCNT_dec(PL_defoutgv);
1177 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1178 GV * egv = GvEGV(PL_defoutgv);
1184 XPUSHs(&PL_sv_undef);
1186 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1187 if (gvp && *gvp == egv) {
1188 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1192 mXPUSHs(newRV(MUTABLE_SV(egv)));
1197 if (!GvIO(newdefout))
1198 gv_IOadd(newdefout);
1199 setdefout(newdefout);
1209 GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs);
1211 if (gv && (io = GvIO(gv))) {
1212 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1214 const I32 gimme = GIMME_V;
1216 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1219 call_method("GETC", gimme);
1222 if (gimme == G_SCALAR)
1223 SvSetMagicSV_nosteal(TARG, TOPs);
1227 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1228 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1229 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1230 report_evil_fh(gv, io, PL_op->op_type);
1231 SETERRNO(EBADF,RMS_IFI);
1235 sv_setpvs(TARG, " ");
1236 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1237 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1238 /* Find out how many bytes the char needs */
1239 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1242 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1243 SvCUR_set(TARG,1+len);
1252 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1255 register PERL_CONTEXT *cx;
1256 const I32 gimme = GIMME_V;
1258 PERL_ARGS_ASSERT_DOFORM;
1263 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1264 PUSHFORMAT(cx, retop);
1266 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1268 setdefout(gv); /* locally select filehandle so $% et al work */
1285 gv = MUTABLE_GV(POPs);
1300 goto not_a_format_reference;
1305 tmpsv = sv_newmortal();
1306 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1307 name = SvPV_nolen_const(tmpsv);
1309 DIE(aTHX_ "Undefined format \"%s\" called", name);
1311 not_a_format_reference:
1312 DIE(aTHX_ "Not a format reference");
1315 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1317 IoFLAGS(io) &= ~IOf_DIDTOP;
1318 return doform(cv,gv,PL_op->op_next);
1324 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1325 register IO * const io = GvIOp(gv);
1330 register PERL_CONTEXT *cx;
1332 if (!io || !(ofp = IoOFP(io)))
1335 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1336 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1338 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1339 PL_formtarget != PL_toptarget)
1343 if (!IoTOP_GV(io)) {
1346 if (!IoTOP_NAME(io)) {
1348 if (!IoFMT_NAME(io))
1349 IoFMT_NAME(io) = savepv(GvNAME(gv));
1350 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1351 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1352 if ((topgv && GvFORM(topgv)) ||
1353 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1354 IoTOP_NAME(io) = savesvpv(topname);
1356 IoTOP_NAME(io) = savepvs("top");
1358 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1359 if (!topgv || !GvFORM(topgv)) {
1360 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1363 IoTOP_GV(io) = topgv;
1365 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1366 I32 lines = IoLINES_LEFT(io);
1367 const char *s = SvPVX_const(PL_formtarget);
1368 if (lines <= 0) /* Yow, header didn't even fit!!! */
1370 while (lines-- > 0) {
1371 s = strchr(s, '\n');
1377 const STRLEN save = SvCUR(PL_formtarget);
1378 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1379 do_print(PL_formtarget, ofp);
1380 SvCUR_set(PL_formtarget, save);
1381 sv_chop(PL_formtarget, s);
1382 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1385 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1386 do_print(PL_formfeed, ofp);
1387 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1389 PL_formtarget = PL_toptarget;
1390 IoFLAGS(io) |= IOf_DIDTOP;
1393 DIE(aTHX_ "bad top format reference");
1396 SV * const sv = sv_newmortal();
1398 gv_efullname4(sv, fgv, NULL, FALSE);
1399 name = SvPV_nolen_const(sv);
1401 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1403 DIE(aTHX_ "Undefined top format called");
1405 if (cv && CvCLONE(cv))
1406 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1407 return doform(cv, gv, PL_op);
1411 POPBLOCK(cx,PL_curpm);
1417 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1419 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1420 else if (ckWARN(WARN_CLOSED))
1421 report_evil_fh(gv, io, PL_op->op_type);
1426 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1427 if (ckWARN(WARN_IO))
1428 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1430 if (!do_print(PL_formtarget, fp))
1433 FmLINES(PL_formtarget) = 0;
1434 SvCUR_set(PL_formtarget, 0);
1435 *SvEND(PL_formtarget) = '\0';
1436 if (IoFLAGS(io) & IOf_FLUSH)
1437 (void)PerlIO_flush(fp);
1442 PL_formtarget = PL_bodytarget;
1444 PERL_UNUSED_VAR(newsp);
1445 PERL_UNUSED_VAR(gimme);
1446 return cx->blk_sub.retop;
1451 dVAR; dSP; dMARK; dORIGMARK;
1457 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1459 if (gv && (io = GvIO(gv))) {
1460 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1462 if (MARK == ORIGMARK) {
1465 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1469 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1472 call_method("PRINTF", G_SCALAR);
1475 MARK = ORIGMARK + 1;
1483 if (!(io = GvIO(gv))) {
1484 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1485 report_evil_fh(gv, io, PL_op->op_type);
1486 SETERRNO(EBADF,RMS_IFI);
1489 else if (!(fp = IoOFP(io))) {
1490 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1492 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1493 else if (ckWARN(WARN_CLOSED))
1494 report_evil_fh(gv, io, PL_op->op_type);
1496 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1500 if (SvTAINTED(MARK[1]))
1501 TAINT_PROPER("printf");
1502 do_sprintf(sv, SP - MARK, MARK + 1);
1503 if (!do_print(sv, fp))
1506 if (IoFLAGS(io) & IOf_FLUSH)
1507 if (PerlIO_flush(fp) == EOF)
1518 PUSHs(&PL_sv_undef);
1526 const int perm = (MAXARG > 3) ? POPi : 0666;
1527 const int mode = POPi;
1528 SV * const sv = POPs;
1529 GV * const gv = MUTABLE_GV(POPs);
1532 /* Need TIEHANDLE method ? */
1533 const char * const tmps = SvPV_const(sv, len);
1534 /* FIXME? do_open should do const */
1535 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1536 IoLINES(GvIOp(gv)) = 0;
1540 PUSHs(&PL_sv_undef);
1547 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1553 Sock_size_t bufsize;
1561 bool charstart = FALSE;
1562 STRLEN charskip = 0;
1565 GV * const gv = MUTABLE_GV(*++MARK);
1566 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1567 && gv && (io = GvIO(gv)) )
1569 const MAGIC * mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1573 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1575 call_method("READ", G_SCALAR);
1589 sv_setpvs(bufsv, "");
1590 length = SvIVx(*++MARK);
1593 offset = SvIVx(*++MARK);
1597 if (!io || !IoIFP(io)) {
1598 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1599 report_evil_fh(gv, io, PL_op->op_type);
1600 SETERRNO(EBADF,RMS_IFI);
1603 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1604 buffer = SvPVutf8_force(bufsv, blen);
1605 /* UTF-8 may not have been set if they are all low bytes */
1610 buffer = SvPV_force(bufsv, blen);
1611 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1614 DIE(aTHX_ "Negative length");
1622 if (PL_op->op_type == OP_RECV) {
1623 char namebuf[MAXPATHLEN];
1624 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1625 bufsize = sizeof (struct sockaddr_in);
1627 bufsize = sizeof namebuf;
1629 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1633 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1634 /* 'offset' means 'flags' here */
1635 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1636 (struct sockaddr *)namebuf, &bufsize);
1640 /* Bogus return without padding */
1641 bufsize = sizeof (struct sockaddr_in);
1643 SvCUR_set(bufsv, count);
1644 *SvEND(bufsv) = '\0';
1645 (void)SvPOK_only(bufsv);
1649 /* This should not be marked tainted if the fp is marked clean */
1650 if (!(IoFLAGS(io) & IOf_UNTAINT))
1651 SvTAINTED_on(bufsv);
1653 sv_setpvn(TARG, namebuf, bufsize);
1658 if (PL_op->op_type == OP_RECV)
1659 DIE(aTHX_ PL_no_sock_func, "recv");
1661 if (DO_UTF8(bufsv)) {
1662 /* offset adjust in characters not bytes */
1663 blen = sv_len_utf8(bufsv);
1666 if (-offset > (int)blen)
1667 DIE(aTHX_ "Offset outside string");
1670 if (DO_UTF8(bufsv)) {
1671 /* convert offset-as-chars to offset-as-bytes */
1672 if (offset >= (int)blen)
1673 offset += SvCUR(bufsv) - blen;
1675 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1678 bufsize = SvCUR(bufsv);
1679 /* Allocating length + offset + 1 isn't perfect in the case of reading
1680 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1682 (should be 2 * length + offset + 1, or possibly something longer if
1683 PL_encoding is true) */
1684 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1685 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1686 Zero(buffer+bufsize, offset-bufsize, char);
1688 buffer = buffer + offset;
1690 read_target = bufsv;
1692 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1693 concatenate it to the current buffer. */
1695 /* Truncate the existing buffer to the start of where we will be
1697 SvCUR_set(bufsv, offset);
1699 read_target = sv_newmortal();
1700 SvUPGRADE(read_target, SVt_PV);
1701 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1704 if (PL_op->op_type == OP_SYSREAD) {
1705 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1706 if (IoTYPE(io) == IoTYPE_SOCKET) {
1707 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1713 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1718 #ifdef HAS_SOCKET__bad_code_maybe
1719 if (IoTYPE(io) == IoTYPE_SOCKET) {
1720 char namebuf[MAXPATHLEN];
1721 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1722 bufsize = sizeof (struct sockaddr_in);
1724 bufsize = sizeof namebuf;
1726 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1727 (struct sockaddr *)namebuf, &bufsize);
1732 count = PerlIO_read(IoIFP(io), buffer, length);
1733 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1734 if (count == 0 && PerlIO_error(IoIFP(io)))
1738 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1739 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1742 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1743 *SvEND(read_target) = '\0';
1744 (void)SvPOK_only(read_target);
1745 if (fp_utf8 && !IN_BYTES) {
1746 /* Look at utf8 we got back and count the characters */
1747 const char *bend = buffer + count;
1748 while (buffer < bend) {
1750 skip = UTF8SKIP(buffer);
1753 if (buffer - charskip + skip > bend) {
1754 /* partial character - try for rest of it */
1755 length = skip - (bend-buffer);
1756 offset = bend - SvPVX_const(bufsv);
1768 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1769 provided amount read (count) was what was requested (length)
1771 if (got < wanted && count == length) {
1772 length = wanted - got;
1773 offset = bend - SvPVX_const(bufsv);
1776 /* return value is character count */
1780 else if (buffer_utf8) {
1781 /* Let svcatsv upgrade the bytes we read in to utf8.
1782 The buffer is a mortal so will be freed soon. */
1783 sv_catsv_nomg(bufsv, read_target);
1786 /* This should not be marked tainted if the fp is marked clean */
1787 if (!(IoFLAGS(io) & IOf_UNTAINT))
1788 SvTAINTED_on(bufsv);
1800 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1806 STRLEN orig_blen_bytes;
1807 const int op_type = PL_op->op_type;
1811 GV *const gv = MUTABLE_GV(*++MARK);
1812 if (PL_op->op_type == OP_SYSWRITE
1813 && gv && (io = GvIO(gv))) {
1814 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1818 if (MARK == SP - 1) {
1820 sv = sv_2mortal(newSViv(sv_len(*SP)));
1826 *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg);
1828 call_method("WRITE", G_SCALAR);
1844 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1846 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1847 if (io && IoIFP(io))
1848 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1850 report_evil_fh(gv, io, PL_op->op_type);
1852 SETERRNO(EBADF,RMS_IFI);
1856 /* Do this first to trigger any overloading. */
1857 buffer = SvPV_const(bufsv, blen);
1858 orig_blen_bytes = blen;
1859 doing_utf8 = DO_UTF8(bufsv);
1861 if (PerlIO_isutf8(IoIFP(io))) {
1862 if (!SvUTF8(bufsv)) {
1863 /* We don't modify the original scalar. */
1864 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1865 buffer = (char *) tmpbuf;
1869 else if (doing_utf8) {
1870 STRLEN tmplen = blen;
1871 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1874 buffer = (char *) tmpbuf;
1878 assert((char *)result == buffer);
1879 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1883 if (op_type == OP_SYSWRITE) {
1884 Size_t length = 0; /* This length is in characters. */
1890 /* The SV is bytes, and we've had to upgrade it. */
1891 blen_chars = orig_blen_bytes;
1893 /* The SV really is UTF-8. */
1894 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1895 /* Don't call sv_len_utf8 again because it will call magic
1896 or overloading a second time, and we might get back a
1897 different result. */
1898 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1900 /* It's safe, and it may well be cached. */
1901 blen_chars = sv_len_utf8(bufsv);
1909 length = blen_chars;
1911 #if Size_t_size > IVSIZE
1912 length = (Size_t)SvNVx(*++MARK);
1914 length = (Size_t)SvIVx(*++MARK);
1916 if ((SSize_t)length < 0) {
1918 DIE(aTHX_ "Negative length");
1923 offset = SvIVx(*++MARK);
1925 if (-offset > (IV)blen_chars) {
1927 DIE(aTHX_ "Offset outside string");
1929 offset += blen_chars;
1930 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1932 DIE(aTHX_ "Offset outside string");
1936 if (length > blen_chars - offset)
1937 length = blen_chars - offset;
1939 /* Here we convert length from characters to bytes. */
1940 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1941 /* Either we had to convert the SV, or the SV is magical, or
1942 the SV has overloading, in which case we can't or mustn't
1943 or mustn't call it again. */
1945 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1946 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1948 /* It's a real UTF-8 SV, and it's not going to change under
1949 us. Take advantage of any cache. */
1951 I32 len_I32 = length;
1953 /* Convert the start and end character positions to bytes.
1954 Remember that the second argument to sv_pos_u2b is relative
1956 sv_pos_u2b(bufsv, &start, &len_I32);
1963 buffer = buffer+offset;
1965 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1966 if (IoTYPE(io) == IoTYPE_SOCKET) {
1967 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1973 /* See the note at doio.c:do_print about filesize limits. --jhi */
1974 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1980 const int flags = SvIVx(*++MARK);
1983 char * const sockbuf = SvPVx(*++MARK, mlen);
1984 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1985 flags, (struct sockaddr *)sockbuf, mlen);
1989 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1994 DIE(aTHX_ PL_no_sock_func, "send");
2001 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2004 #if Size_t_size > IVSIZE
2025 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2026 else if (PL_op->op_flags & OPf_SPECIAL)
2027 gv = PL_last_in_gv = GvEGV(PL_argvgv); /* eof() - ARGV magic */
2029 gv = PL_last_in_gv; /* eof */
2034 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2036 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2038 * in Perl 5.12 and later, the additional paramter is a bitmask:
2041 * 2 = eof() <- ARGV magic
2044 mPUSHi(1); /* 1 = eof(FH) - simple, explicit FH */
2045 else if (PL_op->op_flags & OPf_SPECIAL)
2046 mPUSHi(2); /* 2 = eof() - ARGV magic */
2048 mPUSHi(0); /* 0 = eof - simple, implicit FH */
2051 call_method("EOF", G_SCALAR);
2057 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2058 if (io && !IoIFP(io)) {
2059 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2061 IoFLAGS(io) &= ~IOf_START;
2062 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2064 sv_setpvs(GvSV(gv), "-");
2066 GvSV(gv) = newSVpvs("-");
2067 SvSETMAGIC(GvSV(gv));
2069 else if (!nextargv(gv))
2074 PUSHs(boolSV(do_eof(gv)));
2085 PL_last_in_gv = MUTABLE_GV(POPs);
2088 if (gv && (io = GvIO(gv))) {
2089 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2092 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2095 call_method("TELL", G_SCALAR);
2102 #if LSEEKSIZE > IVSIZE
2103 PUSHn( do_tell(gv) );
2105 PUSHi( do_tell(gv) );
2113 const int whence = POPi;
2114 #if LSEEKSIZE > IVSIZE
2115 const Off_t offset = (Off_t)SvNVx(POPs);
2117 const Off_t offset = (Off_t)SvIVx(POPs);
2120 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2123 if (gv && (io = GvIO(gv))) {
2124 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2127 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2128 #if LSEEKSIZE > IVSIZE
2129 mXPUSHn((NV) offset);
2136 call_method("SEEK", G_SCALAR);
2143 if (PL_op->op_type == OP_SEEK)
2144 PUSHs(boolSV(do_seek(gv, offset, whence)));
2146 const Off_t sought = do_sysseek(gv, offset, whence);
2148 PUSHs(&PL_sv_undef);
2150 SV* const sv = sought ?
2151 #if LSEEKSIZE > IVSIZE
2156 : newSVpvn(zero_but_true, ZBTLEN);
2167 /* There seems to be no consensus on the length type of truncate()
2168 * and ftruncate(), both off_t and size_t have supporters. In
2169 * general one would think that when using large files, off_t is
2170 * at least as wide as size_t, so using an off_t should be okay. */
2171 /* XXX Configure probe for the length type of *truncate() needed XXX */
2174 #if Off_t_size > IVSIZE
2179 /* Checking for length < 0 is problematic as the type might or
2180 * might not be signed: if it is not, clever compilers will moan. */
2181 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2188 if (PL_op->op_flags & OPf_SPECIAL) {
2189 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2198 TAINT_PROPER("truncate");
2199 if (!(fp = IoIFP(io))) {
2205 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2207 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2214 SV * const sv = POPs;
2217 if (isGV_with_GP(sv)) {
2218 tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */
2219 goto do_ftruncate_gv;
2221 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2222 tmpgv = MUTABLE_GV(SvRV(sv)); /* \*main::FRED for example */
2223 goto do_ftruncate_gv;
2225 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2226 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2227 goto do_ftruncate_io;
2230 name = SvPV_nolen_const(sv);
2231 TAINT_PROPER("truncate");
2233 if (truncate(name, len) < 0)
2237 const int tmpfd = PerlLIO_open(name, O_RDWR);
2242 if (my_chsize(tmpfd, len) < 0)
2244 PerlLIO_close(tmpfd);
2253 SETERRNO(EBADF,RMS_IFI);
2261 SV * const argsv = POPs;
2262 const unsigned int func = POPu;
2263 const int optype = PL_op->op_type;
2264 GV * const gv = MUTABLE_GV(POPs);
2265 IO * const io = gv ? GvIOn(gv) : NULL;
2269 if (!io || !argsv || !IoIFP(io)) {
2270 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2271 report_evil_fh(gv, io, PL_op->op_type);
2272 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2276 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2279 s = SvPV_force(argsv, len);
2280 need = IOCPARM_LEN(func);
2282 s = Sv_Grow(argsv, need + 1);
2283 SvCUR_set(argsv, need);
2286 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2289 retval = SvIV(argsv);
2290 s = INT2PTR(char*,retval); /* ouch */
2293 TAINT_PROPER(PL_op_desc[optype]);
2295 if (optype == OP_IOCTL)
2297 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2299 DIE(aTHX_ "ioctl is not implemented");
2303 DIE(aTHX_ "fcntl is not implemented");
2305 #if defined(OS2) && defined(__EMX__)
2306 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2308 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2312 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2314 if (s[SvCUR(argsv)] != 17)
2315 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2317 s[SvCUR(argsv)] = 0; /* put our null back */
2318 SvSETMAGIC(argsv); /* Assume it has changed */
2327 PUSHp(zero_but_true, ZBTLEN);
2340 const int argtype = POPi;
2341 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
2343 if (gv && (io = GvIO(gv)))
2349 /* XXX Looks to me like io is always NULL at this point */
2351 (void)PerlIO_flush(fp);
2352 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2355 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2356 report_evil_fh(gv, io, PL_op->op_type);
2358 SETERRNO(EBADF,RMS_IFI);
2363 DIE(aTHX_ PL_no_func, "flock()");
2373 const int protocol = POPi;
2374 const int type = POPi;
2375 const int domain = POPi;
2376 GV * const gv = MUTABLE_GV(POPs);
2377 register IO * const io = gv ? GvIOn(gv) : NULL;
2381 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2382 report_evil_fh(gv, io, PL_op->op_type);
2383 if (io && IoIFP(io))
2384 do_close(gv, FALSE);
2385 SETERRNO(EBADF,LIB_INVARG);
2390 do_close(gv, FALSE);
2392 TAINT_PROPER("socket");
2393 fd = PerlSock_socket(domain, type, protocol);
2396 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2397 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2398 IoTYPE(io) = IoTYPE_SOCKET;
2399 if (!IoIFP(io) || !IoOFP(io)) {
2400 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2401 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2402 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2405 #if defined(HAS_FCNTL) && defined(F_SETFD)
2406 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2410 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2415 DIE(aTHX_ PL_no_sock_func, "socket");
2421 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2423 const int protocol = POPi;
2424 const int type = POPi;
2425 const int domain = POPi;
2426 GV * const gv2 = MUTABLE_GV(POPs);
2427 GV * const gv1 = MUTABLE_GV(POPs);
2428 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2429 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2432 if (!gv1 || !gv2 || !io1 || !io2) {
2433 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2435 report_evil_fh(gv1, io1, PL_op->op_type);
2437 report_evil_fh(gv1, io2, PL_op->op_type);
2439 if (io1 && IoIFP(io1))
2440 do_close(gv1, FALSE);
2441 if (io2 && IoIFP(io2))
2442 do_close(gv2, FALSE);
2447 do_close(gv1, FALSE);
2449 do_close(gv2, FALSE);
2451 TAINT_PROPER("socketpair");
2452 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2454 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2455 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2456 IoTYPE(io1) = IoTYPE_SOCKET;
2457 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2458 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2459 IoTYPE(io2) = IoTYPE_SOCKET;
2460 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2461 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2462 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2463 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2464 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2465 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2466 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2469 #if defined(HAS_FCNTL) && defined(F_SETFD)
2470 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2471 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2476 DIE(aTHX_ PL_no_sock_func, "socketpair");
2484 SV * const addrsv = POPs;
2485 /* OK, so on what platform does bind modify addr? */
2487 GV * const gv = MUTABLE_GV(POPs);
2488 register IO * const io = GvIOn(gv);
2491 if (!io || !IoIFP(io))
2494 addr = SvPV_const(addrsv, len);
2495 TAINT_PROPER("bind");
2496 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2502 if (ckWARN(WARN_CLOSED))
2503 report_evil_fh(gv, io, PL_op->op_type);
2504 SETERRNO(EBADF,SS_IVCHAN);
2507 DIE(aTHX_ PL_no_sock_func, "bind");
2515 SV * const addrsv = POPs;
2516 GV * const gv = MUTABLE_GV(POPs);
2517 register IO * const io = GvIOn(gv);
2521 if (!io || !IoIFP(io))
2524 addr = SvPV_const(addrsv, len);
2525 TAINT_PROPER("connect");
2526 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2532 if (ckWARN(WARN_CLOSED))
2533 report_evil_fh(gv, io, PL_op->op_type);
2534 SETERRNO(EBADF,SS_IVCHAN);
2537 DIE(aTHX_ PL_no_sock_func, "connect");
2545 const int backlog = POPi;
2546 GV * const gv = MUTABLE_GV(POPs);
2547 register IO * const io = gv ? GvIOn(gv) : NULL;
2549 if (!gv || !io || !IoIFP(io))
2552 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2558 if (ckWARN(WARN_CLOSED))
2559 report_evil_fh(gv, io, PL_op->op_type);
2560 SETERRNO(EBADF,SS_IVCHAN);
2563 DIE(aTHX_ PL_no_sock_func, "listen");
2573 char namebuf[MAXPATHLEN];
2574 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2575 Sock_size_t len = sizeof (struct sockaddr_in);
2577 Sock_size_t len = sizeof namebuf;
2579 GV * const ggv = MUTABLE_GV(POPs);
2580 GV * const ngv = MUTABLE_GV(POPs);
2589 if (!gstio || !IoIFP(gstio))
2593 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2596 /* Some platforms indicate zero length when an AF_UNIX client is
2597 * not bound. Simulate a non-zero-length sockaddr structure in
2599 namebuf[0] = 0; /* sun_len */
2600 namebuf[1] = AF_UNIX; /* sun_family */
2608 do_close(ngv, FALSE);
2609 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2610 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2611 IoTYPE(nstio) = IoTYPE_SOCKET;
2612 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2613 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2614 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2615 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2618 #if defined(HAS_FCNTL) && defined(F_SETFD)
2619 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2623 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2624 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2626 #ifdef __SCO_VERSION__
2627 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2630 PUSHp(namebuf, len);
2634 if (ckWARN(WARN_CLOSED))
2635 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2636 SETERRNO(EBADF,SS_IVCHAN);
2642 DIE(aTHX_ PL_no_sock_func, "accept");
2650 const int how = POPi;
2651 GV * const gv = MUTABLE_GV(POPs);
2652 register IO * const io = GvIOn(gv);
2654 if (!io || !IoIFP(io))
2657 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2661 if (ckWARN(WARN_CLOSED))
2662 report_evil_fh(gv, io, PL_op->op_type);
2663 SETERRNO(EBADF,SS_IVCHAN);
2666 DIE(aTHX_ PL_no_sock_func, "shutdown");
2674 const int optype = PL_op->op_type;
2675 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2676 const unsigned int optname = (unsigned int) POPi;
2677 const unsigned int lvl = (unsigned int) POPi;
2678 GV * const gv = MUTABLE_GV(POPs);
2679 register IO * const io = GvIOn(gv);
2683 if (!io || !IoIFP(io))
2686 fd = PerlIO_fileno(IoIFP(io));
2690 (void)SvPOK_only(sv);
2694 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2701 #if defined(__SYMBIAN32__)
2702 # define SETSOCKOPT_OPTION_VALUE_T void *
2704 # define SETSOCKOPT_OPTION_VALUE_T const char *
2706 /* XXX TODO: We need to have a proper type (a Configure probe,
2707 * etc.) for what the C headers think of the third argument of
2708 * setsockopt(), the option_value read-only buffer: is it
2709 * a "char *", or a "void *", const or not. Some compilers
2710 * don't take kindly to e.g. assuming that "char *" implicitly
2711 * promotes to a "void *", or to explicitly promoting/demoting
2712 * consts to non/vice versa. The "const void *" is the SUS
2713 * definition, but that does not fly everywhere for the above
2715 SETSOCKOPT_OPTION_VALUE_T buf;
2719 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2723 aint = (int)SvIV(sv);
2724 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2727 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2736 if (ckWARN(WARN_CLOSED))
2737 report_evil_fh(gv, io, optype);
2738 SETERRNO(EBADF,SS_IVCHAN);
2743 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2751 const int optype = PL_op->op_type;
2752 GV * const gv = MUTABLE_GV(POPs);
2753 register IO * const io = GvIOn(gv);
2758 if (!io || !IoIFP(io))
2761 sv = sv_2mortal(newSV(257));
2762 (void)SvPOK_only(sv);
2766 fd = PerlIO_fileno(IoIFP(io));
2768 case OP_GETSOCKNAME:
2769 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2772 case OP_GETPEERNAME:
2773 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2775 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2777 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";
2778 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2779 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2780 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2781 sizeof(u_short) + sizeof(struct in_addr))) {
2788 #ifdef BOGUS_GETNAME_RETURN
2789 /* Interactive Unix, getpeername() and getsockname()
2790 does not return valid namelen */
2791 if (len == BOGUS_GETNAME_RETURN)
2792 len = sizeof(struct sockaddr);
2800 if (ckWARN(WARN_CLOSED))
2801 report_evil_fh(gv, io, optype);
2802 SETERRNO(EBADF,SS_IVCHAN);
2807 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2822 if (PL_op->op_flags & OPf_REF) {
2824 if (PL_op->op_type == OP_LSTAT) {
2825 if (gv != PL_defgv) {
2826 do_fstat_warning_check:
2827 if (ckWARN(WARN_IO))
2828 Perl_warner(aTHX_ packWARN(WARN_IO),
2829 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2830 } else if (PL_laststype != OP_LSTAT)
2831 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2835 if (gv != PL_defgv) {
2836 PL_laststype = OP_STAT;
2838 sv_setpvs(PL_statname, "");
2845 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2846 } else if (IoDIRP(io)) {
2848 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2850 PL_laststatval = -1;
2856 if (PL_laststatval < 0) {
2857 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2858 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2863 SV* const sv = POPs;
2864 if (isGV_with_GP(sv)) {
2865 gv = MUTABLE_GV(sv);
2867 } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2868 gv = MUTABLE_GV(SvRV(sv));
2869 if (PL_op->op_type == OP_LSTAT)
2870 goto do_fstat_warning_check;
2872 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2873 io = MUTABLE_IO(SvRV(sv));
2874 if (PL_op->op_type == OP_LSTAT)
2875 goto do_fstat_warning_check;
2876 goto do_fstat_have_io;
2879 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2881 PL_laststype = PL_op->op_type;
2882 if (PL_op->op_type == OP_LSTAT)
2883 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2885 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2886 if (PL_laststatval < 0) {
2887 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2888 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2894 if (gimme != G_ARRAY) {
2895 if (gimme != G_VOID)
2896 XPUSHs(boolSV(max));
2902 mPUSHi(PL_statcache.st_dev);
2903 mPUSHi(PL_statcache.st_ino);
2904 mPUSHu(PL_statcache.st_mode);
2905 mPUSHu(PL_statcache.st_nlink);
2906 #if Uid_t_size > IVSIZE
2907 mPUSHn(PL_statcache.st_uid);
2909 # if Uid_t_sign <= 0
2910 mPUSHi(PL_statcache.st_uid);
2912 mPUSHu(PL_statcache.st_uid);
2915 #if Gid_t_size > IVSIZE
2916 mPUSHn(PL_statcache.st_gid);
2918 # if Gid_t_sign <= 0
2919 mPUSHi(PL_statcache.st_gid);
2921 mPUSHu(PL_statcache.st_gid);
2924 #ifdef USE_STAT_RDEV
2925 mPUSHi(PL_statcache.st_rdev);
2927 PUSHs(newSVpvs_flags("", SVs_TEMP));
2929 #if Off_t_size > IVSIZE
2930 mPUSHn(PL_statcache.st_size);
2932 mPUSHi(PL_statcache.st_size);
2935 mPUSHn(PL_statcache.st_atime);
2936 mPUSHn(PL_statcache.st_mtime);
2937 mPUSHn(PL_statcache.st_ctime);
2939 mPUSHi(PL_statcache.st_atime);
2940 mPUSHi(PL_statcache.st_mtime);
2941 mPUSHi(PL_statcache.st_ctime);
2943 #ifdef USE_STAT_BLOCKS
2944 mPUSHu(PL_statcache.st_blksize);
2945 mPUSHu(PL_statcache.st_blocks);
2947 PUSHs(newSVpvs_flags("", SVs_TEMP));
2948 PUSHs(newSVpvs_flags("", SVs_TEMP));
2954 /* This macro is used by the stacked filetest operators :
2955 * if the previous filetest failed, short-circuit and pass its value.
2956 * Else, discard it from the stack and continue. --rgs
2958 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2959 if (!SvTRUE(TOPs)) { RETURN; } \
2960 else { (void)POPs; PUTBACK; } \
2967 /* Not const, because things tweak this below. Not bool, because there's
2968 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2969 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2970 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2971 /* Giving some sort of initial value silences compilers. */
2973 int access_mode = R_OK;
2975 int access_mode = 0;
2978 /* access_mode is never used, but leaving use_access in makes the
2979 conditional compiling below much clearer. */
2982 int stat_mode = S_IRUSR;
2984 bool effective = FALSE;
2987 STACKED_FTEST_CHECK;
2989 switch (PL_op->op_type) {
2991 #if !(defined(HAS_ACCESS) && defined(R_OK))
2997 #if defined(HAS_ACCESS) && defined(W_OK)
3002 stat_mode = S_IWUSR;
3006 #if defined(HAS_ACCESS) && defined(X_OK)
3011 stat_mode = S_IXUSR;
3015 #ifdef PERL_EFF_ACCESS
3018 stat_mode = S_IWUSR;
3022 #ifndef PERL_EFF_ACCESS
3029 #ifdef PERL_EFF_ACCESS
3034 stat_mode = S_IXUSR;
3040 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3041 const char *name = POPpx;
3043 # ifdef PERL_EFF_ACCESS
3044 result = PERL_EFF_ACCESS(name, access_mode);
3046 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3052 result = access(name, access_mode);
3054 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3069 if (cando(stat_mode, effective, &PL_statcache))
3078 const int op_type = PL_op->op_type;
3080 STACKED_FTEST_CHECK;
3085 if (op_type == OP_FTIS)
3088 /* You can't dTARGET inside OP_FTIS, because you'll get
3089 "panic: pad_sv po" - the op is not flagged to have a target. */
3093 #if Off_t_size > IVSIZE
3094 PUSHn(PL_statcache.st_size);
3096 PUSHi(PL_statcache.st_size);
3100 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3103 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3106 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3119 /* I believe that all these three are likely to be defined on most every
3120 system these days. */
3122 if(PL_op->op_type == OP_FTSUID)
3126 if(PL_op->op_type == OP_FTSGID)
3130 if(PL_op->op_type == OP_FTSVTX)
3134 STACKED_FTEST_CHECK;
3139 switch (PL_op->op_type) {
3141 if (PL_statcache.st_uid == PL_uid)
3145 if (PL_statcache.st_uid == PL_euid)
3149 if (PL_statcache.st_size == 0)
3153 if (S_ISSOCK(PL_statcache.st_mode))
3157 if (S_ISCHR(PL_statcache.st_mode))
3161 if (S_ISBLK(PL_statcache.st_mode))
3165 if (S_ISREG(PL_statcache.st_mode))
3169 if (S_ISDIR(PL_statcache.st_mode))
3173 if (S_ISFIFO(PL_statcache.st_mode))
3178 if (PL_statcache.st_mode & S_ISUID)
3184 if (PL_statcache.st_mode & S_ISGID)
3190 if (PL_statcache.st_mode & S_ISVTX)
3201 I32 result = my_lstat();
3205 if (S_ISLNK(PL_statcache.st_mode))
3218 STACKED_FTEST_CHECK;
3220 if (PL_op->op_flags & OPf_REF)
3222 else if (isGV(TOPs))
3223 gv = MUTABLE_GV(POPs);
3224 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3225 gv = MUTABLE_GV(SvRV(POPs));
3227 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3229 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3230 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3231 else if (tmpsv && SvOK(tmpsv)) {
3232 const char *tmps = SvPV_nolen_const(tmpsv);
3240 if (PerlLIO_isatty(fd))
3245 #if defined(atarist) /* this will work with atariST. Configure will
3246 make guesses for other systems. */
3247 # define FILE_base(f) ((f)->_base)
3248 # define FILE_ptr(f) ((f)->_ptr)
3249 # define FILE_cnt(f) ((f)->_cnt)
3250 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3261 register STDCHAR *s;
3267 STACKED_FTEST_CHECK;
3269 if (PL_op->op_flags & OPf_REF)
3271 else if (isGV(TOPs))
3272 gv = MUTABLE_GV(POPs);
3273 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3274 gv = MUTABLE_GV(SvRV(POPs));
3280 if (gv == PL_defgv) {
3282 io = GvIO(PL_statgv);
3285 goto really_filename;
3290 PL_laststatval = -1;
3291 sv_setpvs(PL_statname, "");
3292 io = GvIO(PL_statgv);
3294 if (io && IoIFP(io)) {
3295 if (! PerlIO_has_base(IoIFP(io)))
3296 DIE(aTHX_ "-T and -B not implemented on filehandles");
3297 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3298 if (PL_laststatval < 0)
3300 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3301 if (PL_op->op_type == OP_FTTEXT)
3306 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3307 i = PerlIO_getc(IoIFP(io));
3309 (void)PerlIO_ungetc(IoIFP(io),i);
3311 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3313 len = PerlIO_get_bufsiz(IoIFP(io));
3314 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3315 /* sfio can have large buffers - limit to 512 */
3320 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3322 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3324 SETERRNO(EBADF,RMS_IFI);
3332 PL_laststype = OP_STAT;
3333 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3334 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3335 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3337 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3340 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3341 if (PL_laststatval < 0) {
3342 (void)PerlIO_close(fp);
3345 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3346 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3347 (void)PerlIO_close(fp);
3349 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3350 RETPUSHNO; /* special case NFS directories */
3351 RETPUSHYES; /* null file is anything */
3356 /* now scan s to look for textiness */
3357 /* XXX ASCII dependent code */
3359 #if defined(DOSISH) || defined(USEMYBINMODE)
3360 /* ignore trailing ^Z on short files */
3361 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3365 for (i = 0; i < len; i++, s++) {
3366 if (!*s) { /* null never allowed in text */
3371 else if (!(isPRINT(*s) || isSPACE(*s)))
3374 else if (*s & 128) {
3376 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3379 /* utf8 characters don't count as odd */
3380 if (UTF8_IS_START(*s)) {
3381 int ulen = UTF8SKIP(s);
3382 if (ulen < len - i) {
3384 for (j = 1; j < ulen; j++) {
3385 if (!UTF8_IS_CONTINUATION(s[j]))
3388 --ulen; /* loop does extra increment */
3398 *s != '\n' && *s != '\r' && *s != '\b' &&
3399 *s != '\t' && *s != '\f' && *s != 27)
3404 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3415 const char *tmps = NULL;
3419 SV * const sv = POPs;
3420 if (PL_op->op_flags & OPf_SPECIAL) {
3421 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3423 else if (isGV_with_GP(sv)) {
3424 gv = MUTABLE_GV(sv);
3426 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
3427 gv = MUTABLE_GV(SvRV(sv));
3430 tmps = SvPV_nolen_const(sv);
3434 if( !gv && (!tmps || !*tmps) ) {
3435 HV * const table = GvHVn(PL_envgv);
3438 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3439 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3441 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3446 deprecate("chdir('') or chdir(undef) as chdir()");
3447 tmps = SvPV_nolen_const(*svp);
3451 TAINT_PROPER("chdir");
3456 TAINT_PROPER("chdir");
3459 IO* const io = GvIO(gv);
3462 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3463 } else if (IoIFP(io)) {
3464 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3467 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3468 report_evil_fh(gv, io, PL_op->op_type);
3469 SETERRNO(EBADF, RMS_IFI);
3474 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3475 report_evil_fh(gv, io, PL_op->op_type);
3476 SETERRNO(EBADF,RMS_IFI);
3480 DIE(aTHX_ PL_no_func, "fchdir");
3484 PUSHi( PerlDir_chdir(tmps) >= 0 );
3486 /* Clear the DEFAULT element of ENV so we'll get the new value
3488 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3495 dVAR; dSP; dMARK; dTARGET;
3496 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3507 char * const tmps = POPpx;
3508 TAINT_PROPER("chroot");
3509 PUSHi( chroot(tmps) >= 0 );
3512 DIE(aTHX_ PL_no_func, "chroot");
3520 const char * const tmps2 = POPpconstx;
3521 const char * const tmps = SvPV_nolen_const(TOPs);
3522 TAINT_PROPER("rename");
3524 anum = PerlLIO_rename(tmps, tmps2);
3526 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3527 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3530 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3531 (void)UNLINK(tmps2);
3532 if (!(anum = link(tmps, tmps2)))
3533 anum = UNLINK(tmps);
3541 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3545 const int op_type = PL_op->op_type;
3549 if (op_type == OP_LINK)
3550 DIE(aTHX_ PL_no_func, "link");
3552 # ifndef HAS_SYMLINK
3553 if (op_type == OP_SYMLINK)
3554 DIE(aTHX_ PL_no_func, "symlink");
3558 const char * const tmps2 = POPpconstx;
3559 const char * const tmps = SvPV_nolen_const(TOPs);
3560 TAINT_PROPER(PL_op_desc[op_type]);
3562 # if defined(HAS_LINK)
3563 # if defined(HAS_SYMLINK)
3564 /* Both present - need to choose which. */
3565 (op_type == OP_LINK) ?
3566 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3568 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3569 PerlLIO_link(tmps, tmps2);
3572 # if defined(HAS_SYMLINK)
3573 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3574 symlink(tmps, tmps2);
3579 SETi( result >= 0 );
3586 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3597 char buf[MAXPATHLEN];
3600 #ifndef INCOMPLETE_TAINTS
3604 len = readlink(tmps, buf, sizeof(buf) - 1);
3612 RETSETUNDEF; /* just pretend it's a normal file */
3616 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3618 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3620 char * const save_filename = filename;
3625 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3627 PERL_ARGS_ASSERT_DOONELINER;
3629 Newx(cmdline, size, char);
3630 my_strlcpy(cmdline, cmd, size);
3631 my_strlcat(cmdline, " ", size);
3632 for (s = cmdline + strlen(cmdline); *filename; ) {
3636 if (s - cmdline < size)
3637 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3638 myfp = PerlProc_popen(cmdline, "r");
3642 SV * const tmpsv = sv_newmortal();
3643 /* Need to save/restore 'PL_rs' ?? */
3644 s = sv_gets(tmpsv, myfp, 0);
3645 (void)PerlProc_pclose(myfp);
3649 #ifdef HAS_SYS_ERRLIST
3654 /* you don't see this */
3655 const char * const errmsg =
3656 #ifdef HAS_SYS_ERRLIST
3664 if (instr(s, errmsg)) {
3671 #define EACCES EPERM
3673 if (instr(s, "cannot make"))
3674 SETERRNO(EEXIST,RMS_FEX);
3675 else if (instr(s, "existing file"))
3676 SETERRNO(EEXIST,RMS_FEX);
3677 else if (instr(s, "ile exists"))
3678 SETERRNO(EEXIST,RMS_FEX);
3679 else if (instr(s, "non-exist"))
3680 SETERRNO(ENOENT,RMS_FNF);
3681 else if (instr(s, "does not exist"))
3682 SETERRNO(ENOENT,RMS_FNF);
3683 else if (instr(s, "not empty"))
3684 SETERRNO(EBUSY,SS_DEVOFFLINE);
3685 else if (instr(s, "cannot access"))
3686 SETERRNO(EACCES,RMS_PRV);
3688 SETERRNO(EPERM,RMS_PRV);
3691 else { /* some mkdirs return no failure indication */
3692 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3693 if (PL_op->op_type == OP_RMDIR)
3698 SETERRNO(EACCES,RMS_PRV); /* a guess */
3707 /* This macro removes trailing slashes from a directory name.
3708 * Different operating and file systems take differently to
3709 * trailing slashes. According to POSIX 1003.1 1996 Edition
3710 * any number of trailing slashes should be allowed.
3711 * Thusly we snip them away so that even non-conforming
3712 * systems are happy.
3713 * We should probably do this "filtering" for all
3714 * the functions that expect (potentially) directory names:
3715 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3716 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3718 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3719 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3722 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3723 (tmps) = savepvn((tmps), (len)); \
3733 const int mode = (MAXARG > 1) ? POPi : 0777;
3735 TRIMSLASHES(tmps,len,copy);
3737 TAINT_PROPER("mkdir");
3739 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3743 SETi( dooneliner("mkdir", tmps) );
3744 oldumask = PerlLIO_umask(0);
3745 PerlLIO_umask(oldumask);
3746 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3761 TRIMSLASHES(tmps,len,copy);
3762 TAINT_PROPER("rmdir");
3764 SETi( PerlDir_rmdir(tmps) >= 0 );
3766 SETi( dooneliner("rmdir", tmps) );
3773 /* Directory calls. */
3777 #if defined(Direntry_t) && defined(HAS_READDIR)
3779 const char * const dirname = POPpconstx;
3780 GV * const gv = MUTABLE_GV(POPs);
3781 register IO * const io = GvIOn(gv);
3786 if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED))
3787 Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3788 "Opening filehandle %s also as a directory", GvENAME(gv));
3790 PerlDir_close(IoDIRP(io));
3791 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3797 SETERRNO(EBADF,RMS_DIR);
3800 DIE(aTHX_ PL_no_dir_func, "opendir");
3806 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3807 DIE(aTHX_ PL_no_dir_func, "readdir");
3809 #if !defined(I_DIRENT) && !defined(VMS)
3810 Direntry_t *readdir (DIR *);
3816 const I32 gimme = GIMME;
3817 GV * const gv = MUTABLE_GV(POPs);
3818 register const Direntry_t *dp;
3819 register IO * const io = GvIOn(gv);
3821 if (!io || !IoDIRP(io)) {
3822 if(ckWARN(WARN_IO)) {
3823 Perl_warner(aTHX_ packWARN(WARN_IO),
3824 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3830 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3834 sv = newSVpvn(dp->d_name, dp->d_namlen);
3836 sv = newSVpv(dp->d_name, 0);
3838 #ifndef INCOMPLETE_TAINTS
3839 if (!(IoFLAGS(io) & IOf_UNTAINT))
3843 } while (gimme == G_ARRAY);
3845 if (!dp && gimme != G_ARRAY)
3852 SETERRNO(EBADF,RMS_ISI);
3853 if (GIMME == G_ARRAY)
3862 #if defined(HAS_TELLDIR) || defined(telldir)
3864 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3865 /* XXX netbsd still seemed to.
3866 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3867 --JHI 1999-Feb-02 */
3868 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3869 long telldir (DIR *);
3871 GV * const gv = MUTABLE_GV(POPs);
3872 register IO * const io = GvIOn(gv);
3874 if (!io || !IoDIRP(io)) {
3875 if(ckWARN(WARN_IO)) {
3876 Perl_warner(aTHX_ packWARN(WARN_IO),
3877 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3882 PUSHi( PerlDir_tell(IoDIRP(io)) );
3886 SETERRNO(EBADF,RMS_ISI);
3889 DIE(aTHX_ PL_no_dir_func, "telldir");
3895 #if defined(HAS_SEEKDIR) || defined(seekdir)
3897 const long along = POPl;
3898 GV * const gv = MUTABLE_GV(POPs);
3899 register IO * const io = GvIOn(gv);
3901 if (!io || !IoDIRP(io)) {
3902 if(ckWARN(WARN_IO)) {
3903 Perl_warner(aTHX_ packWARN(WARN_IO),
3904 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3908 (void)PerlDir_seek(IoDIRP(io), along);
3913 SETERRNO(EBADF,RMS_ISI);
3916 DIE(aTHX_ PL_no_dir_func, "seekdir");
3922 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3924 GV * const gv = MUTABLE_GV(POPs);
3925 register IO * const io = GvIOn(gv);
3927 if (!io || !IoDIRP(io)) {
3928 if(ckWARN(WARN_IO)) {
3929 Perl_warner(aTHX_ packWARN(WARN_IO),
3930 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3934 (void)PerlDir_rewind(IoDIRP(io));
3938 SETERRNO(EBADF,RMS_ISI);
3941 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3947 #if defined(Direntry_t) && defined(HAS_READDIR)
3949 GV * const gv = MUTABLE_GV(POPs);
3950 register IO * const io = GvIOn(gv);
3952 if (!io || !IoDIRP(io)) {
3953 if(ckWARN(WARN_IO)) {
3954 Perl_warner(aTHX_ packWARN(WARN_IO),
3955 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3959 #ifdef VOID_CLOSEDIR
3960 PerlDir_close(IoDIRP(io));
3962 if (PerlDir_close(IoDIRP(io)) < 0) {
3963 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3972 SETERRNO(EBADF,RMS_IFI);
3975 DIE(aTHX_ PL_no_dir_func, "closedir");
3979 /* Process control. */
3988 PERL_FLUSHALL_FOR_CHILD;
3989 childpid = PerlProc_fork();
3993 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3995 SvREADONLY_off(GvSV(tmpgv));
3996 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3997 SvREADONLY_on(GvSV(tmpgv));
3999 #ifdef THREADS_HAVE_PIDS
4000 PL_ppid = (IV)getppid();
4002 #ifdef PERL_USES_PL_PIDSTATUS
4003 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4009 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4014 PERL_FLUSHALL_FOR_CHILD;
4015 childpid = PerlProc_fork();
4021 DIE(aTHX_ PL_no_func, "fork");
4028 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4033 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4034 childpid = wait4pid(-1, &argflags, 0);
4036 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4041 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4042 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4043 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4045 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4050 DIE(aTHX_ PL_no_func, "wait");
4056 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4058 const int optype = POPi;
4059 const Pid_t pid = TOPi;
4063 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4064 result = wait4pid(pid, &argflags, optype);
4066 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4071 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4072 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4073 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4075 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4080 DIE(aTHX_ PL_no_func, "waitpid");
4086 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4087 #if defined(__LIBCATAMOUNT__)
4088 PL_statusvalue = -1;
4097 while (++MARK <= SP) {
4098 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4103 TAINT_PROPER("system");
4105 PERL_FLUSHALL_FOR_CHILD;
4106 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4112 if (PerlProc_pipe(pp) >= 0)
4114 while ((childpid = PerlProc_fork()) == -1) {
4115 if (errno != EAGAIN) {
4120 PerlLIO_close(pp[0]);
4121 PerlLIO_close(pp[1]);
4128 Sigsave_t ihand,qhand; /* place to save signals during system() */
4132 PerlLIO_close(pp[1]);
4134 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4135 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4138 result = wait4pid(childpid, &status, 0);
4139 } while (result == -1 && errno == EINTR);
4141 (void)rsignal_restore(SIGINT, &ihand);
4142 (void)rsignal_restore(SIGQUIT, &qhand);
4144 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4145 do_execfree(); /* free any memory child malloced on fork */
4152 while (n < sizeof(int)) {
4153 n1 = PerlLIO_read(pp[0],
4154 (void*)(((char*)&errkid)+n),
4160 PerlLIO_close(pp[0]);
4161 if (n) { /* Error */
4162 if (n != sizeof(int))
4163 DIE(aTHX_ "panic: kid popen errno read");
4164 errno = errkid; /* Propagate errno from kid */
4165 STATUS_NATIVE_CHILD_SET(-1);
4168 XPUSHi(STATUS_CURRENT);
4172 PerlLIO_close(pp[0]);
4173 #if defined(HAS_FCNTL) && defined(F_SETFD)
4174 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4177 if (PL_op->op_flags & OPf_STACKED) {
4178 SV * const really = *++MARK;
4179 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4181 else if (SP - MARK != 1)
4182 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4184 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4188 #else /* ! FORK or VMS or OS/2 */
4191 if (PL_op->op_flags & OPf_STACKED) {
4192 SV * const really = *++MARK;
4193 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4194 value = (I32)do_aspawn(really, MARK, SP);
4196 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4199 else if (SP - MARK != 1) {
4200 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4201 value = (I32)do_aspawn(NULL, MARK, SP);
4203 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4207 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4209 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4211 STATUS_NATIVE_CHILD_SET(value);
4214 XPUSHi(result ? value : STATUS_CURRENT);
4215 #endif /* !FORK or VMS or OS/2 */
4222 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4227 while (++MARK <= SP) {
4228 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4233 TAINT_PROPER("exec");
4235 PERL_FLUSHALL_FOR_CHILD;
4236 if (PL_op->op_flags & OPf_STACKED) {
4237 SV * const really = *++MARK;
4238 value = (I32)do_aexec(really, MARK, SP);
4240 else if (SP - MARK != 1)
4242 value = (I32)vms_do_aexec(NULL, MARK, SP);
4246 (void ) do_aspawn(NULL, MARK, SP);
4250 value = (I32)do_aexec(NULL, MARK, SP);
4255 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4258 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4261 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4275 # ifdef THREADS_HAVE_PIDS
4276 if (PL_ppid != 1 && getppid() == 1)
4277 /* maybe the parent process has died. Refresh ppid cache */
4281 XPUSHi( getppid() );
4285 DIE(aTHX_ PL_no_func, "getppid");
4294 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4297 pgrp = (I32)BSD_GETPGRP(pid);
4299 if (pid != 0 && pid != PerlProc_getpid())
4300 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4306 DIE(aTHX_ PL_no_func, "getpgrp()");
4325 TAINT_PROPER("setpgrp");
4327 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4329 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4330 || (pid != 0 && pid != PerlProc_getpid()))
4332 DIE(aTHX_ "setpgrp can't take arguments");
4334 SETi( setpgrp() >= 0 );
4335 #endif /* USE_BSDPGRP */
4338 DIE(aTHX_ PL_no_func, "setpgrp()");
4344 #ifdef HAS_GETPRIORITY
4346 const int who = POPi;
4347 const int which = TOPi;
4348 SETi( getpriority(which, who) );
4351 DIE(aTHX_ PL_no_func, "getpriority()");
4357 #ifdef HAS_SETPRIORITY
4359 const int niceval = POPi;
4360 const int who = POPi;
4361 const int which = TOPi;
4362 TAINT_PROPER("setpriority");
4363 SETi( setpriority(which, who, niceval) >= 0 );
4366 DIE(aTHX_ PL_no_func, "setpriority()");
4376 XPUSHn( time(NULL) );
4378 XPUSHi( time(NULL) );
4390 (void)PerlProc_times(&PL_timesbuf);
4392 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4393 /* struct tms, though same data */
4397 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4398 if (GIMME == G_ARRAY) {
4399 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4400 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4401 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4409 if (GIMME == G_ARRAY) {
4416 DIE(aTHX_ "times not implemented");
4418 #endif /* HAS_TIMES */
4428 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4429 static const char * const dayname[] =
4430 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4431 static const char * const monname[] =
4432 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4433 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4438 when = (Time64_T)now;
4441 /* XXX POPq uses an SvIV so it won't work with 32 bit integer scalars
4442 using a double causes an unfortunate loss of accuracy on high numbers.
4443 What we really need is an SvQV.
4445 double input = POPn;
4446 when = (Time64_T)input;
4447 if( when != input ) {
4448 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4449 "%s(%.0f) too large", opname, input);
4453 if (PL_op->op_type == OP_LOCALTIME)
4454 err = localtime64_r(&when, &tmbuf);
4456 err = gmtime64_r(&when, &tmbuf);
4459 /* XXX %lld broken for quads */
4460 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4461 "%s(%.0f) failed", opname, (double)when);
4464 if (GIMME != G_ARRAY) { /* scalar context */
4466 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4467 double year = (double)tmbuf.tm_year + 1900;
4474 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4475 dayname[tmbuf.tm_wday],
4476 monname[tmbuf.tm_mon],
4484 else { /* list context */
4490 mPUSHi(tmbuf.tm_sec);
4491 mPUSHi(tmbuf.tm_min);
4492 mPUSHi(tmbuf.tm_hour);
4493 mPUSHi(tmbuf.tm_mday);
4494 mPUSHi(tmbuf.tm_mon);
4495 mPUSHn(tmbuf.tm_year);
4496 mPUSHi(tmbuf.tm_wday);
4497 mPUSHi(tmbuf.tm_yday);
4498 mPUSHi(tmbuf.tm_isdst);
4509 anum = alarm((unsigned int)anum);
4516 DIE(aTHX_ PL_no_func, "alarm");
4527 (void)time(&lasttime);
4532 PerlProc_sleep((unsigned int)duration);
4535 XPUSHi(when - lasttime);
4539 /* Shared memory. */
4540 /* Merged with some message passing. */
4544 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4545 dVAR; dSP; dMARK; dTARGET;
4546 const int op_type = PL_op->op_type;
4551 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4554 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4557 value = (I32)(do_semop(MARK, SP) >= 0);
4560 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4576 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4577 dVAR; dSP; dMARK; dTARGET;
4578 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4585 DIE(aTHX_ "System V IPC is not implemented on this machine");
4591 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4592 dVAR; dSP; dMARK; dTARGET;
4593 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4601 PUSHp(zero_but_true, ZBTLEN);
4609 /* I can't const this further without getting warnings about the types of
4610 various arrays passed in from structures. */
4612 S_space_join_names_mortal(pTHX_ char *const *array)
4616 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4618 if (array && *array) {
4619 target = newSVpvs_flags("", SVs_TEMP);
4621 sv_catpv(target, *array);
4624 sv_catpvs(target, " ");
4627 target = sv_mortalcopy(&PL_sv_no);
4632 /* Get system info. */
4636 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4638 I32 which = PL_op->op_type;
4639 register char **elem;
4641 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4642 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4643 struct hostent *gethostbyname(Netdb_name_t);
4644 struct hostent *gethostent(void);
4646 struct hostent *hent;
4650 if (which == OP_GHBYNAME) {
4651 #ifdef HAS_GETHOSTBYNAME
4652 const char* const name = POPpbytex;
4653 hent = PerlSock_gethostbyname(name);
4655 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4658 else if (which == OP_GHBYADDR) {
4659 #ifdef HAS_GETHOSTBYADDR
4660 const int addrtype = POPi;
4661 SV * const addrsv = POPs;
4663 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4665 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4667 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4671 #ifdef HAS_GETHOSTENT
4672 hent = PerlSock_gethostent();
4674 DIE(aTHX_ PL_no_sock_func, "gethostent");
4677 #ifdef HOST_NOT_FOUND
4679 #ifdef USE_REENTRANT_API
4680 # ifdef USE_GETHOSTENT_ERRNO
4681 h_errno = PL_reentrant_buffer->_gethostent_errno;
4684 STATUS_UNIX_SET(h_errno);
4688 if (GIMME != G_ARRAY) {
4689 PUSHs(sv = sv_newmortal());
4691 if (which == OP_GHBYNAME) {
4693 sv_setpvn(sv, hent->h_addr, hent->h_length);
4696 sv_setpv(sv, (char*)hent->h_name);
4702 mPUSHs(newSVpv((char*)hent->h_name, 0));
4703 PUSHs(space_join_names_mortal(hent->h_aliases));
4704 mPUSHi(hent->h_addrtype);
4705 len = hent->h_length;
4708 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4709 mXPUSHp(*elem, len);
4713 mPUSHp(hent->h_addr, len);
4715 PUSHs(sv_mortalcopy(&PL_sv_no));
4720 DIE(aTHX_ PL_no_sock_func, "gethostent");
4726 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4728 I32 which = PL_op->op_type;
4730 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4731 struct netent *getnetbyaddr(Netdb_net_t, int);
4732 struct netent *getnetbyname(Netdb_name_t);
4733 struct netent *getnetent(void);
4735 struct netent *nent;
4737 if (which == OP_GNBYNAME){
4738 #ifdef HAS_GETNETBYNAME
4739 const char * const name = POPpbytex;
4740 nent = PerlSock_getnetbyname(name);
4742 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4745 else if (which == OP_GNBYADDR) {
4746 #ifdef HAS_GETNETBYADDR
4747 const int addrtype = POPi;
4748 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4749 nent = PerlSock_getnetbyaddr(addr, addrtype);
4751 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4755 #ifdef HAS_GETNETENT
4756 nent = PerlSock_getnetent();
4758 DIE(aTHX_ PL_no_sock_func, "getnetent");
4761 #ifdef HOST_NOT_FOUND
4763 #ifdef USE_REENTRANT_API
4764 # ifdef USE_GETNETENT_ERRNO
4765 h_errno = PL_reentrant_buffer->_getnetent_errno;
4768 STATUS_UNIX_SET(h_errno);
4773 if (GIMME != G_ARRAY) {
4774 PUSHs(sv = sv_newmortal());
4776 if (which == OP_GNBYNAME)
4777 sv_setiv(sv, (IV)nent->n_net);
4779 sv_setpv(sv, nent->n_name);
4785 mPUSHs(newSVpv(nent->n_name, 0));
4786 PUSHs(space_join_names_mortal(nent->n_aliases));
4787 mPUSHi(nent->n_addrtype);
4788 mPUSHi(nent->n_net);
4793 DIE(aTHX_ PL_no_sock_func, "getnetent");
4799 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4801 I32 which = PL_op->op_type;
4803 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4804 struct protoent *getprotobyname(Netdb_name_t);
4805 struct protoent *getprotobynumber(int);
4806 struct protoent *getprotoent(void);
4808 struct protoent *pent;
4810 if (which == OP_GPBYNAME) {
4811 #ifdef HAS_GETPROTOBYNAME
4812 const char* const name = POPpbytex;
4813 pent = PerlSock_getprotobyname(name);
4815 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4818 else if (which == OP_GPBYNUMBER) {
4819 #ifdef HAS_GETPROTOBYNUMBER
4820 const int number = POPi;
4821 pent = PerlSock_getprotobynumber(number);
4823 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4827 #ifdef HAS_GETPROTOENT
4828 pent = PerlSock_getprotoent();
4830 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4834 if (GIMME != G_ARRAY) {
4835 PUSHs(sv = sv_newmortal());
4837 if (which == OP_GPBYNAME)
4838 sv_setiv(sv, (IV)pent->p_proto);
4840 sv_setpv(sv, pent->p_name);
4846 mPUSHs(newSVpv(pent->p_name, 0));
4847 PUSHs(space_join_names_mortal(pent->p_aliases));
4848 mPUSHi(pent->p_proto);
4853 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4859 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4861 I32 which = PL_op->op_type;
4863 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4864 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4865 struct servent *getservbyport(int, Netdb_name_t);
4866 struct servent *getservent(void);
4868 struct servent *sent;
4870 if (which == OP_GSBYNAME) {
4871 #ifdef HAS_GETSERVBYNAME
4872 const char * const proto = POPpbytex;
4873 const char * const name = POPpbytex;
4874 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4876 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4879 else if (which == OP_GSBYPORT) {
4880 #ifdef HAS_GETSERVBYPORT
4881 const char * const proto = POPpbytex;
4882 unsigned short port = (unsigned short)POPu;
4884 port = PerlSock_htons(port);
4886 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4888 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4892 #ifdef HAS_GETSERVENT
4893 sent = PerlSock_getservent();
4895 DIE(aTHX_ PL_no_sock_func, "getservent");
4899 if (GIMME != G_ARRAY) {
4900 PUSHs(sv = sv_newmortal());
4902 if (which == OP_GSBYNAME) {
4904 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4906 sv_setiv(sv, (IV)(sent->s_port));
4910 sv_setpv(sv, sent->s_name);
4916 mPUSHs(newSVpv(sent->s_name, 0));
4917 PUSHs(space_join_names_mortal(sent->s_aliases));
4919 mPUSHi(PerlSock_ntohs(sent->s_port));
4921 mPUSHi(sent->s_port);
4923 mPUSHs(newSVpv(sent->s_proto, 0));
4928 DIE(aTHX_ PL_no_sock_func, "getservent");
4934 #ifdef HAS_SETHOSTENT
4936 PerlSock_sethostent(TOPi);
4939 DIE(aTHX_ PL_no_sock_func, "sethostent");
4945 #ifdef HAS_SETNETENT
4947 (void)PerlSock_setnetent(TOPi);
4950 DIE(aTHX_ PL_no_sock_func, "setnetent");
4956 #ifdef HAS_SETPROTOENT
4958 (void)PerlSock_setprotoent(TOPi);
4961 DIE(aTHX_ PL_no_sock_func, "setprotoent");
4967 #ifdef HAS_SETSERVENT
4969 (void)PerlSock_setservent(TOPi);
4972 DIE(aTHX_ PL_no_sock_func, "setservent");
4978 #ifdef HAS_ENDHOSTENT
4980 PerlSock_endhostent();
4984 DIE(aTHX_ PL_no_sock_func, "endhostent");
4990 #ifdef HAS_ENDNETENT
4992 PerlSock_endnetent();
4996 DIE(aTHX_ PL_no_sock_func, "endnetent");
5002 #ifdef HAS_ENDPROTOENT
5004 PerlSock_endprotoent();
5008 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5014 #ifdef HAS_ENDSERVENT
5016 PerlSock_endservent();
5020 DIE(aTHX_ PL_no_sock_func, "endservent");
5028 I32 which = PL_op->op_type;
5030 struct passwd *pwent = NULL;
5032 * We currently support only the SysV getsp* shadow password interface.
5033 * The interface is declared in <shadow.h> and often one needs to link
5034 * with -lsecurity or some such.
5035 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5038 * AIX getpwnam() is clever enough to return the encrypted password
5039 * only if the caller (euid?) is root.
5041 * There are at least three other shadow password APIs. Many platforms
5042 * seem to contain more than one interface for accessing the shadow
5043 * password databases, possibly for compatibility reasons.
5044 * The getsp*() is by far he simplest one, the other two interfaces
5045 * are much more complicated, but also very similar to each other.
5050 * struct pr_passwd *getprpw*();
5051 * The password is in
5052 * char getprpw*(...).ufld.fd_encrypt[]
5053 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5058 * struct es_passwd *getespw*();
5059 * The password is in
5060 * char *(getespw*(...).ufld.fd_encrypt)
5061 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5064 * struct userpw *getuserpw();
5065 * The password is in
5066 * char *(getuserpw(...)).spw_upw_passwd
5067 * (but the de facto standard getpwnam() should work okay)
5069 * Mention I_PROT here so that Configure probes for it.
5071 * In HP-UX for getprpw*() the manual page claims that one should include
5072 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5073 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5074 * and pp_sys.c already includes <shadow.h> if there is such.
5076 * Note that <sys/security.h> is already probed for, but currently
5077 * it is only included in special cases.
5079 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5080 * be preferred interface, even though also the getprpw*() interface
5081 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5082 * One also needs to call set_auth_parameters() in main() before
5083 * doing anything else, whether one is using getespw*() or getprpw*().
5085 * Note that accessing the shadow databases can be magnitudes
5086 * slower than accessing the standard databases.
5091 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5092 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5093 * the pw_comment is left uninitialized. */
5094 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5100 const char* const name = POPpbytex;
5101 pwent = getpwnam(name);
5107 pwent = getpwuid(uid);
5111 # ifdef HAS_GETPWENT
5113 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5114 if (pwent) pwent = getpwnam(pwent->pw_name);
5117 DIE(aTHX_ PL_no_func, "getpwent");
5123 if (GIMME != G_ARRAY) {
5124 PUSHs(sv = sv_newmortal());
5126 if (which == OP_GPWNAM)
5127 # if Uid_t_sign <= 0
5128 sv_setiv(sv, (IV)pwent->pw_uid);
5130 sv_setuv(sv, (UV)pwent->pw_uid);
5133 sv_setpv(sv, pwent->pw_name);
5139 mPUSHs(newSVpv(pwent->pw_name, 0));
5143 /* If we have getspnam(), we try to dig up the shadow
5144 * password. If we are underprivileged, the shadow
5145 * interface will set the errno to EACCES or similar,
5146 * and return a null pointer. If this happens, we will
5147 * use the dummy password (usually "*" or "x") from the
5148 * standard password database.
5150 * In theory we could skip the shadow call completely
5151 * if euid != 0 but in practice we cannot know which
5152 * security measures are guarding the shadow databases
5153 * on a random platform.
5155 * Resist the urge to use additional shadow interfaces.
5156 * Divert the urge to writing an extension instead.
5159 /* Some AIX setups falsely(?) detect some getspnam(), which
5160 * has a different API than the Solaris/IRIX one. */
5161 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5164 const struct spwd * const spwent = getspnam(pwent->pw_name);
5165 /* Save and restore errno so that
5166 * underprivileged attempts seem
5167 * to have never made the unsccessful
5168 * attempt to retrieve the shadow password. */
5170 if (spwent && spwent->sp_pwdp)
5171 sv_setpv(sv, spwent->sp_pwdp);
5175 if (!SvPOK(sv)) /* Use the standard password, then. */
5176 sv_setpv(sv, pwent->pw_passwd);
5179 # ifndef INCOMPLETE_TAINTS
5180 /* passwd is tainted because user himself can diddle with it.
5181 * admittedly not much and in a very limited way, but nevertheless. */
5185 # if Uid_t_sign <= 0
5186 mPUSHi(pwent->pw_uid);
5188 mPUSHu(pwent->pw_uid);
5191 # if Uid_t_sign <= 0
5192 mPUSHi(pwent->pw_gid);
5194 mPUSHu(pwent->pw_gid);
5196 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5197 * because of the poor interface of the Perl getpw*(),
5198 * not because there's some standard/convention saying so.
5199 * A better interface would have been to return a hash,
5200 * but we are accursed by our history, alas. --jhi. */
5202 mPUSHi(pwent->pw_change);
5205 mPUSHi(pwent->pw_quota);
5208 mPUSHs(newSVpv(pwent->pw_age, 0));
5210 /* I think that you can never get this compiled, but just in case. */
5211 PUSHs(sv_mortalcopy(&PL_sv_no));
5216 /* pw_class and pw_comment are mutually exclusive--.
5217 * see the above note for pw_change, pw_quota, and pw_age. */
5219 mPUSHs(newSVpv(pwent->pw_class, 0));
5222 mPUSHs(newSVpv(pwent->pw_comment, 0));
5224 /* I think that you can never get this compiled, but just in case. */
5225 PUSHs(sv_mortalcopy(&PL_sv_no));
5230 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5232 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5234 # ifndef INCOMPLETE_TAINTS
5235 /* pw_gecos is tainted because user himself can diddle with it. */
5239 mPUSHs(newSVpv(pwent->pw_dir, 0));
5241 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5242 # ifndef INCOMPLETE_TAINTS
5243 /* pw_shell is tainted because user himself can diddle with it. */
5248 mPUSHi(pwent->pw_expire);
5253 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5259 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5264 DIE(aTHX_ PL_no_func, "setpwent");
5270 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5275 DIE(aTHX_ PL_no_func, "endpwent");
5283 const I32 which = PL_op->op_type;
5284 const struct group *grent;
5286 if (which == OP_GGRNAM) {
5287 const char* const name = POPpbytex;
5288 grent = (const struct group *)getgrnam(name);
5290 else if (which == OP_GGRGID) {
5291 const Gid_t gid = POPi;
5292 grent = (const struct group *)getgrgid(gid);
5296 grent = (struct group *)getgrent();
5298 DIE(aTHX_ PL_no_func, "getgrent");
5302 if (GIMME != G_ARRAY) {
5303 SV * const sv = sv_newmortal();
5307 if (which == OP_GGRNAM)
5308 sv_setiv(sv, (IV)grent->gr_gid);
5310 sv_setpv(sv, grent->gr_name);
5316 mPUSHs(newSVpv(grent->gr_name, 0));
5319 mPUSHs(newSVpv(grent->gr_passwd, 0));
5321 PUSHs(sv_mortalcopy(&PL_sv_no));
5324 mPUSHi(grent->gr_gid);
5326 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5327 /* In UNICOS/mk (_CRAYMPP) the multithreading
5328 * versions (getgrnam_r, getgrgid_r)
5329 * seem to return an illegal pointer
5330 * as the group members list, gr_mem.
5331 * getgrent() doesn't even have a _r version
5332 * but the gr_mem is poisonous anyway.
5333 * So yes, you cannot get the list of group
5334 * members if building multithreaded in UNICOS/mk. */
5335 PUSHs(space_join_names_mortal(grent->gr_mem));
5341 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5347 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5352 DIE(aTHX_ PL_no_func, "setgrent");
5358 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5363 DIE(aTHX_ PL_no_func, "endgrent");
5373 if (!(tmps = PerlProc_getlogin()))
5375 PUSHp(tmps, strlen(tmps));
5378 DIE(aTHX_ PL_no_func, "getlogin");
5382 /* Miscellaneous. */
5387 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5388 register I32 items = SP - MARK;
5389 unsigned long a[20];
5394 while (++MARK <= SP) {
5395 if (SvTAINTED(*MARK)) {
5401 TAINT_PROPER("syscall");
5404 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5405 * or where sizeof(long) != sizeof(char*). But such machines will
5406 * not likely have syscall implemented either, so who cares?
5408 while (++MARK <= SP) {
5409 if (SvNIOK(*MARK) || !i)
5410 a[i++] = SvIV(*MARK);
5411 else if (*MARK == &PL_sv_undef)
5414 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5420 DIE(aTHX_ "Too many args to syscall");
5422 DIE(aTHX_ "Too few args to syscall");
5424 retval = syscall(a[0]);
5427 retval = syscall(a[0],a[1]);
5430 retval = syscall(a[0],a[1],a[2]);
5433 retval = syscall(a[0],a[1],a[2],a[3]);
5436 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5439 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5442 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5445 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5449 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5452 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5455 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5459 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5463 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5467 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5468 a[10],a[11],a[12],a[13]);
5470 #endif /* atarist */
5476 DIE(aTHX_ PL_no_func, "syscall");
5480 #ifdef FCNTL_EMULATE_FLOCK
5482 /* XXX Emulate flock() with fcntl().
5483 What's really needed is a good file locking module.
5487 fcntl_emulate_flock(int fd, int operation)
5491 switch (operation & ~LOCK_NB) {
5493 flock.l_type = F_RDLCK;
5496 flock.l_type = F_WRLCK;
5499 flock.l_type = F_UNLCK;
5505 flock.l_whence = SEEK_SET;
5506 flock.l_start = flock.l_len = (Off_t)0;
5508 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5511 #endif /* FCNTL_EMULATE_FLOCK */
5513 #ifdef LOCKF_EMULATE_FLOCK
5515 /* XXX Emulate flock() with lockf(). This is just to increase
5516 portability of scripts. The calls are not completely
5517 interchangeable. What's really needed is a good file
5521 /* The lockf() constants might have been defined in <unistd.h>.
5522 Unfortunately, <unistd.h> causes troubles on some mixed
5523 (BSD/POSIX) systems, such as SunOS 4.1.3.
5525 Further, the lockf() constants aren't POSIX, so they might not be
5526 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5527 just stick in the SVID values and be done with it. Sigh.
5531 # define F_ULOCK 0 /* Unlock a previously locked region */
5534 # define F_LOCK 1 /* Lock a region for exclusive use */
5537 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5540 # define F_TEST 3 /* Test a region for other processes locks */
5544 lockf_emulate_flock(int fd, int operation)
5550 /* flock locks entire file so for lockf we need to do the same */
5551 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5552 if (pos > 0) /* is seekable and needs to be repositioned */
5553 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5554 pos = -1; /* seek failed, so don't seek back afterwards */
5557 switch (operation) {
5559 /* LOCK_SH - get a shared lock */
5561 /* LOCK_EX - get an exclusive lock */
5563 i = lockf (fd, F_LOCK, 0);
5566 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5567 case LOCK_SH|LOCK_NB:
5568 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5569 case LOCK_EX|LOCK_NB:
5570 i = lockf (fd, F_TLOCK, 0);
5572 if ((errno == EAGAIN) || (errno == EACCES))
5573 errno = EWOULDBLOCK;
5576 /* LOCK_UN - unlock (non-blocking is a no-op) */
5578 case LOCK_UN|LOCK_NB:
5579 i = lockf (fd, F_ULOCK, 0);
5582 /* Default - can't decipher operation */
5589 if (pos > 0) /* need to restore position of the handle */
5590 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5595 #endif /* LOCKF_EMULATE_FLOCK */
5599 * c-indentation-style: bsd
5601 * indent-tabs-mode: t
5604 * ex: set ts=8 sts=4 sw=4 noet: