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 methname = "TIEHANDLE";
806 how = PERL_MAGIC_tiedscalar;
807 /* For tied filehandles, we apply tiedscalar magic to the IO
808 slot of the GP rather than the GV itself. AMS 20010812 */
810 GvIOp(varsv) = newIO();
811 varsv = MUTABLE_SV(GvIOp(varsv));
816 methname = "TIESCALAR";
817 how = PERL_MAGIC_tiedscalar;
821 if (sv_isobject(*MARK)) { /* Calls GET magic. */
823 PUSHSTACKi(PERLSI_MAGIC);
825 EXTEND(SP,(I32)items);
829 call_method(methname, G_SCALAR);
832 /* Not clear why we don't call call_method here too.
833 * perhaps to get different error message ?
836 const char *name = SvPV_nomg_const(*MARK, len);
837 stash = gv_stashpvn(name, len, 0);
838 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
839 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
840 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
843 PUSHSTACKi(PERLSI_MAGIC);
845 EXTEND(SP,(I32)items);
849 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
855 if (sv_isobject(sv)) {
856 sv_unmagic(varsv, how);
857 /* Croak if a self-tie on an aggregate is attempted. */
858 if (varsv == SvRV(sv) &&
859 (SvTYPE(varsv) == SVt_PVAV ||
860 SvTYPE(varsv) == SVt_PVHV))
862 "Self-ties of arrays and hashes are not supported");
863 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
866 SP = PL_stack_base + markoff;
876 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
877 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
879 if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
882 if ((mg = SvTIED_mg(sv, how))) {
883 SV * const obj = SvRV(SvTIED_obj(sv, mg));
885 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
887 if (gv && isGV(gv) && (cv = GvCV(gv))) {
889 XPUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
890 mXPUSHi(SvREFCNT(obj) - 1);
893 call_sv(MUTABLE_SV(cv), G_VOID);
897 else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
898 Perl_warner(aTHX_ packWARN(WARN_UNTIE),
899 "untie attempted while %"UVuf" inner references still exist",
900 (UV)SvREFCNT(obj) - 1 ) ;
904 sv_unmagic(sv, how) ;
914 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
915 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
917 if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
920 if ((mg = SvTIED_mg(sv, how))) {
921 SV *osv = SvTIED_obj(sv, mg);
922 if (osv == mg->mg_obj)
923 osv = sv_mortalcopy(osv);
937 HV * const hv = MUTABLE_HV(POPs);
938 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
939 stash = gv_stashsv(sv, 0);
940 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
942 require_pv("AnyDBM_File.pm");
944 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
945 DIE(aTHX_ "No dbm on this machine");
955 mPUSHu(O_RDWR|O_CREAT);
960 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
963 if (!sv_isobject(TOPs)) {
971 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
975 if (sv_isobject(TOPs)) {
976 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
977 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
994 struct timeval timebuf;
995 struct timeval *tbuf = &timebuf;
998 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1003 # if BYTEORDER & 0xf0000
1004 # define ORDERBYTE (0x88888888 - BYTEORDER)
1006 # define ORDERBYTE (0x4444 - BYTEORDER)
1012 for (i = 1; i <= 3; i++) {
1013 SV * const sv = SP[i];
1016 if (SvREADONLY(sv)) {
1018 sv_force_normal_flags(sv, 0);
1019 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1020 DIE(aTHX_ "%s", PL_no_modify);
1023 if (ckWARN(WARN_MISC))
1024 Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1025 SvPV_force_nolen(sv); /* force string conversion */
1032 /* little endians can use vecs directly */
1033 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1040 masksize = NFDBITS / NBBY;
1042 masksize = sizeof(long); /* documented int, everyone seems to use long */
1044 Zero(&fd_sets[0], 4, char*);
1047 # if SELECT_MIN_BITS == 1
1048 growsize = sizeof(fd_set);
1050 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1051 # undef SELECT_MIN_BITS
1052 # define SELECT_MIN_BITS __FD_SETSIZE
1054 /* If SELECT_MIN_BITS is greater than one we most probably will want
1055 * to align the sizes with SELECT_MIN_BITS/8 because for example
1056 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1057 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1058 * on (sets/tests/clears bits) is 32 bits. */
1059 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1067 timebuf.tv_sec = (long)value;
1068 value -= (NV)timebuf.tv_sec;
1069 timebuf.tv_usec = (long)(value * 1000000.0);
1074 for (i = 1; i <= 3; i++) {
1076 if (!SvOK(sv) || SvCUR(sv) == 0) {
1083 Sv_Grow(sv, growsize);
1087 while (++j <= growsize) {
1091 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1093 Newx(fd_sets[i], growsize, char);
1094 for (offset = 0; offset < growsize; offset += masksize) {
1095 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1096 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1099 fd_sets[i] = SvPVX(sv);
1103 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1104 /* Can't make just the (void*) conditional because that would be
1105 * cpp #if within cpp macro, and not all compilers like that. */
1106 nfound = PerlSock_select(
1108 (Select_fd_set_t) fd_sets[1],
1109 (Select_fd_set_t) fd_sets[2],
1110 (Select_fd_set_t) fd_sets[3],
1111 (void*) tbuf); /* Workaround for compiler bug. */
1113 nfound = PerlSock_select(
1115 (Select_fd_set_t) fd_sets[1],
1116 (Select_fd_set_t) fd_sets[2],
1117 (Select_fd_set_t) fd_sets[3],
1120 for (i = 1; i <= 3; i++) {
1123 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1125 for (offset = 0; offset < growsize; offset += masksize) {
1126 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1127 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1129 Safefree(fd_sets[i]);
1136 if (GIMME == G_ARRAY && tbuf) {
1137 value = (NV)(timebuf.tv_sec) +
1138 (NV)(timebuf.tv_usec) / 1000000.0;
1143 DIE(aTHX_ "select not implemented");
1148 =for apidoc setdefout
1150 Sets PL_defoutgv, the default file handle for output, to the passed in
1151 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1152 count of the passed in typeglob is increased by one, and the reference count
1153 of the typeglob that PL_defoutgv points to is decreased by one.
1159 Perl_setdefout(pTHX_ GV *gv)
1162 SvREFCNT_inc_simple_void(gv);
1164 SvREFCNT_dec(PL_defoutgv);
1172 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1173 GV * egv = GvEGV(PL_defoutgv);
1179 XPUSHs(&PL_sv_undef);
1181 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1182 if (gvp && *gvp == egv) {
1183 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1187 mXPUSHs(newRV(MUTABLE_SV(egv)));
1192 if (!GvIO(newdefout))
1193 gv_IOadd(newdefout);
1194 setdefout(newdefout);
1204 GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs);
1206 if (gv && (io = GvIO(gv))) {
1207 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1209 const I32 gimme = GIMME_V;
1211 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1214 call_method("GETC", gimme);
1217 if (gimme == G_SCALAR)
1218 SvSetMagicSV_nosteal(TARG, TOPs);
1222 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1223 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1224 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1225 report_evil_fh(gv, io, PL_op->op_type);
1226 SETERRNO(EBADF,RMS_IFI);
1230 sv_setpvs(TARG, " ");
1231 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1232 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1233 /* Find out how many bytes the char needs */
1234 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1237 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1238 SvCUR_set(TARG,1+len);
1247 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1250 register PERL_CONTEXT *cx;
1251 const I32 gimme = GIMME_V;
1253 PERL_ARGS_ASSERT_DOFORM;
1258 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1259 PUSHFORMAT(cx, retop);
1261 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1263 setdefout(gv); /* locally select filehandle so $% et al work */
1280 gv = MUTABLE_GV(POPs);
1295 goto not_a_format_reference;
1300 tmpsv = sv_newmortal();
1301 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1302 name = SvPV_nolen_const(tmpsv);
1304 DIE(aTHX_ "Undefined format \"%s\" called", name);
1306 not_a_format_reference:
1307 DIE(aTHX_ "Not a format reference");
1310 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1312 IoFLAGS(io) &= ~IOf_DIDTOP;
1313 return doform(cv,gv,PL_op->op_next);
1319 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1320 register IO * const io = GvIOp(gv);
1325 register PERL_CONTEXT *cx;
1327 if (!io || !(ofp = IoOFP(io)))
1330 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1331 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1333 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1334 PL_formtarget != PL_toptarget)
1338 if (!IoTOP_GV(io)) {
1341 if (!IoTOP_NAME(io)) {
1343 if (!IoFMT_NAME(io))
1344 IoFMT_NAME(io) = savepv(GvNAME(gv));
1345 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1346 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1347 if ((topgv && GvFORM(topgv)) ||
1348 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1349 IoTOP_NAME(io) = savesvpv(topname);
1351 IoTOP_NAME(io) = savepvs("top");
1353 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1354 if (!topgv || !GvFORM(topgv)) {
1355 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1358 IoTOP_GV(io) = topgv;
1360 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1361 I32 lines = IoLINES_LEFT(io);
1362 const char *s = SvPVX_const(PL_formtarget);
1363 if (lines <= 0) /* Yow, header didn't even fit!!! */
1365 while (lines-- > 0) {
1366 s = strchr(s, '\n');
1372 const STRLEN save = SvCUR(PL_formtarget);
1373 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1374 do_print(PL_formtarget, ofp);
1375 SvCUR_set(PL_formtarget, save);
1376 sv_chop(PL_formtarget, s);
1377 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1380 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1381 do_print(PL_formfeed, ofp);
1382 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1384 PL_formtarget = PL_toptarget;
1385 IoFLAGS(io) |= IOf_DIDTOP;
1388 DIE(aTHX_ "bad top format reference");
1391 SV * const sv = sv_newmortal();
1393 gv_efullname4(sv, fgv, NULL, FALSE);
1394 name = SvPV_nolen_const(sv);
1396 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1398 DIE(aTHX_ "Undefined top format called");
1400 if (cv && CvCLONE(cv))
1401 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1402 return doform(cv, gv, PL_op);
1406 POPBLOCK(cx,PL_curpm);
1412 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1414 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1415 else if (ckWARN(WARN_CLOSED))
1416 report_evil_fh(gv, io, PL_op->op_type);
1421 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1422 if (ckWARN(WARN_IO))
1423 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1425 if (!do_print(PL_formtarget, fp))
1428 FmLINES(PL_formtarget) = 0;
1429 SvCUR_set(PL_formtarget, 0);
1430 *SvEND(PL_formtarget) = '\0';
1431 if (IoFLAGS(io) & IOf_FLUSH)
1432 (void)PerlIO_flush(fp);
1437 PL_formtarget = PL_bodytarget;
1439 PERL_UNUSED_VAR(newsp);
1440 PERL_UNUSED_VAR(gimme);
1441 return cx->blk_sub.retop;
1446 dVAR; dSP; dMARK; dORIGMARK;
1452 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1454 if (gv && (io = GvIO(gv))) {
1455 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1457 if (MARK == ORIGMARK) {
1460 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1464 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1467 call_method("PRINTF", G_SCALAR);
1470 MARK = ORIGMARK + 1;
1478 if (!(io = GvIO(gv))) {
1479 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1480 report_evil_fh(gv, io, PL_op->op_type);
1481 SETERRNO(EBADF,RMS_IFI);
1484 else if (!(fp = IoOFP(io))) {
1485 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1487 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1488 else if (ckWARN(WARN_CLOSED))
1489 report_evil_fh(gv, io, PL_op->op_type);
1491 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1495 if (SvTAINTED(MARK[1]))
1496 TAINT_PROPER("printf");
1497 do_sprintf(sv, SP - MARK, MARK + 1);
1498 if (!do_print(sv, fp))
1501 if (IoFLAGS(io) & IOf_FLUSH)
1502 if (PerlIO_flush(fp) == EOF)
1513 PUSHs(&PL_sv_undef);
1521 const int perm = (MAXARG > 3) ? POPi : 0666;
1522 const int mode = POPi;
1523 SV * const sv = POPs;
1524 GV * const gv = MUTABLE_GV(POPs);
1527 /* Need TIEHANDLE method ? */
1528 const char * const tmps = SvPV_const(sv, len);
1529 /* FIXME? do_open should do const */
1530 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1531 IoLINES(GvIOp(gv)) = 0;
1535 PUSHs(&PL_sv_undef);
1542 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1548 Sock_size_t bufsize;
1556 bool charstart = FALSE;
1557 STRLEN charskip = 0;
1560 GV * const gv = MUTABLE_GV(*++MARK);
1561 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1562 && gv && (io = GvIO(gv)) )
1564 const MAGIC * mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1568 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1570 call_method("READ", G_SCALAR);
1584 sv_setpvs(bufsv, "");
1585 length = SvIVx(*++MARK);
1588 offset = SvIVx(*++MARK);
1592 if (!io || !IoIFP(io)) {
1593 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1594 report_evil_fh(gv, io, PL_op->op_type);
1595 SETERRNO(EBADF,RMS_IFI);
1598 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1599 buffer = SvPVutf8_force(bufsv, blen);
1600 /* UTF-8 may not have been set if they are all low bytes */
1605 buffer = SvPV_force(bufsv, blen);
1606 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1609 DIE(aTHX_ "Negative length");
1617 if (PL_op->op_type == OP_RECV) {
1618 char namebuf[MAXPATHLEN];
1619 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1620 bufsize = sizeof (struct sockaddr_in);
1622 bufsize = sizeof namebuf;
1624 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1628 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1629 /* 'offset' means 'flags' here */
1630 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1631 (struct sockaddr *)namebuf, &bufsize);
1635 /* Bogus return without padding */
1636 bufsize = sizeof (struct sockaddr_in);
1638 SvCUR_set(bufsv, count);
1639 *SvEND(bufsv) = '\0';
1640 (void)SvPOK_only(bufsv);
1644 /* This should not be marked tainted if the fp is marked clean */
1645 if (!(IoFLAGS(io) & IOf_UNTAINT))
1646 SvTAINTED_on(bufsv);
1648 sv_setpvn(TARG, namebuf, bufsize);
1653 if (PL_op->op_type == OP_RECV)
1654 DIE(aTHX_ PL_no_sock_func, "recv");
1656 if (DO_UTF8(bufsv)) {
1657 /* offset adjust in characters not bytes */
1658 blen = sv_len_utf8(bufsv);
1661 if (-offset > (int)blen)
1662 DIE(aTHX_ "Offset outside string");
1665 if (DO_UTF8(bufsv)) {
1666 /* convert offset-as-chars to offset-as-bytes */
1667 if (offset >= (int)blen)
1668 offset += SvCUR(bufsv) - blen;
1670 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1673 bufsize = SvCUR(bufsv);
1674 /* Allocating length + offset + 1 isn't perfect in the case of reading
1675 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1677 (should be 2 * length + offset + 1, or possibly something longer if
1678 PL_encoding is true) */
1679 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1680 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1681 Zero(buffer+bufsize, offset-bufsize, char);
1683 buffer = buffer + offset;
1685 read_target = bufsv;
1687 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1688 concatenate it to the current buffer. */
1690 /* Truncate the existing buffer to the start of where we will be
1692 SvCUR_set(bufsv, offset);
1694 read_target = sv_newmortal();
1695 SvUPGRADE(read_target, SVt_PV);
1696 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1699 if (PL_op->op_type == OP_SYSREAD) {
1700 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1701 if (IoTYPE(io) == IoTYPE_SOCKET) {
1702 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1708 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1713 #ifdef HAS_SOCKET__bad_code_maybe
1714 if (IoTYPE(io) == IoTYPE_SOCKET) {
1715 char namebuf[MAXPATHLEN];
1716 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1717 bufsize = sizeof (struct sockaddr_in);
1719 bufsize = sizeof namebuf;
1721 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1722 (struct sockaddr *)namebuf, &bufsize);
1727 count = PerlIO_read(IoIFP(io), buffer, length);
1728 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1729 if (count == 0 && PerlIO_error(IoIFP(io)))
1733 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1734 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1737 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1738 *SvEND(read_target) = '\0';
1739 (void)SvPOK_only(read_target);
1740 if (fp_utf8 && !IN_BYTES) {
1741 /* Look at utf8 we got back and count the characters */
1742 const char *bend = buffer + count;
1743 while (buffer < bend) {
1745 skip = UTF8SKIP(buffer);
1748 if (buffer - charskip + skip > bend) {
1749 /* partial character - try for rest of it */
1750 length = skip - (bend-buffer);
1751 offset = bend - SvPVX_const(bufsv);
1763 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1764 provided amount read (count) was what was requested (length)
1766 if (got < wanted && count == length) {
1767 length = wanted - got;
1768 offset = bend - SvPVX_const(bufsv);
1771 /* return value is character count */
1775 else if (buffer_utf8) {
1776 /* Let svcatsv upgrade the bytes we read in to utf8.
1777 The buffer is a mortal so will be freed soon. */
1778 sv_catsv_nomg(bufsv, read_target);
1781 /* This should not be marked tainted if the fp is marked clean */
1782 if (!(IoFLAGS(io) & IOf_UNTAINT))
1783 SvTAINTED_on(bufsv);
1795 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1801 STRLEN orig_blen_bytes;
1802 const int op_type = PL_op->op_type;
1806 GV *const gv = MUTABLE_GV(*++MARK);
1807 if (PL_op->op_type == OP_SYSWRITE
1808 && gv && (io = GvIO(gv))) {
1809 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1813 if (MARK == SP - 1) {
1815 mXPUSHi(sv_len(sv));
1820 *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg);
1822 call_method("WRITE", G_SCALAR);
1838 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1840 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1841 if (io && IoIFP(io))
1842 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1844 report_evil_fh(gv, io, PL_op->op_type);
1846 SETERRNO(EBADF,RMS_IFI);
1850 /* Do this first to trigger any overloading. */
1851 buffer = SvPV_const(bufsv, blen);
1852 orig_blen_bytes = blen;
1853 doing_utf8 = DO_UTF8(bufsv);
1855 if (PerlIO_isutf8(IoIFP(io))) {
1856 if (!SvUTF8(bufsv)) {
1857 /* We don't modify the original scalar. */
1858 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1859 buffer = (char *) tmpbuf;
1863 else if (doing_utf8) {
1864 STRLEN tmplen = blen;
1865 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1868 buffer = (char *) tmpbuf;
1872 assert((char *)result == buffer);
1873 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1877 if (op_type == OP_SYSWRITE) {
1878 Size_t length = 0; /* This length is in characters. */
1884 /* The SV is bytes, and we've had to upgrade it. */
1885 blen_chars = orig_blen_bytes;
1887 /* The SV really is UTF-8. */
1888 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1889 /* Don't call sv_len_utf8 again because it will call magic
1890 or overloading a second time, and we might get back a
1891 different result. */
1892 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1894 /* It's safe, and it may well be cached. */
1895 blen_chars = sv_len_utf8(bufsv);
1903 length = blen_chars;
1905 #if Size_t_size > IVSIZE
1906 length = (Size_t)SvNVx(*++MARK);
1908 length = (Size_t)SvIVx(*++MARK);
1910 if ((SSize_t)length < 0) {
1912 DIE(aTHX_ "Negative length");
1917 offset = SvIVx(*++MARK);
1919 if (-offset > (IV)blen_chars) {
1921 DIE(aTHX_ "Offset outside string");
1923 offset += blen_chars;
1924 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1926 DIE(aTHX_ "Offset outside string");
1930 if (length > blen_chars - offset)
1931 length = blen_chars - offset;
1933 /* Here we convert length from characters to bytes. */
1934 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1935 /* Either we had to convert the SV, or the SV is magical, or
1936 the SV has overloading, in which case we can't or mustn't
1937 or mustn't call it again. */
1939 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1940 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1942 /* It's a real UTF-8 SV, and it's not going to change under
1943 us. Take advantage of any cache. */
1945 I32 len_I32 = length;
1947 /* Convert the start and end character positions to bytes.
1948 Remember that the second argument to sv_pos_u2b is relative
1950 sv_pos_u2b(bufsv, &start, &len_I32);
1957 buffer = buffer+offset;
1959 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1960 if (IoTYPE(io) == IoTYPE_SOCKET) {
1961 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1967 /* See the note at doio.c:do_print about filesize limits. --jhi */
1968 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1974 const int flags = SvIVx(*++MARK);
1977 char * const sockbuf = SvPVx(*++MARK, mlen);
1978 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1979 flags, (struct sockaddr *)sockbuf, mlen);
1983 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1988 DIE(aTHX_ PL_no_sock_func, "send");
1995 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
1998 #if Size_t_size > IVSIZE
2019 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2020 else if (PL_op->op_flags & OPf_SPECIAL)
2021 gv = PL_last_in_gv = GvEGV(PL_argvgv); /* eof() - ARGV magic */
2023 gv = PL_last_in_gv; /* eof */
2028 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2030 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2032 * in Perl 5.12 and later, the additional paramter is a bitmask:
2035 * 2 = eof() <- ARGV magic
2038 mPUSHi(1); /* 1 = eof(FH) - simple, explicit FH */
2039 else if (PL_op->op_flags & OPf_SPECIAL)
2040 mPUSHi(2); /* 2 = eof() - ARGV magic */
2042 mPUSHi(0); /* 0 = eof - simple, implicit FH */
2045 call_method("EOF", G_SCALAR);
2051 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2052 if (io && !IoIFP(io)) {
2053 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2055 IoFLAGS(io) &= ~IOf_START;
2056 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2058 sv_setpvs(GvSV(gv), "-");
2060 GvSV(gv) = newSVpvs("-");
2061 SvSETMAGIC(GvSV(gv));
2063 else if (!nextargv(gv))
2068 PUSHs(boolSV(do_eof(gv)));
2079 PL_last_in_gv = MUTABLE_GV(POPs);
2082 if (gv && (io = GvIO(gv))) {
2083 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2086 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2089 call_method("TELL", G_SCALAR);
2096 #if LSEEKSIZE > IVSIZE
2097 PUSHn( do_tell(gv) );
2099 PUSHi( do_tell(gv) );
2107 const int whence = POPi;
2108 #if LSEEKSIZE > IVSIZE
2109 const Off_t offset = (Off_t)SvNVx(POPs);
2111 const Off_t offset = (Off_t)SvIVx(POPs);
2114 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2117 if (gv && (io = GvIO(gv))) {
2118 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2121 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2122 #if LSEEKSIZE > IVSIZE
2123 mXPUSHn((NV) offset);
2130 call_method("SEEK", G_SCALAR);
2137 if (PL_op->op_type == OP_SEEK)
2138 PUSHs(boolSV(do_seek(gv, offset, whence)));
2140 const Off_t sought = do_sysseek(gv, offset, whence);
2142 PUSHs(&PL_sv_undef);
2144 SV* const sv = sought ?
2145 #if LSEEKSIZE > IVSIZE
2150 : newSVpvn(zero_but_true, ZBTLEN);
2161 /* There seems to be no consensus on the length type of truncate()
2162 * and ftruncate(), both off_t and size_t have supporters. In
2163 * general one would think that when using large files, off_t is
2164 * at least as wide as size_t, so using an off_t should be okay. */
2165 /* XXX Configure probe for the length type of *truncate() needed XXX */
2168 #if Off_t_size > IVSIZE
2173 /* Checking for length < 0 is problematic as the type might or
2174 * might not be signed: if it is not, clever compilers will moan. */
2175 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2182 if (PL_op->op_flags & OPf_SPECIAL) {
2183 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2192 TAINT_PROPER("truncate");
2193 if (!(fp = IoIFP(io))) {
2199 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2201 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2208 SV * const sv = POPs;
2211 if (isGV_with_GP(sv)) {
2212 tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */
2213 goto do_ftruncate_gv;
2215 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2216 tmpgv = MUTABLE_GV(SvRV(sv)); /* \*main::FRED for example */
2217 goto do_ftruncate_gv;
2219 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2220 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2221 goto do_ftruncate_io;
2224 name = SvPV_nolen_const(sv);
2225 TAINT_PROPER("truncate");
2227 if (truncate(name, len) < 0)
2231 const int tmpfd = PerlLIO_open(name, O_RDWR);
2236 if (my_chsize(tmpfd, len) < 0)
2238 PerlLIO_close(tmpfd);
2247 SETERRNO(EBADF,RMS_IFI);
2255 SV * const argsv = POPs;
2256 const unsigned int func = POPu;
2257 const int optype = PL_op->op_type;
2258 GV * const gv = MUTABLE_GV(POPs);
2259 IO * const io = gv ? GvIOn(gv) : NULL;
2263 if (!io || !argsv || !IoIFP(io)) {
2264 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2265 report_evil_fh(gv, io, PL_op->op_type);
2266 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2270 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2273 s = SvPV_force(argsv, len);
2274 need = IOCPARM_LEN(func);
2276 s = Sv_Grow(argsv, need + 1);
2277 SvCUR_set(argsv, need);
2280 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2283 retval = SvIV(argsv);
2284 s = INT2PTR(char*,retval); /* ouch */
2287 TAINT_PROPER(PL_op_desc[optype]);
2289 if (optype == OP_IOCTL)
2291 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2293 DIE(aTHX_ "ioctl is not implemented");
2297 DIE(aTHX_ "fcntl is not implemented");
2299 #if defined(OS2) && defined(__EMX__)
2300 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2302 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2306 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2308 if (s[SvCUR(argsv)] != 17)
2309 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2311 s[SvCUR(argsv)] = 0; /* put our null back */
2312 SvSETMAGIC(argsv); /* Assume it has changed */
2321 PUSHp(zero_but_true, ZBTLEN);
2334 const int argtype = POPi;
2335 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
2337 if (gv && (io = GvIO(gv)))
2343 /* XXX Looks to me like io is always NULL at this point */
2345 (void)PerlIO_flush(fp);
2346 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2349 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2350 report_evil_fh(gv, io, PL_op->op_type);
2352 SETERRNO(EBADF,RMS_IFI);
2357 DIE(aTHX_ PL_no_func, "flock()");
2367 const int protocol = POPi;
2368 const int type = POPi;
2369 const int domain = POPi;
2370 GV * const gv = MUTABLE_GV(POPs);
2371 register IO * const io = gv ? GvIOn(gv) : NULL;
2375 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2376 report_evil_fh(gv, io, PL_op->op_type);
2377 if (io && IoIFP(io))
2378 do_close(gv, FALSE);
2379 SETERRNO(EBADF,LIB_INVARG);
2384 do_close(gv, FALSE);
2386 TAINT_PROPER("socket");
2387 fd = PerlSock_socket(domain, type, protocol);
2390 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2391 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2392 IoTYPE(io) = IoTYPE_SOCKET;
2393 if (!IoIFP(io) || !IoOFP(io)) {
2394 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2395 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2396 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2399 #if defined(HAS_FCNTL) && defined(F_SETFD)
2400 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2404 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2409 DIE(aTHX_ PL_no_sock_func, "socket");
2415 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2417 const int protocol = POPi;
2418 const int type = POPi;
2419 const int domain = POPi;
2420 GV * const gv2 = MUTABLE_GV(POPs);
2421 GV * const gv1 = MUTABLE_GV(POPs);
2422 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2423 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2426 if (!gv1 || !gv2 || !io1 || !io2) {
2427 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2429 report_evil_fh(gv1, io1, PL_op->op_type);
2431 report_evil_fh(gv1, io2, PL_op->op_type);
2433 if (io1 && IoIFP(io1))
2434 do_close(gv1, FALSE);
2435 if (io2 && IoIFP(io2))
2436 do_close(gv2, FALSE);
2441 do_close(gv1, FALSE);
2443 do_close(gv2, FALSE);
2445 TAINT_PROPER("socketpair");
2446 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2448 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2449 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2450 IoTYPE(io1) = IoTYPE_SOCKET;
2451 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2452 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2453 IoTYPE(io2) = IoTYPE_SOCKET;
2454 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2455 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2456 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2457 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2458 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2459 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2460 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2463 #if defined(HAS_FCNTL) && defined(F_SETFD)
2464 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2465 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2470 DIE(aTHX_ PL_no_sock_func, "socketpair");
2478 SV * const addrsv = POPs;
2479 /* OK, so on what platform does bind modify addr? */
2481 GV * const gv = MUTABLE_GV(POPs);
2482 register IO * const io = GvIOn(gv);
2485 if (!io || !IoIFP(io))
2488 addr = SvPV_const(addrsv, len);
2489 TAINT_PROPER("bind");
2490 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2496 if (ckWARN(WARN_CLOSED))
2497 report_evil_fh(gv, io, PL_op->op_type);
2498 SETERRNO(EBADF,SS_IVCHAN);
2501 DIE(aTHX_ PL_no_sock_func, "bind");
2509 SV * const addrsv = POPs;
2510 GV * const gv = MUTABLE_GV(POPs);
2511 register IO * const io = GvIOn(gv);
2515 if (!io || !IoIFP(io))
2518 addr = SvPV_const(addrsv, len);
2519 TAINT_PROPER("connect");
2520 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2526 if (ckWARN(WARN_CLOSED))
2527 report_evil_fh(gv, io, PL_op->op_type);
2528 SETERRNO(EBADF,SS_IVCHAN);
2531 DIE(aTHX_ PL_no_sock_func, "connect");
2539 const int backlog = POPi;
2540 GV * const gv = MUTABLE_GV(POPs);
2541 register IO * const io = gv ? GvIOn(gv) : NULL;
2543 if (!gv || !io || !IoIFP(io))
2546 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2552 if (ckWARN(WARN_CLOSED))
2553 report_evil_fh(gv, io, PL_op->op_type);
2554 SETERRNO(EBADF,SS_IVCHAN);
2557 DIE(aTHX_ PL_no_sock_func, "listen");
2567 char namebuf[MAXPATHLEN];
2568 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2569 Sock_size_t len = sizeof (struct sockaddr_in);
2571 Sock_size_t len = sizeof namebuf;
2573 GV * const ggv = MUTABLE_GV(POPs);
2574 GV * const ngv = MUTABLE_GV(POPs);
2583 if (!gstio || !IoIFP(gstio))
2587 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2590 /* Some platforms indicate zero length when an AF_UNIX client is
2591 * not bound. Simulate a non-zero-length sockaddr structure in
2593 namebuf[0] = 0; /* sun_len */
2594 namebuf[1] = AF_UNIX; /* sun_family */
2602 do_close(ngv, FALSE);
2603 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2604 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2605 IoTYPE(nstio) = IoTYPE_SOCKET;
2606 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2607 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2608 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2609 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2612 #if defined(HAS_FCNTL) && defined(F_SETFD)
2613 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2617 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2618 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2620 #ifdef __SCO_VERSION__
2621 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2624 PUSHp(namebuf, len);
2628 if (ckWARN(WARN_CLOSED))
2629 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2630 SETERRNO(EBADF,SS_IVCHAN);
2636 DIE(aTHX_ PL_no_sock_func, "accept");
2644 const int how = POPi;
2645 GV * const gv = MUTABLE_GV(POPs);
2646 register IO * const io = GvIOn(gv);
2648 if (!io || !IoIFP(io))
2651 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2655 if (ckWARN(WARN_CLOSED))
2656 report_evil_fh(gv, io, PL_op->op_type);
2657 SETERRNO(EBADF,SS_IVCHAN);
2660 DIE(aTHX_ PL_no_sock_func, "shutdown");
2668 const int optype = PL_op->op_type;
2669 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2670 const unsigned int optname = (unsigned int) POPi;
2671 const unsigned int lvl = (unsigned int) POPi;
2672 GV * const gv = MUTABLE_GV(POPs);
2673 register IO * const io = GvIOn(gv);
2677 if (!io || !IoIFP(io))
2680 fd = PerlIO_fileno(IoIFP(io));
2684 (void)SvPOK_only(sv);
2688 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2695 #if defined(__SYMBIAN32__)
2696 # define SETSOCKOPT_OPTION_VALUE_T void *
2698 # define SETSOCKOPT_OPTION_VALUE_T const char *
2700 /* XXX TODO: We need to have a proper type (a Configure probe,
2701 * etc.) for what the C headers think of the third argument of
2702 * setsockopt(), the option_value read-only buffer: is it
2703 * a "char *", or a "void *", const or not. Some compilers
2704 * don't take kindly to e.g. assuming that "char *" implicitly
2705 * promotes to a "void *", or to explicitly promoting/demoting
2706 * consts to non/vice versa. The "const void *" is the SUS
2707 * definition, but that does not fly everywhere for the above
2709 SETSOCKOPT_OPTION_VALUE_T buf;
2713 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2717 aint = (int)SvIV(sv);
2718 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2721 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2730 if (ckWARN(WARN_CLOSED))
2731 report_evil_fh(gv, io, optype);
2732 SETERRNO(EBADF,SS_IVCHAN);
2737 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2745 const int optype = PL_op->op_type;
2746 GV * const gv = MUTABLE_GV(POPs);
2747 register IO * const io = GvIOn(gv);
2752 if (!io || !IoIFP(io))
2755 sv = sv_2mortal(newSV(257));
2756 (void)SvPOK_only(sv);
2760 fd = PerlIO_fileno(IoIFP(io));
2762 case OP_GETSOCKNAME:
2763 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2766 case OP_GETPEERNAME:
2767 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2769 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2771 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";
2772 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2773 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2774 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2775 sizeof(u_short) + sizeof(struct in_addr))) {
2782 #ifdef BOGUS_GETNAME_RETURN
2783 /* Interactive Unix, getpeername() and getsockname()
2784 does not return valid namelen */
2785 if (len == BOGUS_GETNAME_RETURN)
2786 len = sizeof(struct sockaddr);
2794 if (ckWARN(WARN_CLOSED))
2795 report_evil_fh(gv, io, optype);
2796 SETERRNO(EBADF,SS_IVCHAN);
2801 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2816 if (PL_op->op_flags & OPf_REF) {
2818 if (PL_op->op_type == OP_LSTAT) {
2819 if (gv != PL_defgv) {
2820 do_fstat_warning_check:
2821 if (ckWARN(WARN_IO))
2822 Perl_warner(aTHX_ packWARN(WARN_IO),
2823 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2824 } else if (PL_laststype != OP_LSTAT)
2825 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2829 if (gv != PL_defgv) {
2830 PL_laststype = OP_STAT;
2832 sv_setpvs(PL_statname, "");
2839 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2840 } else if (IoDIRP(io)) {
2842 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2844 PL_laststatval = -1;
2850 if (PL_laststatval < 0) {
2851 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2852 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2857 SV* const sv = POPs;
2858 if (isGV_with_GP(sv)) {
2859 gv = MUTABLE_GV(sv);
2861 } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2862 gv = MUTABLE_GV(SvRV(sv));
2863 if (PL_op->op_type == OP_LSTAT)
2864 goto do_fstat_warning_check;
2866 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2867 io = MUTABLE_IO(SvRV(sv));
2868 if (PL_op->op_type == OP_LSTAT)
2869 goto do_fstat_warning_check;
2870 goto do_fstat_have_io;
2873 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2875 PL_laststype = PL_op->op_type;
2876 if (PL_op->op_type == OP_LSTAT)
2877 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2879 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2880 if (PL_laststatval < 0) {
2881 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2882 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2888 if (gimme != G_ARRAY) {
2889 if (gimme != G_VOID)
2890 XPUSHs(boolSV(max));
2896 mPUSHi(PL_statcache.st_dev);
2897 mPUSHi(PL_statcache.st_ino);
2898 mPUSHu(PL_statcache.st_mode);
2899 mPUSHu(PL_statcache.st_nlink);
2900 #if Uid_t_size > IVSIZE
2901 mPUSHn(PL_statcache.st_uid);
2903 # if Uid_t_sign <= 0
2904 mPUSHi(PL_statcache.st_uid);
2906 mPUSHu(PL_statcache.st_uid);
2909 #if Gid_t_size > IVSIZE
2910 mPUSHn(PL_statcache.st_gid);
2912 # if Gid_t_sign <= 0
2913 mPUSHi(PL_statcache.st_gid);
2915 mPUSHu(PL_statcache.st_gid);
2918 #ifdef USE_STAT_RDEV
2919 mPUSHi(PL_statcache.st_rdev);
2921 PUSHs(newSVpvs_flags("", SVs_TEMP));
2923 #if Off_t_size > IVSIZE
2924 mPUSHn(PL_statcache.st_size);
2926 mPUSHi(PL_statcache.st_size);
2929 mPUSHn(PL_statcache.st_atime);
2930 mPUSHn(PL_statcache.st_mtime);
2931 mPUSHn(PL_statcache.st_ctime);
2933 mPUSHi(PL_statcache.st_atime);
2934 mPUSHi(PL_statcache.st_mtime);
2935 mPUSHi(PL_statcache.st_ctime);
2937 #ifdef USE_STAT_BLOCKS
2938 mPUSHu(PL_statcache.st_blksize);
2939 mPUSHu(PL_statcache.st_blocks);
2941 PUSHs(newSVpvs_flags("", SVs_TEMP));
2942 PUSHs(newSVpvs_flags("", SVs_TEMP));
2948 /* This macro is used by the stacked filetest operators :
2949 * if the previous filetest failed, short-circuit and pass its value.
2950 * Else, discard it from the stack and continue. --rgs
2952 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2953 if (!SvTRUE(TOPs)) { RETURN; } \
2954 else { (void)POPs; PUTBACK; } \
2961 /* Not const, because things tweak this below. Not bool, because there's
2962 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2963 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2964 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2965 /* Giving some sort of initial value silences compilers. */
2967 int access_mode = R_OK;
2969 int access_mode = 0;
2972 /* access_mode is never used, but leaving use_access in makes the
2973 conditional compiling below much clearer. */
2976 int stat_mode = S_IRUSR;
2978 bool effective = FALSE;
2982 switch (PL_op->op_type) {
2983 case OP_FTRREAD: opchar = 'R'; break;
2984 case OP_FTRWRITE: opchar = 'W'; break;
2985 case OP_FTREXEC: opchar = 'X'; break;
2986 case OP_FTEREAD: opchar = 'r'; break;
2987 case OP_FTEWRITE: opchar = 'w'; break;
2988 case OP_FTEEXEC: opchar = 'x'; break;
2990 tryAMAGICftest(opchar);
2992 STACKED_FTEST_CHECK;
2994 switch (PL_op->op_type) {
2996 #if !(defined(HAS_ACCESS) && defined(R_OK))
3002 #if defined(HAS_ACCESS) && defined(W_OK)
3007 stat_mode = S_IWUSR;
3011 #if defined(HAS_ACCESS) && defined(X_OK)
3016 stat_mode = S_IXUSR;
3020 #ifdef PERL_EFF_ACCESS
3023 stat_mode = S_IWUSR;
3027 #ifndef PERL_EFF_ACCESS
3034 #ifdef PERL_EFF_ACCESS
3039 stat_mode = S_IXUSR;
3045 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3046 const char *name = POPpx;
3048 # ifdef PERL_EFF_ACCESS
3049 result = PERL_EFF_ACCESS(name, access_mode);
3051 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3057 result = access(name, access_mode);
3059 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3074 if (cando(stat_mode, effective, &PL_statcache))
3083 const int op_type = PL_op->op_type;
3088 case OP_FTIS: opchar = 'e'; break;
3089 case OP_FTSIZE: opchar = 's'; break;
3090 case OP_FTMTIME: opchar = 'M'; break;
3091 case OP_FTCTIME: opchar = 'C'; break;
3092 case OP_FTATIME: opchar = 'A'; break;
3094 tryAMAGICftest(opchar);
3096 STACKED_FTEST_CHECK;
3102 if (op_type == OP_FTIS)
3105 /* You can't dTARGET inside OP_FTIS, because you'll get
3106 "panic: pad_sv po" - the op is not flagged to have a target. */
3110 #if Off_t_size > IVSIZE
3111 PUSHn(PL_statcache.st_size);
3113 PUSHi(PL_statcache.st_size);
3117 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3120 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3123 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3137 switch (PL_op->op_type) {
3138 case OP_FTROWNED: opchar = 'O'; break;
3139 case OP_FTEOWNED: opchar = 'o'; break;
3140 case OP_FTZERO: opchar = 'z'; break;
3141 case OP_FTSOCK: opchar = 'S'; break;
3142 case OP_FTCHR: opchar = 'c'; break;
3143 case OP_FTBLK: opchar = 'b'; break;
3144 case OP_FTFILE: opchar = 'f'; break;
3145 case OP_FTDIR: opchar = 'd'; break;
3146 case OP_FTPIPE: opchar = 'p'; break;
3147 case OP_FTSUID: opchar = 'u'; break;
3148 case OP_FTSGID: opchar = 'g'; break;
3149 case OP_FTSVTX: opchar = 'k'; break;
3151 tryAMAGICftest(opchar);
3153 /* I believe that all these three are likely to be defined on most every
3154 system these days. */
3156 if(PL_op->op_type == OP_FTSUID)
3160 if(PL_op->op_type == OP_FTSGID)
3164 if(PL_op->op_type == OP_FTSVTX)
3168 STACKED_FTEST_CHECK;
3174 switch (PL_op->op_type) {
3176 if (PL_statcache.st_uid == PL_uid)
3180 if (PL_statcache.st_uid == PL_euid)
3184 if (PL_statcache.st_size == 0)
3188 if (S_ISSOCK(PL_statcache.st_mode))
3192 if (S_ISCHR(PL_statcache.st_mode))
3196 if (S_ISBLK(PL_statcache.st_mode))
3200 if (S_ISREG(PL_statcache.st_mode))
3204 if (S_ISDIR(PL_statcache.st_mode))
3208 if (S_ISFIFO(PL_statcache.st_mode))
3213 if (PL_statcache.st_mode & S_ISUID)
3219 if (PL_statcache.st_mode & S_ISGID)
3225 if (PL_statcache.st_mode & S_ISVTX)
3239 tryAMAGICftest('l');
3240 result = my_lstat();
3245 if (S_ISLNK(PL_statcache.st_mode))
3258 tryAMAGICftest('t');
3260 STACKED_FTEST_CHECK;
3262 if (PL_op->op_flags & OPf_REF)
3264 else if (isGV(TOPs))
3265 gv = MUTABLE_GV(POPs);
3266 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3267 gv = MUTABLE_GV(SvRV(POPs));
3269 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3271 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3272 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3273 else if (tmpsv && SvOK(tmpsv)) {
3274 const char *tmps = SvPV_nolen_const(tmpsv);
3282 if (PerlLIO_isatty(fd))
3287 #if defined(atarist) /* this will work with atariST. Configure will
3288 make guesses for other systems. */
3289 # define FILE_base(f) ((f)->_base)
3290 # define FILE_ptr(f) ((f)->_ptr)
3291 # define FILE_cnt(f) ((f)->_cnt)
3292 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3303 register STDCHAR *s;
3309 tryAMAGICftest(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3311 STACKED_FTEST_CHECK;
3313 if (PL_op->op_flags & OPf_REF)
3315 else if (isGV(TOPs))
3316 gv = MUTABLE_GV(POPs);
3317 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3318 gv = MUTABLE_GV(SvRV(POPs));
3324 if (gv == PL_defgv) {
3326 io = GvIO(PL_statgv);
3329 goto really_filename;
3334 PL_laststatval = -1;
3335 sv_setpvs(PL_statname, "");
3336 io = GvIO(PL_statgv);
3338 if (io && IoIFP(io)) {
3339 if (! PerlIO_has_base(IoIFP(io)))
3340 DIE(aTHX_ "-T and -B not implemented on filehandles");
3341 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3342 if (PL_laststatval < 0)
3344 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3345 if (PL_op->op_type == OP_FTTEXT)
3350 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3351 i = PerlIO_getc(IoIFP(io));
3353 (void)PerlIO_ungetc(IoIFP(io),i);
3355 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3357 len = PerlIO_get_bufsiz(IoIFP(io));
3358 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3359 /* sfio can have large buffers - limit to 512 */
3364 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3366 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3368 SETERRNO(EBADF,RMS_IFI);
3376 PL_laststype = OP_STAT;
3377 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3378 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3379 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3381 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3384 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3385 if (PL_laststatval < 0) {
3386 (void)PerlIO_close(fp);
3389 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3390 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3391 (void)PerlIO_close(fp);
3393 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3394 RETPUSHNO; /* special case NFS directories */
3395 RETPUSHYES; /* null file is anything */
3400 /* now scan s to look for textiness */
3401 /* XXX ASCII dependent code */
3403 #if defined(DOSISH) || defined(USEMYBINMODE)
3404 /* ignore trailing ^Z on short files */
3405 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3409 for (i = 0; i < len; i++, s++) {
3410 if (!*s) { /* null never allowed in text */
3415 else if (!(isPRINT(*s) || isSPACE(*s)))
3418 else if (*s & 128) {
3420 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3423 /* utf8 characters don't count as odd */
3424 if (UTF8_IS_START(*s)) {
3425 int ulen = UTF8SKIP(s);
3426 if (ulen < len - i) {
3428 for (j = 1; j < ulen; j++) {
3429 if (!UTF8_IS_CONTINUATION(s[j]))
3432 --ulen; /* loop does extra increment */
3442 *s != '\n' && *s != '\r' && *s != '\b' &&
3443 *s != '\t' && *s != '\f' && *s != 27)
3448 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3459 const char *tmps = NULL;
3463 SV * const sv = POPs;
3464 if (PL_op->op_flags & OPf_SPECIAL) {
3465 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3467 else if (isGV_with_GP(sv)) {
3468 gv = MUTABLE_GV(sv);
3470 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
3471 gv = MUTABLE_GV(SvRV(sv));
3474 tmps = SvPV_nolen_const(sv);
3478 if( !gv && (!tmps || !*tmps) ) {
3479 HV * const table = GvHVn(PL_envgv);
3482 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3483 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3485 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3490 deprecate("chdir('') or chdir(undef) as chdir()");
3491 tmps = SvPV_nolen_const(*svp);
3495 TAINT_PROPER("chdir");
3500 TAINT_PROPER("chdir");
3503 IO* const io = GvIO(gv);
3506 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3507 } else if (IoIFP(io)) {
3508 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3511 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3512 report_evil_fh(gv, io, PL_op->op_type);
3513 SETERRNO(EBADF, RMS_IFI);
3518 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3519 report_evil_fh(gv, io, PL_op->op_type);
3520 SETERRNO(EBADF,RMS_IFI);
3524 DIE(aTHX_ PL_no_func, "fchdir");
3528 PUSHi( PerlDir_chdir(tmps) >= 0 );
3530 /* Clear the DEFAULT element of ENV so we'll get the new value
3532 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3539 dVAR; dSP; dMARK; dTARGET;
3540 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3551 char * const tmps = POPpx;
3552 TAINT_PROPER("chroot");
3553 PUSHi( chroot(tmps) >= 0 );
3556 DIE(aTHX_ PL_no_func, "chroot");
3564 const char * const tmps2 = POPpconstx;
3565 const char * const tmps = SvPV_nolen_const(TOPs);
3566 TAINT_PROPER("rename");
3568 anum = PerlLIO_rename(tmps, tmps2);
3570 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3571 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3574 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3575 (void)UNLINK(tmps2);
3576 if (!(anum = link(tmps, tmps2)))
3577 anum = UNLINK(tmps);
3585 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3589 const int op_type = PL_op->op_type;
3593 if (op_type == OP_LINK)
3594 DIE(aTHX_ PL_no_func, "link");
3596 # ifndef HAS_SYMLINK
3597 if (op_type == OP_SYMLINK)
3598 DIE(aTHX_ PL_no_func, "symlink");
3602 const char * const tmps2 = POPpconstx;
3603 const char * const tmps = SvPV_nolen_const(TOPs);
3604 TAINT_PROPER(PL_op_desc[op_type]);
3606 # if defined(HAS_LINK)
3607 # if defined(HAS_SYMLINK)
3608 /* Both present - need to choose which. */
3609 (op_type == OP_LINK) ?
3610 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3612 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3613 PerlLIO_link(tmps, tmps2);
3616 # if defined(HAS_SYMLINK)
3617 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3618 symlink(tmps, tmps2);
3623 SETi( result >= 0 );
3630 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3641 char buf[MAXPATHLEN];
3644 #ifndef INCOMPLETE_TAINTS
3648 len = readlink(tmps, buf, sizeof(buf) - 1);
3656 RETSETUNDEF; /* just pretend it's a normal file */
3660 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3662 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3664 char * const save_filename = filename;
3669 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3671 PERL_ARGS_ASSERT_DOONELINER;
3673 Newx(cmdline, size, char);
3674 my_strlcpy(cmdline, cmd, size);
3675 my_strlcat(cmdline, " ", size);
3676 for (s = cmdline + strlen(cmdline); *filename; ) {
3680 if (s - cmdline < size)
3681 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3682 myfp = PerlProc_popen(cmdline, "r");
3686 SV * const tmpsv = sv_newmortal();
3687 /* Need to save/restore 'PL_rs' ?? */
3688 s = sv_gets(tmpsv, myfp, 0);
3689 (void)PerlProc_pclose(myfp);
3693 #ifdef HAS_SYS_ERRLIST
3698 /* you don't see this */
3699 const char * const errmsg =
3700 #ifdef HAS_SYS_ERRLIST
3708 if (instr(s, errmsg)) {
3715 #define EACCES EPERM
3717 if (instr(s, "cannot make"))
3718 SETERRNO(EEXIST,RMS_FEX);
3719 else if (instr(s, "existing file"))
3720 SETERRNO(EEXIST,RMS_FEX);
3721 else if (instr(s, "ile exists"))
3722 SETERRNO(EEXIST,RMS_FEX);
3723 else if (instr(s, "non-exist"))
3724 SETERRNO(ENOENT,RMS_FNF);
3725 else if (instr(s, "does not exist"))
3726 SETERRNO(ENOENT,RMS_FNF);
3727 else if (instr(s, "not empty"))
3728 SETERRNO(EBUSY,SS_DEVOFFLINE);
3729 else if (instr(s, "cannot access"))
3730 SETERRNO(EACCES,RMS_PRV);
3732 SETERRNO(EPERM,RMS_PRV);
3735 else { /* some mkdirs return no failure indication */
3736 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3737 if (PL_op->op_type == OP_RMDIR)
3742 SETERRNO(EACCES,RMS_PRV); /* a guess */
3751 /* This macro removes trailing slashes from a directory name.
3752 * Different operating and file systems take differently to
3753 * trailing slashes. According to POSIX 1003.1 1996 Edition
3754 * any number of trailing slashes should be allowed.
3755 * Thusly we snip them away so that even non-conforming
3756 * systems are happy.
3757 * We should probably do this "filtering" for all
3758 * the functions that expect (potentially) directory names:
3759 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3760 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3762 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3763 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3766 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3767 (tmps) = savepvn((tmps), (len)); \
3777 const int mode = (MAXARG > 1) ? POPi : 0777;
3779 TRIMSLASHES(tmps,len,copy);
3781 TAINT_PROPER("mkdir");
3783 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3787 SETi( dooneliner("mkdir", tmps) );
3788 oldumask = PerlLIO_umask(0);
3789 PerlLIO_umask(oldumask);
3790 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3805 TRIMSLASHES(tmps,len,copy);
3806 TAINT_PROPER("rmdir");
3808 SETi( PerlDir_rmdir(tmps) >= 0 );
3810 SETi( dooneliner("rmdir", tmps) );
3817 /* Directory calls. */
3821 #if defined(Direntry_t) && defined(HAS_READDIR)
3823 const char * const dirname = POPpconstx;
3824 GV * const gv = MUTABLE_GV(POPs);
3825 register IO * const io = GvIOn(gv);
3830 if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED))
3831 Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3832 "Opening filehandle %s also as a directory", GvENAME(gv));
3834 PerlDir_close(IoDIRP(io));
3835 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3841 SETERRNO(EBADF,RMS_DIR);
3844 DIE(aTHX_ PL_no_dir_func, "opendir");
3850 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3851 DIE(aTHX_ PL_no_dir_func, "readdir");
3853 #if !defined(I_DIRENT) && !defined(VMS)
3854 Direntry_t *readdir (DIR *);
3860 const I32 gimme = GIMME;
3861 GV * const gv = MUTABLE_GV(POPs);
3862 register const Direntry_t *dp;
3863 register IO * const io = GvIOn(gv);
3865 if (!io || !IoDIRP(io)) {
3866 if(ckWARN(WARN_IO)) {
3867 Perl_warner(aTHX_ packWARN(WARN_IO),
3868 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3874 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3878 sv = newSVpvn(dp->d_name, dp->d_namlen);
3880 sv = newSVpv(dp->d_name, 0);
3882 #ifndef INCOMPLETE_TAINTS
3883 if (!(IoFLAGS(io) & IOf_UNTAINT))
3887 } while (gimme == G_ARRAY);
3889 if (!dp && gimme != G_ARRAY)
3896 SETERRNO(EBADF,RMS_ISI);
3897 if (GIMME == G_ARRAY)
3906 #if defined(HAS_TELLDIR) || defined(telldir)
3908 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3909 /* XXX netbsd still seemed to.
3910 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3911 --JHI 1999-Feb-02 */
3912 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3913 long telldir (DIR *);
3915 GV * const gv = MUTABLE_GV(POPs);
3916 register IO * const io = GvIOn(gv);
3918 if (!io || !IoDIRP(io)) {
3919 if(ckWARN(WARN_IO)) {
3920 Perl_warner(aTHX_ packWARN(WARN_IO),
3921 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3926 PUSHi( PerlDir_tell(IoDIRP(io)) );
3930 SETERRNO(EBADF,RMS_ISI);
3933 DIE(aTHX_ PL_no_dir_func, "telldir");
3939 #if defined(HAS_SEEKDIR) || defined(seekdir)
3941 const long along = POPl;
3942 GV * const gv = MUTABLE_GV(POPs);
3943 register IO * const io = GvIOn(gv);
3945 if (!io || !IoDIRP(io)) {
3946 if(ckWARN(WARN_IO)) {
3947 Perl_warner(aTHX_ packWARN(WARN_IO),
3948 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3952 (void)PerlDir_seek(IoDIRP(io), along);
3957 SETERRNO(EBADF,RMS_ISI);
3960 DIE(aTHX_ PL_no_dir_func, "seekdir");
3966 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3968 GV * const gv = MUTABLE_GV(POPs);
3969 register IO * const io = GvIOn(gv);
3971 if (!io || !IoDIRP(io)) {
3972 if(ckWARN(WARN_IO)) {
3973 Perl_warner(aTHX_ packWARN(WARN_IO),
3974 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3978 (void)PerlDir_rewind(IoDIRP(io));
3982 SETERRNO(EBADF,RMS_ISI);
3985 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3991 #if defined(Direntry_t) && defined(HAS_READDIR)
3993 GV * const gv = MUTABLE_GV(POPs);
3994 register IO * const io = GvIOn(gv);
3996 if (!io || !IoDIRP(io)) {
3997 if(ckWARN(WARN_IO)) {
3998 Perl_warner(aTHX_ packWARN(WARN_IO),
3999 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
4003 #ifdef VOID_CLOSEDIR
4004 PerlDir_close(IoDIRP(io));
4006 if (PerlDir_close(IoDIRP(io)) < 0) {
4007 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4016 SETERRNO(EBADF,RMS_IFI);
4019 DIE(aTHX_ PL_no_dir_func, "closedir");
4023 /* Process control. */
4032 PERL_FLUSHALL_FOR_CHILD;
4033 childpid = PerlProc_fork();
4037 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
4039 SvREADONLY_off(GvSV(tmpgv));
4040 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4041 SvREADONLY_on(GvSV(tmpgv));
4043 #ifdef THREADS_HAVE_PIDS
4044 PL_ppid = (IV)getppid();
4046 #ifdef PERL_USES_PL_PIDSTATUS
4047 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4053 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4058 PERL_FLUSHALL_FOR_CHILD;
4059 childpid = PerlProc_fork();
4065 DIE(aTHX_ PL_no_func, "fork");
4072 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4077 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4078 childpid = wait4pid(-1, &argflags, 0);
4080 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4085 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4086 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4087 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4089 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4094 DIE(aTHX_ PL_no_func, "wait");
4100 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4102 const int optype = POPi;
4103 const Pid_t pid = TOPi;
4107 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4108 result = wait4pid(pid, &argflags, optype);
4110 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4115 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4116 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4117 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4119 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4124 DIE(aTHX_ PL_no_func, "waitpid");
4130 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4131 #if defined(__LIBCATAMOUNT__)
4132 PL_statusvalue = -1;
4141 while (++MARK <= SP) {
4142 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4147 TAINT_PROPER("system");
4149 PERL_FLUSHALL_FOR_CHILD;
4150 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4156 if (PerlProc_pipe(pp) >= 0)
4158 while ((childpid = PerlProc_fork()) == -1) {
4159 if (errno != EAGAIN) {
4164 PerlLIO_close(pp[0]);
4165 PerlLIO_close(pp[1]);
4172 Sigsave_t ihand,qhand; /* place to save signals during system() */
4176 PerlLIO_close(pp[1]);
4178 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4179 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4182 result = wait4pid(childpid, &status, 0);
4183 } while (result == -1 && errno == EINTR);
4185 (void)rsignal_restore(SIGINT, &ihand);
4186 (void)rsignal_restore(SIGQUIT, &qhand);
4188 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4189 do_execfree(); /* free any memory child malloced on fork */
4196 while (n < sizeof(int)) {
4197 n1 = PerlLIO_read(pp[0],
4198 (void*)(((char*)&errkid)+n),
4204 PerlLIO_close(pp[0]);
4205 if (n) { /* Error */
4206 if (n != sizeof(int))
4207 DIE(aTHX_ "panic: kid popen errno read");
4208 errno = errkid; /* Propagate errno from kid */
4209 STATUS_NATIVE_CHILD_SET(-1);
4212 XPUSHi(STATUS_CURRENT);
4216 PerlLIO_close(pp[0]);
4217 #if defined(HAS_FCNTL) && defined(F_SETFD)
4218 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4221 if (PL_op->op_flags & OPf_STACKED) {
4222 SV * const really = *++MARK;
4223 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4225 else if (SP - MARK != 1)
4226 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4228 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4232 #else /* ! FORK or VMS or OS/2 */
4235 if (PL_op->op_flags & OPf_STACKED) {
4236 SV * const really = *++MARK;
4237 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4238 value = (I32)do_aspawn(really, MARK, SP);
4240 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4243 else if (SP - MARK != 1) {
4244 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4245 value = (I32)do_aspawn(NULL, MARK, SP);
4247 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4251 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4253 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4255 STATUS_NATIVE_CHILD_SET(value);
4258 XPUSHi(result ? value : STATUS_CURRENT);
4259 #endif /* !FORK or VMS or OS/2 */
4266 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4271 while (++MARK <= SP) {
4272 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4277 TAINT_PROPER("exec");
4279 PERL_FLUSHALL_FOR_CHILD;
4280 if (PL_op->op_flags & OPf_STACKED) {
4281 SV * const really = *++MARK;
4282 value = (I32)do_aexec(really, MARK, SP);
4284 else if (SP - MARK != 1)
4286 value = (I32)vms_do_aexec(NULL, MARK, SP);
4290 (void ) do_aspawn(NULL, MARK, SP);
4294 value = (I32)do_aexec(NULL, MARK, SP);
4299 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4302 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4305 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4319 # ifdef THREADS_HAVE_PIDS
4320 if (PL_ppid != 1 && getppid() == 1)
4321 /* maybe the parent process has died. Refresh ppid cache */
4325 XPUSHi( getppid() );
4329 DIE(aTHX_ PL_no_func, "getppid");
4338 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4341 pgrp = (I32)BSD_GETPGRP(pid);
4343 if (pid != 0 && pid != PerlProc_getpid())
4344 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4350 DIE(aTHX_ PL_no_func, "getpgrp()");
4370 TAINT_PROPER("setpgrp");
4372 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4374 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4375 || (pid != 0 && pid != PerlProc_getpid()))
4377 DIE(aTHX_ "setpgrp can't take arguments");
4379 SETi( setpgrp() >= 0 );
4380 #endif /* USE_BSDPGRP */
4383 DIE(aTHX_ PL_no_func, "setpgrp()");
4389 #ifdef HAS_GETPRIORITY
4391 const int who = POPi;
4392 const int which = TOPi;
4393 SETi( getpriority(which, who) );
4396 DIE(aTHX_ PL_no_func, "getpriority()");
4402 #ifdef HAS_SETPRIORITY
4404 const int niceval = POPi;
4405 const int who = POPi;
4406 const int which = TOPi;
4407 TAINT_PROPER("setpriority");
4408 SETi( setpriority(which, who, niceval) >= 0 );
4411 DIE(aTHX_ PL_no_func, "setpriority()");
4421 XPUSHn( time(NULL) );
4423 XPUSHi( time(NULL) );
4435 (void)PerlProc_times(&PL_timesbuf);
4437 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4438 /* struct tms, though same data */
4442 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4443 if (GIMME == G_ARRAY) {
4444 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4445 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4446 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4454 if (GIMME == G_ARRAY) {
4461 DIE(aTHX_ "times not implemented");
4463 #endif /* HAS_TIMES */
4473 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4474 static const char * const dayname[] =
4475 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4476 static const char * const monname[] =
4477 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4478 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4483 when = (Time64_T)now;
4486 double input = Perl_floor(POPn);
4487 when = (Time64_T)input;
4488 if (when != input && ckWARN(WARN_OVERFLOW)) {
4489 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4490 "%s(%.0f) too large", opname, input);
4494 if (PL_op->op_type == OP_LOCALTIME)
4495 err = S_localtime64_r(&when, &tmbuf);
4497 err = S_gmtime64_r(&when, &tmbuf);
4499 if (err == NULL && ckWARN(WARN_OVERFLOW)) {
4500 /* XXX %lld broken for quads */
4501 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4502 "%s(%.0f) failed", opname, (double)when);
4505 if (GIMME != G_ARRAY) { /* scalar context */
4507 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4508 double year = (double)tmbuf.tm_year + 1900;
4515 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4516 dayname[tmbuf.tm_wday],
4517 monname[tmbuf.tm_mon],
4525 else { /* list context */
4531 mPUSHi(tmbuf.tm_sec);
4532 mPUSHi(tmbuf.tm_min);
4533 mPUSHi(tmbuf.tm_hour);
4534 mPUSHi(tmbuf.tm_mday);
4535 mPUSHi(tmbuf.tm_mon);
4536 mPUSHn(tmbuf.tm_year);
4537 mPUSHi(tmbuf.tm_wday);
4538 mPUSHi(tmbuf.tm_yday);
4539 mPUSHi(tmbuf.tm_isdst);
4550 anum = alarm((unsigned int)anum);
4557 DIE(aTHX_ PL_no_func, "alarm");
4568 (void)time(&lasttime);
4573 PerlProc_sleep((unsigned int)duration);
4576 XPUSHi(when - lasttime);
4580 /* Shared memory. */
4581 /* Merged with some message passing. */
4585 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4586 dVAR; dSP; dMARK; dTARGET;
4587 const int op_type = PL_op->op_type;
4592 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4595 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4598 value = (I32)(do_semop(MARK, SP) >= 0);
4601 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4617 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4618 dVAR; dSP; dMARK; dTARGET;
4619 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4626 DIE(aTHX_ "System V IPC is not implemented on this machine");
4632 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4633 dVAR; dSP; dMARK; dTARGET;
4634 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4642 PUSHp(zero_but_true, ZBTLEN);
4650 /* I can't const this further without getting warnings about the types of
4651 various arrays passed in from structures. */
4653 S_space_join_names_mortal(pTHX_ char *const *array)
4657 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4659 if (array && *array) {
4660 target = newSVpvs_flags("", SVs_TEMP);
4662 sv_catpv(target, *array);
4665 sv_catpvs(target, " ");
4668 target = sv_mortalcopy(&PL_sv_no);
4673 /* Get system info. */
4677 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4679 I32 which = PL_op->op_type;
4680 register char **elem;
4682 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4683 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4684 struct hostent *gethostbyname(Netdb_name_t);
4685 struct hostent *gethostent(void);
4687 struct hostent *hent;
4691 if (which == OP_GHBYNAME) {
4692 #ifdef HAS_GETHOSTBYNAME
4693 const char* const name = POPpbytex;
4694 hent = PerlSock_gethostbyname(name);
4696 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4699 else if (which == OP_GHBYADDR) {
4700 #ifdef HAS_GETHOSTBYADDR
4701 const int addrtype = POPi;
4702 SV * const addrsv = POPs;
4704 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4706 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4708 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4712 #ifdef HAS_GETHOSTENT
4713 hent = PerlSock_gethostent();
4715 DIE(aTHX_ PL_no_sock_func, "gethostent");
4718 #ifdef HOST_NOT_FOUND
4720 #ifdef USE_REENTRANT_API
4721 # ifdef USE_GETHOSTENT_ERRNO
4722 h_errno = PL_reentrant_buffer->_gethostent_errno;
4725 STATUS_UNIX_SET(h_errno);
4729 if (GIMME != G_ARRAY) {
4730 PUSHs(sv = sv_newmortal());
4732 if (which == OP_GHBYNAME) {
4734 sv_setpvn(sv, hent->h_addr, hent->h_length);
4737 sv_setpv(sv, (char*)hent->h_name);
4743 mPUSHs(newSVpv((char*)hent->h_name, 0));
4744 PUSHs(space_join_names_mortal(hent->h_aliases));
4745 mPUSHi(hent->h_addrtype);
4746 len = hent->h_length;
4749 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4750 mXPUSHp(*elem, len);
4754 mPUSHp(hent->h_addr, len);
4756 PUSHs(sv_mortalcopy(&PL_sv_no));
4761 DIE(aTHX_ PL_no_sock_func, "gethostent");
4767 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4769 I32 which = PL_op->op_type;
4771 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4772 struct netent *getnetbyaddr(Netdb_net_t, int);
4773 struct netent *getnetbyname(Netdb_name_t);
4774 struct netent *getnetent(void);
4776 struct netent *nent;
4778 if (which == OP_GNBYNAME){
4779 #ifdef HAS_GETNETBYNAME
4780 const char * const name = POPpbytex;
4781 nent = PerlSock_getnetbyname(name);
4783 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4786 else if (which == OP_GNBYADDR) {
4787 #ifdef HAS_GETNETBYADDR
4788 const int addrtype = POPi;
4789 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4790 nent = PerlSock_getnetbyaddr(addr, addrtype);
4792 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4796 #ifdef HAS_GETNETENT
4797 nent = PerlSock_getnetent();
4799 DIE(aTHX_ PL_no_sock_func, "getnetent");
4802 #ifdef HOST_NOT_FOUND
4804 #ifdef USE_REENTRANT_API
4805 # ifdef USE_GETNETENT_ERRNO
4806 h_errno = PL_reentrant_buffer->_getnetent_errno;
4809 STATUS_UNIX_SET(h_errno);
4814 if (GIMME != G_ARRAY) {
4815 PUSHs(sv = sv_newmortal());
4817 if (which == OP_GNBYNAME)
4818 sv_setiv(sv, (IV)nent->n_net);
4820 sv_setpv(sv, nent->n_name);
4826 mPUSHs(newSVpv(nent->n_name, 0));
4827 PUSHs(space_join_names_mortal(nent->n_aliases));
4828 mPUSHi(nent->n_addrtype);
4829 mPUSHi(nent->n_net);
4834 DIE(aTHX_ PL_no_sock_func, "getnetent");
4840 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4842 I32 which = PL_op->op_type;
4844 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4845 struct protoent *getprotobyname(Netdb_name_t);
4846 struct protoent *getprotobynumber(int);
4847 struct protoent *getprotoent(void);
4849 struct protoent *pent;
4851 if (which == OP_GPBYNAME) {
4852 #ifdef HAS_GETPROTOBYNAME
4853 const char* const name = POPpbytex;
4854 pent = PerlSock_getprotobyname(name);
4856 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4859 else if (which == OP_GPBYNUMBER) {
4860 #ifdef HAS_GETPROTOBYNUMBER
4861 const int number = POPi;
4862 pent = PerlSock_getprotobynumber(number);
4864 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4868 #ifdef HAS_GETPROTOENT
4869 pent = PerlSock_getprotoent();
4871 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4875 if (GIMME != G_ARRAY) {
4876 PUSHs(sv = sv_newmortal());
4878 if (which == OP_GPBYNAME)
4879 sv_setiv(sv, (IV)pent->p_proto);
4881 sv_setpv(sv, pent->p_name);
4887 mPUSHs(newSVpv(pent->p_name, 0));
4888 PUSHs(space_join_names_mortal(pent->p_aliases));
4889 mPUSHi(pent->p_proto);
4894 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4900 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4902 I32 which = PL_op->op_type;
4904 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4905 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4906 struct servent *getservbyport(int, Netdb_name_t);
4907 struct servent *getservent(void);
4909 struct servent *sent;
4911 if (which == OP_GSBYNAME) {
4912 #ifdef HAS_GETSERVBYNAME
4913 const char * const proto = POPpbytex;
4914 const char * const name = POPpbytex;
4915 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4917 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4920 else if (which == OP_GSBYPORT) {
4921 #ifdef HAS_GETSERVBYPORT
4922 const char * const proto = POPpbytex;
4923 unsigned short port = (unsigned short)POPu;
4925 port = PerlSock_htons(port);
4927 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4929 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4933 #ifdef HAS_GETSERVENT
4934 sent = PerlSock_getservent();
4936 DIE(aTHX_ PL_no_sock_func, "getservent");
4940 if (GIMME != G_ARRAY) {
4941 PUSHs(sv = sv_newmortal());
4943 if (which == OP_GSBYNAME) {
4945 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4947 sv_setiv(sv, (IV)(sent->s_port));
4951 sv_setpv(sv, sent->s_name);
4957 mPUSHs(newSVpv(sent->s_name, 0));
4958 PUSHs(space_join_names_mortal(sent->s_aliases));
4960 mPUSHi(PerlSock_ntohs(sent->s_port));
4962 mPUSHi(sent->s_port);
4964 mPUSHs(newSVpv(sent->s_proto, 0));
4969 DIE(aTHX_ PL_no_sock_func, "getservent");
4975 #ifdef HAS_SETHOSTENT
4977 PerlSock_sethostent(TOPi);
4980 DIE(aTHX_ PL_no_sock_func, "sethostent");
4986 #ifdef HAS_SETNETENT
4988 (void)PerlSock_setnetent(TOPi);
4991 DIE(aTHX_ PL_no_sock_func, "setnetent");
4997 #ifdef HAS_SETPROTOENT
4999 (void)PerlSock_setprotoent(TOPi);
5002 DIE(aTHX_ PL_no_sock_func, "setprotoent");
5008 #ifdef HAS_SETSERVENT
5010 (void)PerlSock_setservent(TOPi);
5013 DIE(aTHX_ PL_no_sock_func, "setservent");
5019 #ifdef HAS_ENDHOSTENT
5021 PerlSock_endhostent();
5025 DIE(aTHX_ PL_no_sock_func, "endhostent");
5031 #ifdef HAS_ENDNETENT
5033 PerlSock_endnetent();
5037 DIE(aTHX_ PL_no_sock_func, "endnetent");
5043 #ifdef HAS_ENDPROTOENT
5045 PerlSock_endprotoent();
5049 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5055 #ifdef HAS_ENDSERVENT
5057 PerlSock_endservent();
5061 DIE(aTHX_ PL_no_sock_func, "endservent");
5069 I32 which = PL_op->op_type;
5071 struct passwd *pwent = NULL;
5073 * We currently support only the SysV getsp* shadow password interface.
5074 * The interface is declared in <shadow.h> and often one needs to link
5075 * with -lsecurity or some such.
5076 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5079 * AIX getpwnam() is clever enough to return the encrypted password
5080 * only if the caller (euid?) is root.
5082 * There are at least three other shadow password APIs. Many platforms
5083 * seem to contain more than one interface for accessing the shadow
5084 * password databases, possibly for compatibility reasons.
5085 * The getsp*() is by far he simplest one, the other two interfaces
5086 * are much more complicated, but also very similar to each other.
5091 * struct pr_passwd *getprpw*();
5092 * The password is in
5093 * char getprpw*(...).ufld.fd_encrypt[]
5094 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5099 * struct es_passwd *getespw*();
5100 * The password is in
5101 * char *(getespw*(...).ufld.fd_encrypt)
5102 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5105 * struct userpw *getuserpw();
5106 * The password is in
5107 * char *(getuserpw(...)).spw_upw_passwd
5108 * (but the de facto standard getpwnam() should work okay)
5110 * Mention I_PROT here so that Configure probes for it.
5112 * In HP-UX for getprpw*() the manual page claims that one should include
5113 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5114 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5115 * and pp_sys.c already includes <shadow.h> if there is such.
5117 * Note that <sys/security.h> is already probed for, but currently
5118 * it is only included in special cases.
5120 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5121 * be preferred interface, even though also the getprpw*() interface
5122 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5123 * One also needs to call set_auth_parameters() in main() before
5124 * doing anything else, whether one is using getespw*() or getprpw*().
5126 * Note that accessing the shadow databases can be magnitudes
5127 * slower than accessing the standard databases.
5132 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5133 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5134 * the pw_comment is left uninitialized. */
5135 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5141 const char* const name = POPpbytex;
5142 pwent = getpwnam(name);
5148 pwent = getpwuid(uid);
5152 # ifdef HAS_GETPWENT
5154 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5155 if (pwent) pwent = getpwnam(pwent->pw_name);
5158 DIE(aTHX_ PL_no_func, "getpwent");
5164 if (GIMME != G_ARRAY) {
5165 PUSHs(sv = sv_newmortal());
5167 if (which == OP_GPWNAM)
5168 # if Uid_t_sign <= 0
5169 sv_setiv(sv, (IV)pwent->pw_uid);
5171 sv_setuv(sv, (UV)pwent->pw_uid);
5174 sv_setpv(sv, pwent->pw_name);
5180 mPUSHs(newSVpv(pwent->pw_name, 0));
5184 /* If we have getspnam(), we try to dig up the shadow
5185 * password. If we are underprivileged, the shadow
5186 * interface will set the errno to EACCES or similar,
5187 * and return a null pointer. If this happens, we will
5188 * use the dummy password (usually "*" or "x") from the
5189 * standard password database.
5191 * In theory we could skip the shadow call completely
5192 * if euid != 0 but in practice we cannot know which
5193 * security measures are guarding the shadow databases
5194 * on a random platform.
5196 * Resist the urge to use additional shadow interfaces.
5197 * Divert the urge to writing an extension instead.
5200 /* Some AIX setups falsely(?) detect some getspnam(), which
5201 * has a different API than the Solaris/IRIX one. */
5202 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5205 const struct spwd * const spwent = getspnam(pwent->pw_name);
5206 /* Save and restore errno so that
5207 * underprivileged attempts seem
5208 * to have never made the unsccessful
5209 * attempt to retrieve the shadow password. */
5211 if (spwent && spwent->sp_pwdp)
5212 sv_setpv(sv, spwent->sp_pwdp);
5216 if (!SvPOK(sv)) /* Use the standard password, then. */
5217 sv_setpv(sv, pwent->pw_passwd);
5220 # ifndef INCOMPLETE_TAINTS
5221 /* passwd is tainted because user himself can diddle with it.
5222 * admittedly not much and in a very limited way, but nevertheless. */
5226 # if Uid_t_sign <= 0
5227 mPUSHi(pwent->pw_uid);
5229 mPUSHu(pwent->pw_uid);
5232 # if Uid_t_sign <= 0
5233 mPUSHi(pwent->pw_gid);
5235 mPUSHu(pwent->pw_gid);
5237 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5238 * because of the poor interface of the Perl getpw*(),
5239 * not because there's some standard/convention saying so.
5240 * A better interface would have been to return a hash,
5241 * but we are accursed by our history, alas. --jhi. */
5243 mPUSHi(pwent->pw_change);
5246 mPUSHi(pwent->pw_quota);
5249 mPUSHs(newSVpv(pwent->pw_age, 0));
5251 /* I think that you can never get this compiled, but just in case. */
5252 PUSHs(sv_mortalcopy(&PL_sv_no));
5257 /* pw_class and pw_comment are mutually exclusive--.
5258 * see the above note for pw_change, pw_quota, and pw_age. */
5260 mPUSHs(newSVpv(pwent->pw_class, 0));
5263 mPUSHs(newSVpv(pwent->pw_comment, 0));
5265 /* I think that you can never get this compiled, but just in case. */
5266 PUSHs(sv_mortalcopy(&PL_sv_no));
5271 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5273 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5275 # ifndef INCOMPLETE_TAINTS
5276 /* pw_gecos is tainted because user himself can diddle with it. */
5280 mPUSHs(newSVpv(pwent->pw_dir, 0));
5282 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5283 # ifndef INCOMPLETE_TAINTS
5284 /* pw_shell is tainted because user himself can diddle with it. */
5289 mPUSHi(pwent->pw_expire);
5294 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5300 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5305 DIE(aTHX_ PL_no_func, "setpwent");
5311 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5316 DIE(aTHX_ PL_no_func, "endpwent");
5324 const I32 which = PL_op->op_type;
5325 const struct group *grent;
5327 if (which == OP_GGRNAM) {
5328 const char* const name = POPpbytex;
5329 grent = (const struct group *)getgrnam(name);
5331 else if (which == OP_GGRGID) {
5332 const Gid_t gid = POPi;
5333 grent = (const struct group *)getgrgid(gid);
5337 grent = (struct group *)getgrent();
5339 DIE(aTHX_ PL_no_func, "getgrent");
5343 if (GIMME != G_ARRAY) {
5344 SV * const sv = sv_newmortal();
5348 if (which == OP_GGRNAM)
5350 sv_setiv(sv, (IV)grent->gr_gid);
5352 sv_setuv(sv, (UV)grent->gr_gid);
5355 sv_setpv(sv, grent->gr_name);
5361 mPUSHs(newSVpv(grent->gr_name, 0));
5364 mPUSHs(newSVpv(grent->gr_passwd, 0));
5366 PUSHs(sv_mortalcopy(&PL_sv_no));
5370 mPUSHi(grent->gr_gid);
5372 mPUSHu(grent->gr_gid);
5375 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5376 /* In UNICOS/mk (_CRAYMPP) the multithreading
5377 * versions (getgrnam_r, getgrgid_r)
5378 * seem to return an illegal pointer
5379 * as the group members list, gr_mem.
5380 * getgrent() doesn't even have a _r version
5381 * but the gr_mem is poisonous anyway.
5382 * So yes, you cannot get the list of group
5383 * members if building multithreaded in UNICOS/mk. */
5384 PUSHs(space_join_names_mortal(grent->gr_mem));
5390 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5396 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5401 DIE(aTHX_ PL_no_func, "setgrent");
5407 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5412 DIE(aTHX_ PL_no_func, "endgrent");
5422 if (!(tmps = PerlProc_getlogin()))
5424 PUSHp(tmps, strlen(tmps));
5427 DIE(aTHX_ PL_no_func, "getlogin");
5431 /* Miscellaneous. */
5436 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5437 register I32 items = SP - MARK;
5438 unsigned long a[20];
5443 while (++MARK <= SP) {
5444 if (SvTAINTED(*MARK)) {
5450 TAINT_PROPER("syscall");
5453 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5454 * or where sizeof(long) != sizeof(char*). But such machines will
5455 * not likely have syscall implemented either, so who cares?
5457 while (++MARK <= SP) {
5458 if (SvNIOK(*MARK) || !i)
5459 a[i++] = SvIV(*MARK);
5460 else if (*MARK == &PL_sv_undef)
5463 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5469 DIE(aTHX_ "Too many args to syscall");
5471 DIE(aTHX_ "Too few args to syscall");
5473 retval = syscall(a[0]);
5476 retval = syscall(a[0],a[1]);
5479 retval = syscall(a[0],a[1],a[2]);
5482 retval = syscall(a[0],a[1],a[2],a[3]);
5485 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5488 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5491 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5494 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5498 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5501 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5504 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5508 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5512 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5516 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5517 a[10],a[11],a[12],a[13]);
5519 #endif /* atarist */
5525 DIE(aTHX_ PL_no_func, "syscall");
5529 #ifdef FCNTL_EMULATE_FLOCK
5531 /* XXX Emulate flock() with fcntl().
5532 What's really needed is a good file locking module.
5536 fcntl_emulate_flock(int fd, int operation)
5540 switch (operation & ~LOCK_NB) {
5542 flock.l_type = F_RDLCK;
5545 flock.l_type = F_WRLCK;
5548 flock.l_type = F_UNLCK;
5554 flock.l_whence = SEEK_SET;
5555 flock.l_start = flock.l_len = (Off_t)0;
5557 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5560 #endif /* FCNTL_EMULATE_FLOCK */
5562 #ifdef LOCKF_EMULATE_FLOCK
5564 /* XXX Emulate flock() with lockf(). This is just to increase
5565 portability of scripts. The calls are not completely
5566 interchangeable. What's really needed is a good file
5570 /* The lockf() constants might have been defined in <unistd.h>.
5571 Unfortunately, <unistd.h> causes troubles on some mixed
5572 (BSD/POSIX) systems, such as SunOS 4.1.3.
5574 Further, the lockf() constants aren't POSIX, so they might not be
5575 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5576 just stick in the SVID values and be done with it. Sigh.
5580 # define F_ULOCK 0 /* Unlock a previously locked region */
5583 # define F_LOCK 1 /* Lock a region for exclusive use */
5586 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5589 # define F_TEST 3 /* Test a region for other processes locks */
5593 lockf_emulate_flock(int fd, int operation)
5599 /* flock locks entire file so for lockf we need to do the same */
5600 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5601 if (pos > 0) /* is seekable and needs to be repositioned */
5602 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5603 pos = -1; /* seek failed, so don't seek back afterwards */
5606 switch (operation) {
5608 /* LOCK_SH - get a shared lock */
5610 /* LOCK_EX - get an exclusive lock */
5612 i = lockf (fd, F_LOCK, 0);
5615 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5616 case LOCK_SH|LOCK_NB:
5617 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5618 case LOCK_EX|LOCK_NB:
5619 i = lockf (fd, F_TLOCK, 0);
5621 if ((errno == EAGAIN) || (errno == EACCES))
5622 errno = EWOULDBLOCK;
5625 /* LOCK_UN - unlock (non-blocking is a no-op) */
5627 case LOCK_UN|LOCK_NB:
5628 i = lockf (fd, F_ULOCK, 0);
5631 /* Default - can't decipher operation */
5638 if (pos > 0) /* need to restore position of the handle */
5639 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5644 #endif /* LOCKF_EMULATE_FLOCK */
5648 * c-indentation-style: bsd
5650 * indent-tabs-mode: t
5653 * ex: set ts=8 sts=4 sw=4 noet: