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
32 #if !defined(PERL_MICRO) && defined(Quad_t)
38 /* Shadow password support for solaris - pdo@cs.umd.edu
39 * Not just Solaris: at least HP-UX, IRIX, Linux.
40 * The API is from SysV.
42 * There are at least two more shadow interfaces,
43 * see the comments in pp_gpwent().
47 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
48 * and another MAXINT from "perl.h" <- <sys/param.h>. */
55 # include <sys/wait.h>
59 # include <sys/resource.h>
68 # include <sys/select.h>
72 /* XXX Configure test needed.
73 h_errno might not be a simple 'int', especially for multi-threaded
74 applications, see "extern int errno in perl.h". Creating such
75 a test requires taking into account the differences between
76 compiling multithreaded and singlethreaded ($ccflags et al).
77 HOST_NOT_FOUND is typically defined in <netdb.h>.
79 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
88 struct passwd *getpwnam (char *);
89 struct passwd *getpwuid (Uid_t);
94 struct passwd *getpwent (void);
95 #elif defined (VMS) && defined (my_getpwent)
96 struct passwd *Perl_my_getpwent (pTHX);
105 struct group *getgrnam (char *);
106 struct group *getgrgid (Gid_t);
110 struct group *getgrent (void);
116 # if defined(_MSC_VER) || defined(__MINGW32__)
117 # include <sys/utime.h>
124 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
127 # define my_chsize PerlLIO_chsize
130 # define my_chsize PerlLIO_chsize
132 I32 my_chsize(int fd, Off_t length);
138 #else /* no flock() */
140 /* fcntl.h might not have been included, even if it exists, because
141 the current Configure only sets I_FCNTL if it's needed to pick up
142 the *_OK constants. Make sure it has been included before testing
143 the fcntl() locking constants. */
144 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
148 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
149 # define FLOCK fcntl_emulate_flock
150 # define FCNTL_EMULATE_FLOCK
151 # else /* no flock() or fcntl(F_SETLK,...) */
153 # define FLOCK lockf_emulate_flock
154 # define LOCKF_EMULATE_FLOCK
156 # endif /* no flock() or fcntl(F_SETLK,...) */
159 static int FLOCK (int, int);
162 * These are the flock() constants. Since this sytems doesn't have
163 * flock(), the values of the constants are probably not available.
177 # endif /* emulating flock() */
179 #endif /* no flock() */
182 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
184 #if defined(I_SYS_ACCESS) && !defined(R_OK)
185 # include <sys/access.h>
188 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
189 # define FD_CLOEXEC 1 /* NeXT needs this */
195 /* Missing protos on LynxOS */
196 void sethostent(int);
197 void endhostent(void);
199 void endnetent(void);
200 void setprotoent(int);
201 void endprotoent(void);
202 void setservent(int);
203 void endservent(void);
206 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
208 /* F_OK unused: if stat() cannot find it... */
210 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
211 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
212 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
215 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
216 # ifdef I_SYS_SECURITY
217 # include <sys/security.h>
221 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
224 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
228 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
230 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
234 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
235 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
236 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
239 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
241 const Uid_t ruid = getuid();
242 const Uid_t euid = geteuid();
243 const Gid_t rgid = getgid();
244 const Gid_t egid = getegid();
248 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
249 Perl_croak(aTHX_ "switching effective uid is not implemented");
252 if (setreuid(euid, ruid))
255 if (setresuid(euid, ruid, (Uid_t)-1))
258 Perl_croak(aTHX_ "entering effective uid failed");
261 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
262 Perl_croak(aTHX_ "switching effective gid is not implemented");
265 if (setregid(egid, rgid))
268 if (setresgid(egid, rgid, (Gid_t)-1))
271 Perl_croak(aTHX_ "entering effective gid failed");
274 res = access(path, mode);
277 if (setreuid(ruid, euid))
280 if (setresuid(ruid, euid, (Uid_t)-1))
283 Perl_croak(aTHX_ "leaving effective uid failed");
286 if (setregid(rgid, egid))
289 if (setresgid(rgid, egid, (Gid_t)-1))
292 Perl_croak(aTHX_ "leaving effective gid failed");
297 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
304 const char * const tmps = POPpconstx;
305 const I32 gimme = GIMME_V;
306 const char *mode = "r";
309 if (PL_op->op_private & OPpOPEN_IN_RAW)
311 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
313 fp = PerlProc_popen(tmps, mode);
315 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
317 PerlIO_apply_layers(aTHX_ fp,mode,type);
319 if (gimme == G_VOID) {
321 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
324 else if (gimme == G_SCALAR) {
327 PL_rs = &PL_sv_undef;
328 sv_setpvs(TARG, ""); /* note that this preserves previous buffer */
329 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
337 SV * const sv = newSV(79);
338 if (sv_gets(sv, fp, 0) == NULL) {
343 if (SvLEN(sv) - SvCUR(sv) > 20) {
344 SvPV_shrink_to_cur(sv);
349 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
350 TAINT; /* "I believe that this is not gratuitous!" */
353 STATUS_NATIVE_CHILD_SET(-1);
354 if (gimme == G_SCALAR)
365 tryAMAGICunTARGET(iter, -1);
367 /* Note that we only ever get here if File::Glob fails to load
368 * without at the same time croaking, for some reason, or if
369 * perl was built with PERL_EXTERNAL_GLOB */
376 * The external globbing program may use things we can't control,
377 * so for security reasons we must assume the worst.
380 taint_proper(PL_no_security, "glob");
384 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
385 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
387 SAVESPTR(PL_rs); /* This is not permanent, either. */
388 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
391 *SvPVX(PL_rs) = '\n';
395 result = do_readline();
403 PL_last_in_gv = cGVOP_gv;
404 return do_readline();
415 do_join(TARG, &PL_sv_no, MARK, SP);
419 else if (SP == MARK) {
427 tmps = SvPV_const(tmpsv, len);
428 if ((!tmps || !len) && PL_errgv) {
429 SV * const error = ERRSV;
430 SvUPGRADE(error, SVt_PV);
431 if (SvPOK(error) && SvCUR(error))
432 sv_catpvs(error, "\t...caught");
434 tmps = SvPV_const(tmpsv, len);
437 tmpsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
439 Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv));
451 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
453 if (SP - MARK != 1) {
455 do_join(TARG, &PL_sv_no, MARK, SP);
457 tmps = SvPV_const(tmpsv, len);
463 tmps = SvROK(tmpsv) ? (const char *)NULL : SvPV_const(tmpsv, len);
466 SV * const error = ERRSV;
467 SvUPGRADE(error, SVt_PV);
468 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
470 SvSetSV(error,tmpsv);
471 else if (sv_isobject(error)) {
472 HV * const stash = SvSTASH(SvRV(error));
473 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
475 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
476 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
483 call_sv(MUTABLE_SV(GvCV(gv)),
484 G_SCALAR|G_EVAL|G_KEEPERR);
485 sv_setsv(error,*PL_stack_sp--);
491 if (SvPOK(error) && SvCUR(error))
492 sv_catpvs(error, "\t...propagated");
495 tmps = SvPV_const(tmpsv, len);
501 tmpsv = newSVpvs_flags("Died", SVs_TEMP);
503 DIE(aTHX_ "%"SVf, SVfARG(tmpsv));
519 GV * const gv = MUTABLE_GV(*++MARK);
522 DIE(aTHX_ PL_no_usym, "filehandle");
524 if ((io = GvIOp(gv))) {
526 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
528 if (IoDIRP(io) && ckWARN2(WARN_IO, WARN_DEPRECATED))
529 Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
530 "Opening dirhandle %s also as a file", GvENAME(gv));
532 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
534 /* Method's args are same as ours ... */
535 /* ... except handle is replaced by the object */
536 *MARK-- = SvTIED_obj(MUTABLE_SV(io), mg);
540 call_method("OPEN", G_SCALAR);
554 tmps = SvPV_const(sv, len);
555 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
558 PUSHi( (I32)PL_forkprocess );
559 else if (PL_forkprocess == 0) /* we are a new child */
569 GV * const gv = (MAXARG == 0) ? PL_defoutgv : MUTABLE_GV(POPs);
572 IO * const io = GvIO(gv);
574 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
577 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
580 call_method("CLOSE", G_SCALAR);
588 PUSHs(boolSV(do_close(gv, TRUE)));
601 GV * const wgv = MUTABLE_GV(POPs);
602 GV * const rgv = MUTABLE_GV(POPs);
607 if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
608 DIE(aTHX_ PL_no_usym, "filehandle");
613 do_close(rgv, FALSE);
615 do_close(wgv, FALSE);
617 if (PerlProc_pipe(fd) < 0)
620 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
621 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
622 IoOFP(rstio) = IoIFP(rstio);
623 IoIFP(wstio) = IoOFP(wstio);
624 IoTYPE(rstio) = IoTYPE_RDONLY;
625 IoTYPE(wstio) = IoTYPE_WRONLY;
627 if (!IoIFP(rstio) || !IoOFP(wstio)) {
629 PerlIO_close(IoIFP(rstio));
631 PerlLIO_close(fd[0]);
633 PerlIO_close(IoOFP(wstio));
635 PerlLIO_close(fd[1]);
638 #if defined(HAS_FCNTL) && defined(F_SETFD)
639 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
640 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
647 DIE(aTHX_ PL_no_func, "pipe");
661 gv = MUTABLE_GV(POPs);
663 if (gv && (io = GvIO(gv))
664 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
667 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
670 call_method("FILENO", G_SCALAR);
676 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
677 /* Can't do this because people seem to do things like
678 defined(fileno($foo)) to check whether $foo is a valid fh.
679 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
680 report_evil_fh(gv, io, PL_op->op_type);
685 PUSHi(PerlIO_fileno(fp));
698 anum = PerlLIO_umask(022);
699 /* setting it to 022 between the two calls to umask avoids
700 * to have a window where the umask is set to 0 -- meaning
701 * that another thread could create world-writeable files. */
703 (void)PerlLIO_umask(anum);
706 anum = PerlLIO_umask(POPi);
707 TAINT_PROPER("umask");
710 /* Only DIE if trying to restrict permissions on "user" (self).
711 * Otherwise it's harmless and more useful to just return undef
712 * since 'group' and 'other' concepts probably don't exist here. */
713 if (MAXARG >= 1 && (POPi & 0700))
714 DIE(aTHX_ "umask not implemented");
715 XPUSHs(&PL_sv_undef);
734 gv = MUTABLE_GV(POPs);
736 if (gv && (io = GvIO(gv))) {
737 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
740 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
745 call_method("BINMODE", G_SCALAR);
753 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
754 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
755 report_evil_fh(gv, io, PL_op->op_type);
756 SETERRNO(EBADF,RMS_IFI);
763 const char *d = NULL;
766 d = SvPV_const(discp, len);
767 mode = mode_from_discipline(d, len);
768 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
769 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
770 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
791 const I32 markoff = MARK - PL_stack_base;
792 const char *methname;
793 int how = PERL_MAGIC_tied;
797 switch(SvTYPE(varsv)) {
799 methname = "TIEHASH";
800 HvEITER_set(MUTABLE_HV(varsv), 0);
803 methname = "TIEARRAY";
806 if (isGV_with_GP(varsv)) {
807 methname = "TIEHANDLE";
808 how = PERL_MAGIC_tiedscalar;
809 /* For tied filehandles, we apply tiedscalar magic to the IO
810 slot of the GP rather than the GV itself. AMS 20010812 */
812 GvIOp(varsv) = newIO();
813 varsv = MUTABLE_SV(GvIOp(varsv));
818 methname = "TIESCALAR";
819 how = PERL_MAGIC_tiedscalar;
823 if (sv_isobject(*MARK)) { /* Calls GET magic. */
825 PUSHSTACKi(PERLSI_MAGIC);
827 EXTEND(SP,(I32)items);
831 call_method(methname, G_SCALAR);
834 /* Not clear why we don't call call_method here too.
835 * perhaps to get different error message ?
838 const char *name = SvPV_nomg_const(*MARK, len);
839 stash = gv_stashpvn(name, len, 0);
840 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
841 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
842 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
845 PUSHSTACKi(PERLSI_MAGIC);
847 EXTEND(SP,(I32)items);
851 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
857 if (sv_isobject(sv)) {
858 sv_unmagic(varsv, how);
859 /* Croak if a self-tie on an aggregate is attempted. */
860 if (varsv == SvRV(sv) &&
861 (SvTYPE(varsv) == SVt_PVAV ||
862 SvTYPE(varsv) == SVt_PVHV))
864 "Self-ties of arrays and hashes are not supported");
865 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
868 SP = PL_stack_base + markoff;
878 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
879 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
881 if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
884 if ((mg = SvTIED_mg(sv, how))) {
885 SV * const obj = SvRV(SvTIED_obj(sv, mg));
887 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
889 if (gv && isGV(gv) && (cv = GvCV(gv))) {
891 XPUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
892 mXPUSHi(SvREFCNT(obj) - 1);
895 call_sv(MUTABLE_SV(cv), G_VOID);
899 else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
900 Perl_warner(aTHX_ packWARN(WARN_UNTIE),
901 "untie attempted while %"UVuf" inner references still exist",
902 (UV)SvREFCNT(obj) - 1 ) ;
906 sv_unmagic(sv, how) ;
916 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
917 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
919 if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
922 if ((mg = SvTIED_mg(sv, how))) {
923 SV *osv = SvTIED_obj(sv, mg);
924 if (osv == mg->mg_obj)
925 osv = sv_mortalcopy(osv);
939 HV * const hv = MUTABLE_HV(POPs);
940 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
941 stash = gv_stashsv(sv, 0);
942 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
944 require_pv("AnyDBM_File.pm");
946 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
947 DIE(aTHX_ "No dbm on this machine");
957 mPUSHu(O_RDWR|O_CREAT);
962 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
965 if (!sv_isobject(TOPs)) {
973 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
977 if (sv_isobject(TOPs)) {
978 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
979 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
996 struct timeval timebuf;
997 struct timeval *tbuf = &timebuf;
1000 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1005 # if BYTEORDER & 0xf0000
1006 # define ORDERBYTE (0x88888888 - BYTEORDER)
1008 # define ORDERBYTE (0x4444 - BYTEORDER)
1014 for (i = 1; i <= 3; i++) {
1015 SV * const sv = SP[i];
1018 if (SvREADONLY(sv)) {
1020 sv_force_normal_flags(sv, 0);
1021 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1022 DIE(aTHX_ "%s", PL_no_modify);
1025 if (ckWARN(WARN_MISC))
1026 Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1027 SvPV_force_nolen(sv); /* force string conversion */
1034 /* little endians can use vecs directly */
1035 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1042 masksize = NFDBITS / NBBY;
1044 masksize = sizeof(long); /* documented int, everyone seems to use long */
1046 Zero(&fd_sets[0], 4, char*);
1049 # if SELECT_MIN_BITS == 1
1050 growsize = sizeof(fd_set);
1052 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1053 # undef SELECT_MIN_BITS
1054 # define SELECT_MIN_BITS __FD_SETSIZE
1056 /* If SELECT_MIN_BITS is greater than one we most probably will want
1057 * to align the sizes with SELECT_MIN_BITS/8 because for example
1058 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1059 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1060 * on (sets/tests/clears bits) is 32 bits. */
1061 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1069 timebuf.tv_sec = (long)value;
1070 value -= (NV)timebuf.tv_sec;
1071 timebuf.tv_usec = (long)(value * 1000000.0);
1076 for (i = 1; i <= 3; i++) {
1078 if (!SvOK(sv) || SvCUR(sv) == 0) {
1085 Sv_Grow(sv, growsize);
1089 while (++j <= growsize) {
1093 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1095 Newx(fd_sets[i], growsize, char);
1096 for (offset = 0; offset < growsize; offset += masksize) {
1097 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1098 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1101 fd_sets[i] = SvPVX(sv);
1105 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1106 /* Can't make just the (void*) conditional because that would be
1107 * cpp #if within cpp macro, and not all compilers like that. */
1108 nfound = PerlSock_select(
1110 (Select_fd_set_t) fd_sets[1],
1111 (Select_fd_set_t) fd_sets[2],
1112 (Select_fd_set_t) fd_sets[3],
1113 (void*) tbuf); /* Workaround for compiler bug. */
1115 nfound = PerlSock_select(
1117 (Select_fd_set_t) fd_sets[1],
1118 (Select_fd_set_t) fd_sets[2],
1119 (Select_fd_set_t) fd_sets[3],
1122 for (i = 1; i <= 3; i++) {
1125 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1127 for (offset = 0; offset < growsize; offset += masksize) {
1128 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1129 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1131 Safefree(fd_sets[i]);
1138 if (GIMME == G_ARRAY && tbuf) {
1139 value = (NV)(timebuf.tv_sec) +
1140 (NV)(timebuf.tv_usec) / 1000000.0;
1145 DIE(aTHX_ "select not implemented");
1150 =for apidoc setdefout
1152 Sets PL_defoutgv, the default file handle for output, to the passed in
1153 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1154 count of the passed in typeglob is increased by one, and the reference count
1155 of the typeglob that PL_defoutgv points to is decreased by one.
1161 Perl_setdefout(pTHX_ GV *gv)
1164 SvREFCNT_inc_simple_void(gv);
1166 SvREFCNT_dec(PL_defoutgv);
1174 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1175 GV * egv = GvEGV(PL_defoutgv);
1181 XPUSHs(&PL_sv_undef);
1183 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1184 if (gvp && *gvp == egv) {
1185 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1189 mXPUSHs(newRV(MUTABLE_SV(egv)));
1194 if (!GvIO(newdefout))
1195 gv_IOadd(newdefout);
1196 setdefout(newdefout);
1206 GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs);
1208 if (gv && (io = GvIO(gv))) {
1209 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1211 const I32 gimme = GIMME_V;
1213 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1216 call_method("GETC", gimme);
1219 if (gimme == G_SCALAR)
1220 SvSetMagicSV_nosteal(TARG, TOPs);
1224 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1225 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1226 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1227 report_evil_fh(gv, io, PL_op->op_type);
1228 SETERRNO(EBADF,RMS_IFI);
1232 sv_setpvs(TARG, " ");
1233 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1234 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1235 /* Find out how many bytes the char needs */
1236 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1239 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1240 SvCUR_set(TARG,1+len);
1249 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1252 register PERL_CONTEXT *cx;
1253 const I32 gimme = GIMME_V;
1255 PERL_ARGS_ASSERT_DOFORM;
1260 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1261 PUSHFORMAT(cx, retop);
1263 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1265 setdefout(gv); /* locally select filehandle so $% et al work */
1282 gv = MUTABLE_GV(POPs);
1297 goto not_a_format_reference;
1302 tmpsv = sv_newmortal();
1303 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1304 name = SvPV_nolen_const(tmpsv);
1306 DIE(aTHX_ "Undefined format \"%s\" called", name);
1308 not_a_format_reference:
1309 DIE(aTHX_ "Not a format reference");
1312 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1314 IoFLAGS(io) &= ~IOf_DIDTOP;
1315 return doform(cv,gv,PL_op->op_next);
1321 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1322 register IO * const io = GvIOp(gv);
1327 register PERL_CONTEXT *cx;
1329 if (!io || !(ofp = IoOFP(io)))
1332 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1333 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1335 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1336 PL_formtarget != PL_toptarget)
1340 if (!IoTOP_GV(io)) {
1343 if (!IoTOP_NAME(io)) {
1345 if (!IoFMT_NAME(io))
1346 IoFMT_NAME(io) = savepv(GvNAME(gv));
1347 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1348 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1349 if ((topgv && GvFORM(topgv)) ||
1350 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1351 IoTOP_NAME(io) = savesvpv(topname);
1353 IoTOP_NAME(io) = savepvs("top");
1355 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1356 if (!topgv || !GvFORM(topgv)) {
1357 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1360 IoTOP_GV(io) = topgv;
1362 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1363 I32 lines = IoLINES_LEFT(io);
1364 const char *s = SvPVX_const(PL_formtarget);
1365 if (lines <= 0) /* Yow, header didn't even fit!!! */
1367 while (lines-- > 0) {
1368 s = strchr(s, '\n');
1374 const STRLEN save = SvCUR(PL_formtarget);
1375 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1376 do_print(PL_formtarget, ofp);
1377 SvCUR_set(PL_formtarget, save);
1378 sv_chop(PL_formtarget, s);
1379 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1382 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1383 do_print(PL_formfeed, ofp);
1384 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1386 PL_formtarget = PL_toptarget;
1387 IoFLAGS(io) |= IOf_DIDTOP;
1390 DIE(aTHX_ "bad top format reference");
1393 SV * const sv = sv_newmortal();
1395 gv_efullname4(sv, fgv, NULL, FALSE);
1396 name = SvPV_nolen_const(sv);
1398 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1400 DIE(aTHX_ "Undefined top format called");
1402 if (cv && CvCLONE(cv))
1403 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1404 return doform(cv, gv, PL_op);
1408 POPBLOCK(cx,PL_curpm);
1414 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1416 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1417 else if (ckWARN(WARN_CLOSED))
1418 report_evil_fh(gv, io, PL_op->op_type);
1423 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1424 if (ckWARN(WARN_IO))
1425 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1427 if (!do_print(PL_formtarget, fp))
1430 FmLINES(PL_formtarget) = 0;
1431 SvCUR_set(PL_formtarget, 0);
1432 *SvEND(PL_formtarget) = '\0';
1433 if (IoFLAGS(io) & IOf_FLUSH)
1434 (void)PerlIO_flush(fp);
1439 PL_formtarget = PL_bodytarget;
1441 PERL_UNUSED_VAR(newsp);
1442 PERL_UNUSED_VAR(gimme);
1443 return cx->blk_sub.retop;
1448 dVAR; dSP; dMARK; dORIGMARK;
1454 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1456 if (gv && (io = GvIO(gv))) {
1457 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1459 if (MARK == ORIGMARK) {
1462 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1466 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1469 call_method("PRINTF", G_SCALAR);
1472 MARK = ORIGMARK + 1;
1480 if (!(io = GvIO(gv))) {
1481 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1482 report_evil_fh(gv, io, PL_op->op_type);
1483 SETERRNO(EBADF,RMS_IFI);
1486 else if (!(fp = IoOFP(io))) {
1487 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1489 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1490 else if (ckWARN(WARN_CLOSED))
1491 report_evil_fh(gv, io, PL_op->op_type);
1493 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1497 if (SvTAINTED(MARK[1]))
1498 TAINT_PROPER("printf");
1499 do_sprintf(sv, SP - MARK, MARK + 1);
1500 if (!do_print(sv, fp))
1503 if (IoFLAGS(io) & IOf_FLUSH)
1504 if (PerlIO_flush(fp) == EOF)
1515 PUSHs(&PL_sv_undef);
1523 const int perm = (MAXARG > 3) ? POPi : 0666;
1524 const int mode = POPi;
1525 SV * const sv = POPs;
1526 GV * const gv = MUTABLE_GV(POPs);
1529 /* Need TIEHANDLE method ? */
1530 const char * const tmps = SvPV_const(sv, len);
1531 /* FIXME? do_open should do const */
1532 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1533 IoLINES(GvIOp(gv)) = 0;
1537 PUSHs(&PL_sv_undef);
1544 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1550 Sock_size_t bufsize;
1558 bool charstart = FALSE;
1559 STRLEN charskip = 0;
1562 GV * const gv = MUTABLE_GV(*++MARK);
1563 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1564 && gv && (io = GvIO(gv)) )
1566 const MAGIC * mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1570 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1572 call_method("READ", G_SCALAR);
1586 sv_setpvs(bufsv, "");
1587 length = SvIVx(*++MARK);
1590 offset = SvIVx(*++MARK);
1594 if (!io || !IoIFP(io)) {
1595 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1596 report_evil_fh(gv, io, PL_op->op_type);
1597 SETERRNO(EBADF,RMS_IFI);
1600 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1601 buffer = SvPVutf8_force(bufsv, blen);
1602 /* UTF-8 may not have been set if they are all low bytes */
1607 buffer = SvPV_force(bufsv, blen);
1608 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1611 DIE(aTHX_ "Negative length");
1619 if (PL_op->op_type == OP_RECV) {
1620 char namebuf[MAXPATHLEN];
1621 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1622 bufsize = sizeof (struct sockaddr_in);
1624 bufsize = sizeof namebuf;
1626 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1630 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1631 /* 'offset' means 'flags' here */
1632 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1633 (struct sockaddr *)namebuf, &bufsize);
1637 /* Bogus return without padding */
1638 bufsize = sizeof (struct sockaddr_in);
1640 SvCUR_set(bufsv, count);
1641 *SvEND(bufsv) = '\0';
1642 (void)SvPOK_only(bufsv);
1646 /* This should not be marked tainted if the fp is marked clean */
1647 if (!(IoFLAGS(io) & IOf_UNTAINT))
1648 SvTAINTED_on(bufsv);
1650 sv_setpvn(TARG, namebuf, bufsize);
1655 if (PL_op->op_type == OP_RECV)
1656 DIE(aTHX_ PL_no_sock_func, "recv");
1658 if (DO_UTF8(bufsv)) {
1659 /* offset adjust in characters not bytes */
1660 blen = sv_len_utf8(bufsv);
1663 if (-offset > (int)blen)
1664 DIE(aTHX_ "Offset outside string");
1667 if (DO_UTF8(bufsv)) {
1668 /* convert offset-as-chars to offset-as-bytes */
1669 if (offset >= (int)blen)
1670 offset += SvCUR(bufsv) - blen;
1672 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1675 bufsize = SvCUR(bufsv);
1676 /* Allocating length + offset + 1 isn't perfect in the case of reading
1677 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1679 (should be 2 * length + offset + 1, or possibly something longer if
1680 PL_encoding is true) */
1681 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1682 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1683 Zero(buffer+bufsize, offset-bufsize, char);
1685 buffer = buffer + offset;
1687 read_target = bufsv;
1689 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1690 concatenate it to the current buffer. */
1692 /* Truncate the existing buffer to the start of where we will be
1694 SvCUR_set(bufsv, offset);
1696 read_target = sv_newmortal();
1697 SvUPGRADE(read_target, SVt_PV);
1698 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1701 if (PL_op->op_type == OP_SYSREAD) {
1702 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1703 if (IoTYPE(io) == IoTYPE_SOCKET) {
1704 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1710 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1715 #ifdef HAS_SOCKET__bad_code_maybe
1716 if (IoTYPE(io) == IoTYPE_SOCKET) {
1717 char namebuf[MAXPATHLEN];
1718 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1719 bufsize = sizeof (struct sockaddr_in);
1721 bufsize = sizeof namebuf;
1723 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1724 (struct sockaddr *)namebuf, &bufsize);
1729 count = PerlIO_read(IoIFP(io), buffer, length);
1730 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1731 if (count == 0 && PerlIO_error(IoIFP(io)))
1735 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1736 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1739 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1740 *SvEND(read_target) = '\0';
1741 (void)SvPOK_only(read_target);
1742 if (fp_utf8 && !IN_BYTES) {
1743 /* Look at utf8 we got back and count the characters */
1744 const char *bend = buffer + count;
1745 while (buffer < bend) {
1747 skip = UTF8SKIP(buffer);
1750 if (buffer - charskip + skip > bend) {
1751 /* partial character - try for rest of it */
1752 length = skip - (bend-buffer);
1753 offset = bend - SvPVX_const(bufsv);
1765 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1766 provided amount read (count) was what was requested (length)
1768 if (got < wanted && count == length) {
1769 length = wanted - got;
1770 offset = bend - SvPVX_const(bufsv);
1773 /* return value is character count */
1777 else if (buffer_utf8) {
1778 /* Let svcatsv upgrade the bytes we read in to utf8.
1779 The buffer is a mortal so will be freed soon. */
1780 sv_catsv_nomg(bufsv, read_target);
1783 /* This should not be marked tainted if the fp is marked clean */
1784 if (!(IoFLAGS(io) & IOf_UNTAINT))
1785 SvTAINTED_on(bufsv);
1797 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1803 STRLEN orig_blen_bytes;
1804 const int op_type = PL_op->op_type;
1808 GV *const gv = MUTABLE_GV(*++MARK);
1809 if (PL_op->op_type == OP_SYSWRITE
1810 && gv && (io = GvIO(gv))) {
1811 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1815 if (MARK == SP - 1) {
1817 mXPUSHi(sv_len(sv));
1822 *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg);
1824 call_method("WRITE", G_SCALAR);
1840 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1842 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1843 if (io && IoIFP(io))
1844 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1846 report_evil_fh(gv, io, PL_op->op_type);
1848 SETERRNO(EBADF,RMS_IFI);
1852 /* Do this first to trigger any overloading. */
1853 buffer = SvPV_const(bufsv, blen);
1854 orig_blen_bytes = blen;
1855 doing_utf8 = DO_UTF8(bufsv);
1857 if (PerlIO_isutf8(IoIFP(io))) {
1858 if (!SvUTF8(bufsv)) {
1859 /* We don't modify the original scalar. */
1860 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1861 buffer = (char *) tmpbuf;
1865 else if (doing_utf8) {
1866 STRLEN tmplen = blen;
1867 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1870 buffer = (char *) tmpbuf;
1874 assert((char *)result == buffer);
1875 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1879 if (op_type == OP_SYSWRITE) {
1880 Size_t length = 0; /* This length is in characters. */
1886 /* The SV is bytes, and we've had to upgrade it. */
1887 blen_chars = orig_blen_bytes;
1889 /* The SV really is UTF-8. */
1890 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1891 /* Don't call sv_len_utf8 again because it will call magic
1892 or overloading a second time, and we might get back a
1893 different result. */
1894 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1896 /* It's safe, and it may well be cached. */
1897 blen_chars = sv_len_utf8(bufsv);
1905 length = blen_chars;
1907 #if Size_t_size > IVSIZE
1908 length = (Size_t)SvNVx(*++MARK);
1910 length = (Size_t)SvIVx(*++MARK);
1912 if ((SSize_t)length < 0) {
1914 DIE(aTHX_ "Negative length");
1919 offset = SvIVx(*++MARK);
1921 if (-offset > (IV)blen_chars) {
1923 DIE(aTHX_ "Offset outside string");
1925 offset += blen_chars;
1926 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1928 DIE(aTHX_ "Offset outside string");
1932 if (length > blen_chars - offset)
1933 length = blen_chars - offset;
1935 /* Here we convert length from characters to bytes. */
1936 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1937 /* Either we had to convert the SV, or the SV is magical, or
1938 the SV has overloading, in which case we can't or mustn't
1939 or mustn't call it again. */
1941 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1942 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1944 /* It's a real UTF-8 SV, and it's not going to change under
1945 us. Take advantage of any cache. */
1947 I32 len_I32 = length;
1949 /* Convert the start and end character positions to bytes.
1950 Remember that the second argument to sv_pos_u2b is relative
1952 sv_pos_u2b(bufsv, &start, &len_I32);
1959 buffer = buffer+offset;
1961 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1962 if (IoTYPE(io) == IoTYPE_SOCKET) {
1963 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1969 /* See the note at doio.c:do_print about filesize limits. --jhi */
1970 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1976 const int flags = SvIVx(*++MARK);
1979 char * const sockbuf = SvPVx(*++MARK, mlen);
1980 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1981 flags, (struct sockaddr *)sockbuf, mlen);
1985 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1990 DIE(aTHX_ PL_no_sock_func, "send");
1997 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2000 #if Size_t_size > IVSIZE
2021 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2022 else if (PL_op->op_flags & OPf_SPECIAL)
2023 gv = PL_last_in_gv = GvEGV(PL_argvgv); /* eof() - ARGV magic */
2025 gv = PL_last_in_gv; /* eof */
2030 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2032 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2034 * in Perl 5.12 and later, the additional paramter is a bitmask:
2037 * 2 = eof() <- ARGV magic
2040 mPUSHi(1); /* 1 = eof(FH) - simple, explicit FH */
2041 else if (PL_op->op_flags & OPf_SPECIAL)
2042 mPUSHi(2); /* 2 = eof() - ARGV magic */
2044 mPUSHi(0); /* 0 = eof - simple, implicit FH */
2047 call_method("EOF", G_SCALAR);
2053 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2054 if (io && !IoIFP(io)) {
2055 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2057 IoFLAGS(io) &= ~IOf_START;
2058 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2060 sv_setpvs(GvSV(gv), "-");
2062 GvSV(gv) = newSVpvs("-");
2063 SvSETMAGIC(GvSV(gv));
2065 else if (!nextargv(gv))
2070 PUSHs(boolSV(do_eof(gv)));
2081 PL_last_in_gv = MUTABLE_GV(POPs);
2084 if (gv && (io = GvIO(gv))) {
2085 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2088 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2091 call_method("TELL", G_SCALAR);
2098 #if LSEEKSIZE > IVSIZE
2099 PUSHn( do_tell(gv) );
2101 PUSHi( do_tell(gv) );
2109 const int whence = POPi;
2110 #if LSEEKSIZE > IVSIZE
2111 const Off_t offset = (Off_t)SvNVx(POPs);
2113 const Off_t offset = (Off_t)SvIVx(POPs);
2116 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2119 if (gv && (io = GvIO(gv))) {
2120 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2123 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2124 #if LSEEKSIZE > IVSIZE
2125 mXPUSHn((NV) offset);
2132 call_method("SEEK", G_SCALAR);
2139 if (PL_op->op_type == OP_SEEK)
2140 PUSHs(boolSV(do_seek(gv, offset, whence)));
2142 const Off_t sought = do_sysseek(gv, offset, whence);
2144 PUSHs(&PL_sv_undef);
2146 SV* const sv = sought ?
2147 #if LSEEKSIZE > IVSIZE
2152 : newSVpvn(zero_but_true, ZBTLEN);
2163 /* There seems to be no consensus on the length type of truncate()
2164 * and ftruncate(), both off_t and size_t have supporters. In
2165 * general one would think that when using large files, off_t is
2166 * at least as wide as size_t, so using an off_t should be okay. */
2167 /* XXX Configure probe for the length type of *truncate() needed XXX */
2170 #if Off_t_size > IVSIZE
2175 /* Checking for length < 0 is problematic as the type might or
2176 * might not be signed: if it is not, clever compilers will moan. */
2177 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2184 if (PL_op->op_flags & OPf_SPECIAL) {
2185 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2194 TAINT_PROPER("truncate");
2195 if (!(fp = IoIFP(io))) {
2201 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2203 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2210 SV * const sv = POPs;
2213 if (isGV_with_GP(sv)) {
2214 tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */
2215 goto do_ftruncate_gv;
2217 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2218 tmpgv = MUTABLE_GV(SvRV(sv)); /* \*main::FRED for example */
2219 goto do_ftruncate_gv;
2221 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2222 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2223 goto do_ftruncate_io;
2226 name = SvPV_nolen_const(sv);
2227 TAINT_PROPER("truncate");
2229 if (truncate(name, len) < 0)
2233 const int tmpfd = PerlLIO_open(name, O_RDWR);
2238 if (my_chsize(tmpfd, len) < 0)
2240 PerlLIO_close(tmpfd);
2249 SETERRNO(EBADF,RMS_IFI);
2257 SV * const argsv = POPs;
2258 const unsigned int func = POPu;
2259 const int optype = PL_op->op_type;
2260 GV * const gv = MUTABLE_GV(POPs);
2261 IO * const io = gv ? GvIOn(gv) : NULL;
2265 if (!io || !argsv || !IoIFP(io)) {
2266 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2267 report_evil_fh(gv, io, PL_op->op_type);
2268 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2272 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2275 s = SvPV_force(argsv, len);
2276 need = IOCPARM_LEN(func);
2278 s = Sv_Grow(argsv, need + 1);
2279 SvCUR_set(argsv, need);
2282 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2285 retval = SvIV(argsv);
2286 s = INT2PTR(char*,retval); /* ouch */
2289 TAINT_PROPER(PL_op_desc[optype]);
2291 if (optype == OP_IOCTL)
2293 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2295 DIE(aTHX_ "ioctl is not implemented");
2299 DIE(aTHX_ "fcntl is not implemented");
2301 #if defined(OS2) && defined(__EMX__)
2302 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2304 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2308 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2310 if (s[SvCUR(argsv)] != 17)
2311 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2313 s[SvCUR(argsv)] = 0; /* put our null back */
2314 SvSETMAGIC(argsv); /* Assume it has changed */
2323 PUSHp(zero_but_true, ZBTLEN);
2336 const int argtype = POPi;
2337 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
2339 if (gv && (io = GvIO(gv)))
2345 /* XXX Looks to me like io is always NULL at this point */
2347 (void)PerlIO_flush(fp);
2348 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2351 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2352 report_evil_fh(gv, io, PL_op->op_type);
2354 SETERRNO(EBADF,RMS_IFI);
2359 DIE(aTHX_ PL_no_func, "flock()");
2369 const int protocol = POPi;
2370 const int type = POPi;
2371 const int domain = POPi;
2372 GV * const gv = MUTABLE_GV(POPs);
2373 register IO * const io = gv ? GvIOn(gv) : NULL;
2377 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2378 report_evil_fh(gv, io, PL_op->op_type);
2379 if (io && IoIFP(io))
2380 do_close(gv, FALSE);
2381 SETERRNO(EBADF,LIB_INVARG);
2386 do_close(gv, FALSE);
2388 TAINT_PROPER("socket");
2389 fd = PerlSock_socket(domain, type, protocol);
2392 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2393 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2394 IoTYPE(io) = IoTYPE_SOCKET;
2395 if (!IoIFP(io) || !IoOFP(io)) {
2396 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2397 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2398 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2401 #if defined(HAS_FCNTL) && defined(F_SETFD)
2402 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2406 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2411 DIE(aTHX_ PL_no_sock_func, "socket");
2417 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2419 const int protocol = POPi;
2420 const int type = POPi;
2421 const int domain = POPi;
2422 GV * const gv2 = MUTABLE_GV(POPs);
2423 GV * const gv1 = MUTABLE_GV(POPs);
2424 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2425 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2428 if (!gv1 || !gv2 || !io1 || !io2) {
2429 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2431 report_evil_fh(gv1, io1, PL_op->op_type);
2433 report_evil_fh(gv1, io2, PL_op->op_type);
2435 if (io1 && IoIFP(io1))
2436 do_close(gv1, FALSE);
2437 if (io2 && IoIFP(io2))
2438 do_close(gv2, FALSE);
2443 do_close(gv1, FALSE);
2445 do_close(gv2, FALSE);
2447 TAINT_PROPER("socketpair");
2448 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2450 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2451 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2452 IoTYPE(io1) = IoTYPE_SOCKET;
2453 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2454 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2455 IoTYPE(io2) = IoTYPE_SOCKET;
2456 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2457 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2458 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2459 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2460 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2461 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2462 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2465 #if defined(HAS_FCNTL) && defined(F_SETFD)
2466 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2467 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2472 DIE(aTHX_ PL_no_sock_func, "socketpair");
2480 SV * const addrsv = POPs;
2481 /* OK, so on what platform does bind modify addr? */
2483 GV * const gv = MUTABLE_GV(POPs);
2484 register IO * const io = GvIOn(gv);
2487 if (!io || !IoIFP(io))
2490 addr = SvPV_const(addrsv, len);
2491 TAINT_PROPER("bind");
2492 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2498 if (ckWARN(WARN_CLOSED))
2499 report_evil_fh(gv, io, PL_op->op_type);
2500 SETERRNO(EBADF,SS_IVCHAN);
2503 DIE(aTHX_ PL_no_sock_func, "bind");
2511 SV * const addrsv = POPs;
2512 GV * const gv = MUTABLE_GV(POPs);
2513 register IO * const io = GvIOn(gv);
2517 if (!io || !IoIFP(io))
2520 addr = SvPV_const(addrsv, len);
2521 TAINT_PROPER("connect");
2522 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2528 if (ckWARN(WARN_CLOSED))
2529 report_evil_fh(gv, io, PL_op->op_type);
2530 SETERRNO(EBADF,SS_IVCHAN);
2533 DIE(aTHX_ PL_no_sock_func, "connect");
2541 const int backlog = POPi;
2542 GV * const gv = MUTABLE_GV(POPs);
2543 register IO * const io = gv ? GvIOn(gv) : NULL;
2545 if (!gv || !io || !IoIFP(io))
2548 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2554 if (ckWARN(WARN_CLOSED))
2555 report_evil_fh(gv, io, PL_op->op_type);
2556 SETERRNO(EBADF,SS_IVCHAN);
2559 DIE(aTHX_ PL_no_sock_func, "listen");
2569 char namebuf[MAXPATHLEN];
2570 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2571 Sock_size_t len = sizeof (struct sockaddr_in);
2573 Sock_size_t len = sizeof namebuf;
2575 GV * const ggv = MUTABLE_GV(POPs);
2576 GV * const ngv = MUTABLE_GV(POPs);
2585 if (!gstio || !IoIFP(gstio))
2589 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2592 /* Some platforms indicate zero length when an AF_UNIX client is
2593 * not bound. Simulate a non-zero-length sockaddr structure in
2595 namebuf[0] = 0; /* sun_len */
2596 namebuf[1] = AF_UNIX; /* sun_family */
2604 do_close(ngv, FALSE);
2605 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2606 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2607 IoTYPE(nstio) = IoTYPE_SOCKET;
2608 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2609 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2610 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2611 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2614 #if defined(HAS_FCNTL) && defined(F_SETFD)
2615 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2619 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2620 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2622 #ifdef __SCO_VERSION__
2623 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2626 PUSHp(namebuf, len);
2630 if (ckWARN(WARN_CLOSED))
2631 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2632 SETERRNO(EBADF,SS_IVCHAN);
2638 DIE(aTHX_ PL_no_sock_func, "accept");
2646 const int how = POPi;
2647 GV * const gv = MUTABLE_GV(POPs);
2648 register IO * const io = GvIOn(gv);
2650 if (!io || !IoIFP(io))
2653 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2657 if (ckWARN(WARN_CLOSED))
2658 report_evil_fh(gv, io, PL_op->op_type);
2659 SETERRNO(EBADF,SS_IVCHAN);
2662 DIE(aTHX_ PL_no_sock_func, "shutdown");
2670 const int optype = PL_op->op_type;
2671 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2672 const unsigned int optname = (unsigned int) POPi;
2673 const unsigned int lvl = (unsigned int) POPi;
2674 GV * const gv = MUTABLE_GV(POPs);
2675 register IO * const io = GvIOn(gv);
2679 if (!io || !IoIFP(io))
2682 fd = PerlIO_fileno(IoIFP(io));
2686 (void)SvPOK_only(sv);
2690 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2697 #if defined(__SYMBIAN32__)
2698 # define SETSOCKOPT_OPTION_VALUE_T void *
2700 # define SETSOCKOPT_OPTION_VALUE_T const char *
2702 /* XXX TODO: We need to have a proper type (a Configure probe,
2703 * etc.) for what the C headers think of the third argument of
2704 * setsockopt(), the option_value read-only buffer: is it
2705 * a "char *", or a "void *", const or not. Some compilers
2706 * don't take kindly to e.g. assuming that "char *" implicitly
2707 * promotes to a "void *", or to explicitly promoting/demoting
2708 * consts to non/vice versa. The "const void *" is the SUS
2709 * definition, but that does not fly everywhere for the above
2711 SETSOCKOPT_OPTION_VALUE_T buf;
2715 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2719 aint = (int)SvIV(sv);
2720 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2723 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2732 if (ckWARN(WARN_CLOSED))
2733 report_evil_fh(gv, io, optype);
2734 SETERRNO(EBADF,SS_IVCHAN);
2739 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2747 const int optype = PL_op->op_type;
2748 GV * const gv = MUTABLE_GV(POPs);
2749 register IO * const io = GvIOn(gv);
2754 if (!io || !IoIFP(io))
2757 sv = sv_2mortal(newSV(257));
2758 (void)SvPOK_only(sv);
2762 fd = PerlIO_fileno(IoIFP(io));
2764 case OP_GETSOCKNAME:
2765 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2768 case OP_GETPEERNAME:
2769 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2771 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2773 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";
2774 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2775 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2776 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2777 sizeof(u_short) + sizeof(struct in_addr))) {
2784 #ifdef BOGUS_GETNAME_RETURN
2785 /* Interactive Unix, getpeername() and getsockname()
2786 does not return valid namelen */
2787 if (len == BOGUS_GETNAME_RETURN)
2788 len = sizeof(struct sockaddr);
2796 if (ckWARN(WARN_CLOSED))
2797 report_evil_fh(gv, io, optype);
2798 SETERRNO(EBADF,SS_IVCHAN);
2803 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2818 if (PL_op->op_flags & OPf_REF) {
2820 if (PL_op->op_type == OP_LSTAT) {
2821 if (gv != PL_defgv) {
2822 do_fstat_warning_check:
2823 if (ckWARN(WARN_IO))
2824 Perl_warner(aTHX_ packWARN(WARN_IO),
2825 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2826 } else if (PL_laststype != OP_LSTAT)
2827 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2831 if (gv != PL_defgv) {
2832 PL_laststype = OP_STAT;
2834 sv_setpvs(PL_statname, "");
2841 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2842 } else if (IoDIRP(io)) {
2844 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2846 PL_laststatval = -1;
2852 if (PL_laststatval < 0) {
2853 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2854 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2859 SV* const sv = POPs;
2860 if (isGV_with_GP(sv)) {
2861 gv = MUTABLE_GV(sv);
2863 } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2864 gv = MUTABLE_GV(SvRV(sv));
2865 if (PL_op->op_type == OP_LSTAT)
2866 goto do_fstat_warning_check;
2868 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2869 io = MUTABLE_IO(SvRV(sv));
2870 if (PL_op->op_type == OP_LSTAT)
2871 goto do_fstat_warning_check;
2872 goto do_fstat_have_io;
2875 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2877 PL_laststype = PL_op->op_type;
2878 if (PL_op->op_type == OP_LSTAT)
2879 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2881 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2882 if (PL_laststatval < 0) {
2883 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2884 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2890 if (gimme != G_ARRAY) {
2891 if (gimme != G_VOID)
2892 XPUSHs(boolSV(max));
2898 mPUSHi(PL_statcache.st_dev);
2899 mPUSHi(PL_statcache.st_ino);
2900 mPUSHu(PL_statcache.st_mode);
2901 mPUSHu(PL_statcache.st_nlink);
2902 #if Uid_t_size > IVSIZE
2903 mPUSHn(PL_statcache.st_uid);
2905 # if Uid_t_sign <= 0
2906 mPUSHi(PL_statcache.st_uid);
2908 mPUSHu(PL_statcache.st_uid);
2911 #if Gid_t_size > IVSIZE
2912 mPUSHn(PL_statcache.st_gid);
2914 # if Gid_t_sign <= 0
2915 mPUSHi(PL_statcache.st_gid);
2917 mPUSHu(PL_statcache.st_gid);
2920 #ifdef USE_STAT_RDEV
2921 mPUSHi(PL_statcache.st_rdev);
2923 PUSHs(newSVpvs_flags("", SVs_TEMP));
2925 #if Off_t_size > IVSIZE
2926 mPUSHn(PL_statcache.st_size);
2928 mPUSHi(PL_statcache.st_size);
2931 mPUSHn(PL_statcache.st_atime);
2932 mPUSHn(PL_statcache.st_mtime);
2933 mPUSHn(PL_statcache.st_ctime);
2935 mPUSHi(PL_statcache.st_atime);
2936 mPUSHi(PL_statcache.st_mtime);
2937 mPUSHi(PL_statcache.st_ctime);
2939 #ifdef USE_STAT_BLOCKS
2940 mPUSHu(PL_statcache.st_blksize);
2941 mPUSHu(PL_statcache.st_blocks);
2943 PUSHs(newSVpvs_flags("", SVs_TEMP));
2944 PUSHs(newSVpvs_flags("", SVs_TEMP));
2950 /* This macro is used by the stacked filetest operators :
2951 * if the previous filetest failed, short-circuit and pass its value.
2952 * Else, discard it from the stack and continue. --rgs
2954 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2955 if (!SvTRUE(TOPs)) { RETURN; } \
2956 else { (void)POPs; PUTBACK; } \
2963 /* Not const, because things tweak this below. Not bool, because there's
2964 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2965 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2966 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2967 /* Giving some sort of initial value silences compilers. */
2969 int access_mode = R_OK;
2971 int access_mode = 0;
2974 /* access_mode is never used, but leaving use_access in makes the
2975 conditional compiling below much clearer. */
2978 int stat_mode = S_IRUSR;
2980 bool effective = FALSE;
2984 switch (PL_op->op_type) {
2985 case OP_FTRREAD: opchar = 'R'; break;
2986 case OP_FTRWRITE: opchar = 'W'; break;
2987 case OP_FTREXEC: opchar = 'X'; break;
2988 case OP_FTEREAD: opchar = 'r'; break;
2989 case OP_FTEWRITE: opchar = 'w'; break;
2990 case OP_FTEEXEC: opchar = 'x'; break;
2992 tryAMAGICftest(opchar);
2994 STACKED_FTEST_CHECK;
2996 switch (PL_op->op_type) {
2998 #if !(defined(HAS_ACCESS) && defined(R_OK))
3004 #if defined(HAS_ACCESS) && defined(W_OK)
3009 stat_mode = S_IWUSR;
3013 #if defined(HAS_ACCESS) && defined(X_OK)
3018 stat_mode = S_IXUSR;
3022 #ifdef PERL_EFF_ACCESS
3025 stat_mode = S_IWUSR;
3029 #ifndef PERL_EFF_ACCESS
3036 #ifdef PERL_EFF_ACCESS
3041 stat_mode = S_IXUSR;
3047 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3048 const char *name = POPpx;
3050 # ifdef PERL_EFF_ACCESS
3051 result = PERL_EFF_ACCESS(name, access_mode);
3053 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3059 result = access(name, access_mode);
3061 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3076 if (cando(stat_mode, effective, &PL_statcache))
3085 const int op_type = PL_op->op_type;
3090 case OP_FTIS: opchar = 'e'; break;
3091 case OP_FTSIZE: opchar = 's'; break;
3092 case OP_FTMTIME: opchar = 'M'; break;
3093 case OP_FTCTIME: opchar = 'C'; break;
3094 case OP_FTATIME: opchar = 'A'; break;
3096 tryAMAGICftest(opchar);
3098 STACKED_FTEST_CHECK;
3104 if (op_type == OP_FTIS)
3107 /* You can't dTARGET inside OP_FTIS, because you'll get
3108 "panic: pad_sv po" - the op is not flagged to have a target. */
3112 #if Off_t_size > IVSIZE
3113 PUSHn(PL_statcache.st_size);
3115 PUSHi(PL_statcache.st_size);
3119 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3122 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3125 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3139 switch (PL_op->op_type) {
3140 case OP_FTROWNED: opchar = 'O'; break;
3141 case OP_FTEOWNED: opchar = 'o'; break;
3142 case OP_FTZERO: opchar = 'z'; break;
3143 case OP_FTSOCK: opchar = 'S'; break;
3144 case OP_FTCHR: opchar = 'c'; break;
3145 case OP_FTBLK: opchar = 'b'; break;
3146 case OP_FTFILE: opchar = 'f'; break;
3147 case OP_FTDIR: opchar = 'd'; break;
3148 case OP_FTPIPE: opchar = 'p'; break;
3149 case OP_FTSUID: opchar = 'u'; break;
3150 case OP_FTSGID: opchar = 'g'; break;
3151 case OP_FTSVTX: opchar = 'k'; break;
3153 tryAMAGICftest(opchar);
3155 /* I believe that all these three are likely to be defined on most every
3156 system these days. */
3158 if(PL_op->op_type == OP_FTSUID)
3162 if(PL_op->op_type == OP_FTSGID)
3166 if(PL_op->op_type == OP_FTSVTX)
3170 STACKED_FTEST_CHECK;
3176 switch (PL_op->op_type) {
3178 if (PL_statcache.st_uid == PL_uid)
3182 if (PL_statcache.st_uid == PL_euid)
3186 if (PL_statcache.st_size == 0)
3190 if (S_ISSOCK(PL_statcache.st_mode))
3194 if (S_ISCHR(PL_statcache.st_mode))
3198 if (S_ISBLK(PL_statcache.st_mode))
3202 if (S_ISREG(PL_statcache.st_mode))
3206 if (S_ISDIR(PL_statcache.st_mode))
3210 if (S_ISFIFO(PL_statcache.st_mode))
3215 if (PL_statcache.st_mode & S_ISUID)
3221 if (PL_statcache.st_mode & S_ISGID)
3227 if (PL_statcache.st_mode & S_ISVTX)
3241 tryAMAGICftest('l');
3242 result = my_lstat();
3247 if (S_ISLNK(PL_statcache.st_mode))
3260 tryAMAGICftest('t');
3262 STACKED_FTEST_CHECK;
3264 if (PL_op->op_flags & OPf_REF)
3266 else if (isGV(TOPs))
3267 gv = MUTABLE_GV(POPs);
3268 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3269 gv = MUTABLE_GV(SvRV(POPs));
3271 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3273 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3274 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3275 else if (tmpsv && SvOK(tmpsv)) {
3276 const char *tmps = SvPV_nolen_const(tmpsv);
3284 if (PerlLIO_isatty(fd))
3289 #if defined(atarist) /* this will work with atariST. Configure will
3290 make guesses for other systems. */
3291 # define FILE_base(f) ((f)->_base)
3292 # define FILE_ptr(f) ((f)->_ptr)
3293 # define FILE_cnt(f) ((f)->_cnt)
3294 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3305 register STDCHAR *s;
3311 tryAMAGICftest(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3313 STACKED_FTEST_CHECK;
3315 if (PL_op->op_flags & OPf_REF)
3317 else if (isGV(TOPs))
3318 gv = MUTABLE_GV(POPs);
3319 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3320 gv = MUTABLE_GV(SvRV(POPs));
3326 if (gv == PL_defgv) {
3328 io = GvIO(PL_statgv);
3331 goto really_filename;
3336 PL_laststatval = -1;
3337 sv_setpvs(PL_statname, "");
3338 io = GvIO(PL_statgv);
3340 if (io && IoIFP(io)) {
3341 if (! PerlIO_has_base(IoIFP(io)))
3342 DIE(aTHX_ "-T and -B not implemented on filehandles");
3343 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3344 if (PL_laststatval < 0)
3346 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3347 if (PL_op->op_type == OP_FTTEXT)
3352 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3353 i = PerlIO_getc(IoIFP(io));
3355 (void)PerlIO_ungetc(IoIFP(io),i);
3357 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3359 len = PerlIO_get_bufsiz(IoIFP(io));
3360 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3361 /* sfio can have large buffers - limit to 512 */
3366 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3368 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3370 SETERRNO(EBADF,RMS_IFI);
3378 PL_laststype = OP_STAT;
3379 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3380 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3381 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3383 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3386 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3387 if (PL_laststatval < 0) {
3388 (void)PerlIO_close(fp);
3391 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3392 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3393 (void)PerlIO_close(fp);
3395 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3396 RETPUSHNO; /* special case NFS directories */
3397 RETPUSHYES; /* null file is anything */
3402 /* now scan s to look for textiness */
3403 /* XXX ASCII dependent code */
3405 #if defined(DOSISH) || defined(USEMYBINMODE)
3406 /* ignore trailing ^Z on short files */
3407 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3411 for (i = 0; i < len; i++, s++) {
3412 if (!*s) { /* null never allowed in text */
3417 else if (!(isPRINT(*s) || isSPACE(*s)))
3420 else if (*s & 128) {
3422 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3425 /* utf8 characters don't count as odd */
3426 if (UTF8_IS_START(*s)) {
3427 int ulen = UTF8SKIP(s);
3428 if (ulen < len - i) {
3430 for (j = 1; j < ulen; j++) {
3431 if (!UTF8_IS_CONTINUATION(s[j]))
3434 --ulen; /* loop does extra increment */
3444 *s != '\n' && *s != '\r' && *s != '\b' &&
3445 *s != '\t' && *s != '\f' && *s != 27)
3450 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3461 const char *tmps = NULL;
3465 SV * const sv = POPs;
3466 if (PL_op->op_flags & OPf_SPECIAL) {
3467 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3469 else if (isGV_with_GP(sv)) {
3470 gv = MUTABLE_GV(sv);
3472 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
3473 gv = MUTABLE_GV(SvRV(sv));
3476 tmps = SvPV_nolen_const(sv);
3480 if( !gv && (!tmps || !*tmps) ) {
3481 HV * const table = GvHVn(PL_envgv);
3484 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3485 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3487 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3492 deprecate("chdir('') or chdir(undef) as chdir()");
3493 tmps = SvPV_nolen_const(*svp);
3497 TAINT_PROPER("chdir");
3502 TAINT_PROPER("chdir");
3505 IO* const io = GvIO(gv);
3508 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3509 } else if (IoIFP(io)) {
3510 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3513 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3514 report_evil_fh(gv, io, PL_op->op_type);
3515 SETERRNO(EBADF, RMS_IFI);
3520 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3521 report_evil_fh(gv, io, PL_op->op_type);
3522 SETERRNO(EBADF,RMS_IFI);
3526 DIE(aTHX_ PL_no_func, "fchdir");
3530 PUSHi( PerlDir_chdir(tmps) >= 0 );
3532 /* Clear the DEFAULT element of ENV so we'll get the new value
3534 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3541 dVAR; dSP; dMARK; dTARGET;
3542 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3553 char * const tmps = POPpx;
3554 TAINT_PROPER("chroot");
3555 PUSHi( chroot(tmps) >= 0 );
3558 DIE(aTHX_ PL_no_func, "chroot");
3566 const char * const tmps2 = POPpconstx;
3567 const char * const tmps = SvPV_nolen_const(TOPs);
3568 TAINT_PROPER("rename");
3570 anum = PerlLIO_rename(tmps, tmps2);
3572 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3573 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3576 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3577 (void)UNLINK(tmps2);
3578 if (!(anum = link(tmps, tmps2)))
3579 anum = UNLINK(tmps);
3587 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3591 const int op_type = PL_op->op_type;
3595 if (op_type == OP_LINK)
3596 DIE(aTHX_ PL_no_func, "link");
3598 # ifndef HAS_SYMLINK
3599 if (op_type == OP_SYMLINK)
3600 DIE(aTHX_ PL_no_func, "symlink");
3604 const char * const tmps2 = POPpconstx;
3605 const char * const tmps = SvPV_nolen_const(TOPs);
3606 TAINT_PROPER(PL_op_desc[op_type]);
3608 # if defined(HAS_LINK)
3609 # if defined(HAS_SYMLINK)
3610 /* Both present - need to choose which. */
3611 (op_type == OP_LINK) ?
3612 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3614 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3615 PerlLIO_link(tmps, tmps2);
3618 # if defined(HAS_SYMLINK)
3619 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3620 symlink(tmps, tmps2);
3625 SETi( result >= 0 );
3632 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3643 char buf[MAXPATHLEN];
3646 #ifndef INCOMPLETE_TAINTS
3650 len = readlink(tmps, buf, sizeof(buf) - 1);
3658 RETSETUNDEF; /* just pretend it's a normal file */
3662 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3664 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3666 char * const save_filename = filename;
3671 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3673 PERL_ARGS_ASSERT_DOONELINER;
3675 Newx(cmdline, size, char);
3676 my_strlcpy(cmdline, cmd, size);
3677 my_strlcat(cmdline, " ", size);
3678 for (s = cmdline + strlen(cmdline); *filename; ) {
3682 if (s - cmdline < size)
3683 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3684 myfp = PerlProc_popen(cmdline, "r");
3688 SV * const tmpsv = sv_newmortal();
3689 /* Need to save/restore 'PL_rs' ?? */
3690 s = sv_gets(tmpsv, myfp, 0);
3691 (void)PerlProc_pclose(myfp);
3695 #ifdef HAS_SYS_ERRLIST
3700 /* you don't see this */
3701 const char * const errmsg =
3702 #ifdef HAS_SYS_ERRLIST
3710 if (instr(s, errmsg)) {
3717 #define EACCES EPERM
3719 if (instr(s, "cannot make"))
3720 SETERRNO(EEXIST,RMS_FEX);
3721 else if (instr(s, "existing file"))
3722 SETERRNO(EEXIST,RMS_FEX);
3723 else if (instr(s, "ile exists"))
3724 SETERRNO(EEXIST,RMS_FEX);
3725 else if (instr(s, "non-exist"))
3726 SETERRNO(ENOENT,RMS_FNF);
3727 else if (instr(s, "does not exist"))
3728 SETERRNO(ENOENT,RMS_FNF);
3729 else if (instr(s, "not empty"))
3730 SETERRNO(EBUSY,SS_DEVOFFLINE);
3731 else if (instr(s, "cannot access"))
3732 SETERRNO(EACCES,RMS_PRV);
3734 SETERRNO(EPERM,RMS_PRV);
3737 else { /* some mkdirs return no failure indication */
3738 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3739 if (PL_op->op_type == OP_RMDIR)
3744 SETERRNO(EACCES,RMS_PRV); /* a guess */
3753 /* This macro removes trailing slashes from a directory name.
3754 * Different operating and file systems take differently to
3755 * trailing slashes. According to POSIX 1003.1 1996 Edition
3756 * any number of trailing slashes should be allowed.
3757 * Thusly we snip them away so that even non-conforming
3758 * systems are happy.
3759 * We should probably do this "filtering" for all
3760 * the functions that expect (potentially) directory names:
3761 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3762 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3764 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3765 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3768 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3769 (tmps) = savepvn((tmps), (len)); \
3779 const int mode = (MAXARG > 1) ? POPi : 0777;
3781 TRIMSLASHES(tmps,len,copy);
3783 TAINT_PROPER("mkdir");
3785 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3789 SETi( dooneliner("mkdir", tmps) );
3790 oldumask = PerlLIO_umask(0);
3791 PerlLIO_umask(oldumask);
3792 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3807 TRIMSLASHES(tmps,len,copy);
3808 TAINT_PROPER("rmdir");
3810 SETi( PerlDir_rmdir(tmps) >= 0 );
3812 SETi( dooneliner("rmdir", tmps) );
3819 /* Directory calls. */
3823 #if defined(Direntry_t) && defined(HAS_READDIR)
3825 const char * const dirname = POPpconstx;
3826 GV * const gv = MUTABLE_GV(POPs);
3827 register IO * const io = GvIOn(gv);
3832 if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED))
3833 Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3834 "Opening filehandle %s also as a directory", GvENAME(gv));
3836 PerlDir_close(IoDIRP(io));
3837 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3843 SETERRNO(EBADF,RMS_DIR);
3846 DIE(aTHX_ PL_no_dir_func, "opendir");
3852 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3853 DIE(aTHX_ PL_no_dir_func, "readdir");
3855 #if !defined(I_DIRENT) && !defined(VMS)
3856 Direntry_t *readdir (DIR *);
3862 const I32 gimme = GIMME;
3863 GV * const gv = MUTABLE_GV(POPs);
3864 register const Direntry_t *dp;
3865 register IO * const io = GvIOn(gv);
3867 if (!io || !IoDIRP(io)) {
3868 if(ckWARN(WARN_IO)) {
3869 Perl_warner(aTHX_ packWARN(WARN_IO),
3870 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3876 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3880 sv = newSVpvn(dp->d_name, dp->d_namlen);
3882 sv = newSVpv(dp->d_name, 0);
3884 #ifndef INCOMPLETE_TAINTS
3885 if (!(IoFLAGS(io) & IOf_UNTAINT))
3889 } while (gimme == G_ARRAY);
3891 if (!dp && gimme != G_ARRAY)
3898 SETERRNO(EBADF,RMS_ISI);
3899 if (GIMME == G_ARRAY)
3908 #if defined(HAS_TELLDIR) || defined(telldir)
3910 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3911 /* XXX netbsd still seemed to.
3912 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3913 --JHI 1999-Feb-02 */
3914 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3915 long telldir (DIR *);
3917 GV * const gv = MUTABLE_GV(POPs);
3918 register IO * const io = GvIOn(gv);
3920 if (!io || !IoDIRP(io)) {
3921 if(ckWARN(WARN_IO)) {
3922 Perl_warner(aTHX_ packWARN(WARN_IO),
3923 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3928 PUSHi( PerlDir_tell(IoDIRP(io)) );
3932 SETERRNO(EBADF,RMS_ISI);
3935 DIE(aTHX_ PL_no_dir_func, "telldir");
3941 #if defined(HAS_SEEKDIR) || defined(seekdir)
3943 const long along = POPl;
3944 GV * const gv = MUTABLE_GV(POPs);
3945 register IO * const io = GvIOn(gv);
3947 if (!io || !IoDIRP(io)) {
3948 if(ckWARN(WARN_IO)) {
3949 Perl_warner(aTHX_ packWARN(WARN_IO),
3950 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3954 (void)PerlDir_seek(IoDIRP(io), along);
3959 SETERRNO(EBADF,RMS_ISI);
3962 DIE(aTHX_ PL_no_dir_func, "seekdir");
3968 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3970 GV * const gv = MUTABLE_GV(POPs);
3971 register IO * const io = GvIOn(gv);
3973 if (!io || !IoDIRP(io)) {
3974 if(ckWARN(WARN_IO)) {
3975 Perl_warner(aTHX_ packWARN(WARN_IO),
3976 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3980 (void)PerlDir_rewind(IoDIRP(io));
3984 SETERRNO(EBADF,RMS_ISI);
3987 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3993 #if defined(Direntry_t) && defined(HAS_READDIR)
3995 GV * const gv = MUTABLE_GV(POPs);
3996 register IO * const io = GvIOn(gv);
3998 if (!io || !IoDIRP(io)) {
3999 if(ckWARN(WARN_IO)) {
4000 Perl_warner(aTHX_ packWARN(WARN_IO),
4001 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
4005 #ifdef VOID_CLOSEDIR
4006 PerlDir_close(IoDIRP(io));
4008 if (PerlDir_close(IoDIRP(io)) < 0) {
4009 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4018 SETERRNO(EBADF,RMS_IFI);
4021 DIE(aTHX_ PL_no_dir_func, "closedir");
4025 /* Process control. */
4034 PERL_FLUSHALL_FOR_CHILD;
4035 childpid = PerlProc_fork();
4039 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
4041 SvREADONLY_off(GvSV(tmpgv));
4042 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4043 SvREADONLY_on(GvSV(tmpgv));
4045 #ifdef THREADS_HAVE_PIDS
4046 PL_ppid = (IV)getppid();
4048 #ifdef PERL_USES_PL_PIDSTATUS
4049 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4055 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4060 PERL_FLUSHALL_FOR_CHILD;
4061 childpid = PerlProc_fork();
4067 DIE(aTHX_ PL_no_func, "fork");
4074 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4079 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4080 childpid = wait4pid(-1, &argflags, 0);
4082 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4087 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4088 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4089 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4091 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4096 DIE(aTHX_ PL_no_func, "wait");
4102 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4104 const int optype = POPi;
4105 const Pid_t pid = TOPi;
4109 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4110 result = wait4pid(pid, &argflags, optype);
4112 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4117 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4118 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4119 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4121 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4126 DIE(aTHX_ PL_no_func, "waitpid");
4132 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4133 #if defined(__LIBCATAMOUNT__)
4134 PL_statusvalue = -1;
4143 while (++MARK <= SP) {
4144 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4149 TAINT_PROPER("system");
4151 PERL_FLUSHALL_FOR_CHILD;
4152 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4158 if (PerlProc_pipe(pp) >= 0)
4160 while ((childpid = PerlProc_fork()) == -1) {
4161 if (errno != EAGAIN) {
4166 PerlLIO_close(pp[0]);
4167 PerlLIO_close(pp[1]);
4174 Sigsave_t ihand,qhand; /* place to save signals during system() */
4178 PerlLIO_close(pp[1]);
4180 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4181 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4184 result = wait4pid(childpid, &status, 0);
4185 } while (result == -1 && errno == EINTR);
4187 (void)rsignal_restore(SIGINT, &ihand);
4188 (void)rsignal_restore(SIGQUIT, &qhand);
4190 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4191 do_execfree(); /* free any memory child malloced on fork */
4198 while (n < sizeof(int)) {
4199 n1 = PerlLIO_read(pp[0],
4200 (void*)(((char*)&errkid)+n),
4206 PerlLIO_close(pp[0]);
4207 if (n) { /* Error */
4208 if (n != sizeof(int))
4209 DIE(aTHX_ "panic: kid popen errno read");
4210 errno = errkid; /* Propagate errno from kid */
4211 STATUS_NATIVE_CHILD_SET(-1);
4214 XPUSHi(STATUS_CURRENT);
4218 PerlLIO_close(pp[0]);
4219 #if defined(HAS_FCNTL) && defined(F_SETFD)
4220 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4223 if (PL_op->op_flags & OPf_STACKED) {
4224 SV * const really = *++MARK;
4225 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4227 else if (SP - MARK != 1)
4228 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4230 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4234 #else /* ! FORK or VMS or OS/2 */
4237 if (PL_op->op_flags & OPf_STACKED) {
4238 SV * const really = *++MARK;
4239 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4240 value = (I32)do_aspawn(really, MARK, SP);
4242 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4245 else if (SP - MARK != 1) {
4246 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4247 value = (I32)do_aspawn(NULL, MARK, SP);
4249 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4253 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4255 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4257 STATUS_NATIVE_CHILD_SET(value);
4260 XPUSHi(result ? value : STATUS_CURRENT);
4261 #endif /* !FORK or VMS or OS/2 */
4268 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4273 while (++MARK <= SP) {
4274 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4279 TAINT_PROPER("exec");
4281 PERL_FLUSHALL_FOR_CHILD;
4282 if (PL_op->op_flags & OPf_STACKED) {
4283 SV * const really = *++MARK;
4284 value = (I32)do_aexec(really, MARK, SP);
4286 else if (SP - MARK != 1)
4288 value = (I32)vms_do_aexec(NULL, MARK, SP);
4292 (void ) do_aspawn(NULL, MARK, SP);
4296 value = (I32)do_aexec(NULL, MARK, SP);
4301 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4304 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4307 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4321 # ifdef THREADS_HAVE_PIDS
4322 if (PL_ppid != 1 && getppid() == 1)
4323 /* maybe the parent process has died. Refresh ppid cache */
4327 XPUSHi( getppid() );
4331 DIE(aTHX_ PL_no_func, "getppid");
4340 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4343 pgrp = (I32)BSD_GETPGRP(pid);
4345 if (pid != 0 && pid != PerlProc_getpid())
4346 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4352 DIE(aTHX_ PL_no_func, "getpgrp()");
4372 TAINT_PROPER("setpgrp");
4374 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4376 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4377 || (pid != 0 && pid != PerlProc_getpid()))
4379 DIE(aTHX_ "setpgrp can't take arguments");
4381 SETi( setpgrp() >= 0 );
4382 #endif /* USE_BSDPGRP */
4385 DIE(aTHX_ PL_no_func, "setpgrp()");
4391 #ifdef HAS_GETPRIORITY
4393 const int who = POPi;
4394 const int which = TOPi;
4395 SETi( getpriority(which, who) );
4398 DIE(aTHX_ PL_no_func, "getpriority()");
4404 #ifdef HAS_SETPRIORITY
4406 const int niceval = POPi;
4407 const int who = POPi;
4408 const int which = TOPi;
4409 TAINT_PROPER("setpriority");
4410 SETi( setpriority(which, who, niceval) >= 0 );
4413 DIE(aTHX_ PL_no_func, "setpriority()");
4423 XPUSHn( time(NULL) );
4425 XPUSHi( time(NULL) );
4437 (void)PerlProc_times(&PL_timesbuf);
4439 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4440 /* struct tms, though same data */
4444 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4445 if (GIMME == G_ARRAY) {
4446 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4447 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4448 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4456 if (GIMME == G_ARRAY) {
4463 DIE(aTHX_ "times not implemented");
4465 #endif /* HAS_TIMES */
4472 #if defined(PERL_MICRO) || !defined(Quad_t)
4474 const struct tm *err;
4481 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4482 static const char * const dayname[] =
4483 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4484 static const char * const monname[] =
4485 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4486 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4488 #if defined(PERL_MICRO) || !defined(Quad_t)
4492 when = (Time_t)SvIVx(POPs);
4494 if (PL_op->op_type == OP_LOCALTIME)
4495 err = localtime(&when);
4497 err = gmtime(&when);
4505 when = (Time64_T)now;
4508 /* XXX POPq uses an SvIV so it won't work with 32 bit integer scalars
4509 using a double causes an unfortunate loss of accuracy on high numbers.
4510 What we really need is an SvQV.
4512 double input = Perl_floor(POPn);
4513 when = (Time64_T)input;
4514 if (when != input && ckWARN(WARN_OVERFLOW)) {
4515 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4516 "%s(%.0f) too large", opname, input);
4520 if (PL_op->op_type == OP_LOCALTIME)
4521 err = S_localtime64_r(&when, &tmbuf);
4523 err = S_gmtime64_r(&when, &tmbuf);
4526 if (err == NULL && ckWARN(WARN_OVERFLOW)) {
4527 /* XXX %lld broken for quads */
4528 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4529 "%s(%.0f) failed", opname, (double)when);
4532 if (GIMME != G_ARRAY) { /* scalar context */
4534 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4535 double year = (double)tmbuf.tm_year + 1900;
4542 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4543 dayname[tmbuf.tm_wday],
4544 monname[tmbuf.tm_mon],
4552 else { /* list context */
4558 mPUSHi(tmbuf.tm_sec);
4559 mPUSHi(tmbuf.tm_min);
4560 mPUSHi(tmbuf.tm_hour);
4561 mPUSHi(tmbuf.tm_mday);
4562 mPUSHi(tmbuf.tm_mon);
4563 mPUSHn(tmbuf.tm_year);
4564 mPUSHi(tmbuf.tm_wday);
4565 mPUSHi(tmbuf.tm_yday);
4566 mPUSHi(tmbuf.tm_isdst);
4577 anum = alarm((unsigned int)anum);
4584 DIE(aTHX_ PL_no_func, "alarm");
4595 (void)time(&lasttime);
4600 PerlProc_sleep((unsigned int)duration);
4603 XPUSHi(when - lasttime);
4607 /* Shared memory. */
4608 /* Merged with some message passing. */
4612 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4613 dVAR; dSP; dMARK; dTARGET;
4614 const int op_type = PL_op->op_type;
4619 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4622 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4625 value = (I32)(do_semop(MARK, SP) >= 0);
4628 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4644 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4645 dVAR; dSP; dMARK; dTARGET;
4646 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4653 DIE(aTHX_ "System V IPC is not implemented on this machine");
4659 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4660 dVAR; dSP; dMARK; dTARGET;
4661 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4669 PUSHp(zero_but_true, ZBTLEN);
4677 /* I can't const this further without getting warnings about the types of
4678 various arrays passed in from structures. */
4680 S_space_join_names_mortal(pTHX_ char *const *array)
4684 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4686 if (array && *array) {
4687 target = newSVpvs_flags("", SVs_TEMP);
4689 sv_catpv(target, *array);
4692 sv_catpvs(target, " ");
4695 target = sv_mortalcopy(&PL_sv_no);
4700 /* Get system info. */
4704 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4706 I32 which = PL_op->op_type;
4707 register char **elem;
4709 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4710 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4711 struct hostent *gethostbyname(Netdb_name_t);
4712 struct hostent *gethostent(void);
4714 struct hostent *hent;
4718 if (which == OP_GHBYNAME) {
4719 #ifdef HAS_GETHOSTBYNAME
4720 const char* const name = POPpbytex;
4721 hent = PerlSock_gethostbyname(name);
4723 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4726 else if (which == OP_GHBYADDR) {
4727 #ifdef HAS_GETHOSTBYADDR
4728 const int addrtype = POPi;
4729 SV * const addrsv = POPs;
4731 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4733 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4735 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4739 #ifdef HAS_GETHOSTENT
4740 hent = PerlSock_gethostent();
4742 DIE(aTHX_ PL_no_sock_func, "gethostent");
4745 #ifdef HOST_NOT_FOUND
4747 #ifdef USE_REENTRANT_API
4748 # ifdef USE_GETHOSTENT_ERRNO
4749 h_errno = PL_reentrant_buffer->_gethostent_errno;
4752 STATUS_UNIX_SET(h_errno);
4756 if (GIMME != G_ARRAY) {
4757 PUSHs(sv = sv_newmortal());
4759 if (which == OP_GHBYNAME) {
4761 sv_setpvn(sv, hent->h_addr, hent->h_length);
4764 sv_setpv(sv, (char*)hent->h_name);
4770 mPUSHs(newSVpv((char*)hent->h_name, 0));
4771 PUSHs(space_join_names_mortal(hent->h_aliases));
4772 mPUSHi(hent->h_addrtype);
4773 len = hent->h_length;
4776 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4777 mXPUSHp(*elem, len);
4781 mPUSHp(hent->h_addr, len);
4783 PUSHs(sv_mortalcopy(&PL_sv_no));
4788 DIE(aTHX_ PL_no_sock_func, "gethostent");
4794 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4796 I32 which = PL_op->op_type;
4798 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4799 struct netent *getnetbyaddr(Netdb_net_t, int);
4800 struct netent *getnetbyname(Netdb_name_t);
4801 struct netent *getnetent(void);
4803 struct netent *nent;
4805 if (which == OP_GNBYNAME){
4806 #ifdef HAS_GETNETBYNAME
4807 const char * const name = POPpbytex;
4808 nent = PerlSock_getnetbyname(name);
4810 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4813 else if (which == OP_GNBYADDR) {
4814 #ifdef HAS_GETNETBYADDR
4815 const int addrtype = POPi;
4816 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4817 nent = PerlSock_getnetbyaddr(addr, addrtype);
4819 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4823 #ifdef HAS_GETNETENT
4824 nent = PerlSock_getnetent();
4826 DIE(aTHX_ PL_no_sock_func, "getnetent");
4829 #ifdef HOST_NOT_FOUND
4831 #ifdef USE_REENTRANT_API
4832 # ifdef USE_GETNETENT_ERRNO
4833 h_errno = PL_reentrant_buffer->_getnetent_errno;
4836 STATUS_UNIX_SET(h_errno);
4841 if (GIMME != G_ARRAY) {
4842 PUSHs(sv = sv_newmortal());
4844 if (which == OP_GNBYNAME)
4845 sv_setiv(sv, (IV)nent->n_net);
4847 sv_setpv(sv, nent->n_name);
4853 mPUSHs(newSVpv(nent->n_name, 0));
4854 PUSHs(space_join_names_mortal(nent->n_aliases));
4855 mPUSHi(nent->n_addrtype);
4856 mPUSHi(nent->n_net);
4861 DIE(aTHX_ PL_no_sock_func, "getnetent");
4867 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4869 I32 which = PL_op->op_type;
4871 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4872 struct protoent *getprotobyname(Netdb_name_t);
4873 struct protoent *getprotobynumber(int);
4874 struct protoent *getprotoent(void);
4876 struct protoent *pent;
4878 if (which == OP_GPBYNAME) {
4879 #ifdef HAS_GETPROTOBYNAME
4880 const char* const name = POPpbytex;
4881 pent = PerlSock_getprotobyname(name);
4883 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4886 else if (which == OP_GPBYNUMBER) {
4887 #ifdef HAS_GETPROTOBYNUMBER
4888 const int number = POPi;
4889 pent = PerlSock_getprotobynumber(number);
4891 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4895 #ifdef HAS_GETPROTOENT
4896 pent = PerlSock_getprotoent();
4898 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4902 if (GIMME != G_ARRAY) {
4903 PUSHs(sv = sv_newmortal());
4905 if (which == OP_GPBYNAME)
4906 sv_setiv(sv, (IV)pent->p_proto);
4908 sv_setpv(sv, pent->p_name);
4914 mPUSHs(newSVpv(pent->p_name, 0));
4915 PUSHs(space_join_names_mortal(pent->p_aliases));
4916 mPUSHi(pent->p_proto);
4921 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4927 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4929 I32 which = PL_op->op_type;
4931 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4932 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4933 struct servent *getservbyport(int, Netdb_name_t);
4934 struct servent *getservent(void);
4936 struct servent *sent;
4938 if (which == OP_GSBYNAME) {
4939 #ifdef HAS_GETSERVBYNAME
4940 const char * const proto = POPpbytex;
4941 const char * const name = POPpbytex;
4942 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4944 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4947 else if (which == OP_GSBYPORT) {
4948 #ifdef HAS_GETSERVBYPORT
4949 const char * const proto = POPpbytex;
4950 unsigned short port = (unsigned short)POPu;
4952 port = PerlSock_htons(port);
4954 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4956 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4960 #ifdef HAS_GETSERVENT
4961 sent = PerlSock_getservent();
4963 DIE(aTHX_ PL_no_sock_func, "getservent");
4967 if (GIMME != G_ARRAY) {
4968 PUSHs(sv = sv_newmortal());
4970 if (which == OP_GSBYNAME) {
4972 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4974 sv_setiv(sv, (IV)(sent->s_port));
4978 sv_setpv(sv, sent->s_name);
4984 mPUSHs(newSVpv(sent->s_name, 0));
4985 PUSHs(space_join_names_mortal(sent->s_aliases));
4987 mPUSHi(PerlSock_ntohs(sent->s_port));
4989 mPUSHi(sent->s_port);
4991 mPUSHs(newSVpv(sent->s_proto, 0));
4996 DIE(aTHX_ PL_no_sock_func, "getservent");
5002 #ifdef HAS_SETHOSTENT
5004 PerlSock_sethostent(TOPi);
5007 DIE(aTHX_ PL_no_sock_func, "sethostent");
5013 #ifdef HAS_SETNETENT
5015 (void)PerlSock_setnetent(TOPi);
5018 DIE(aTHX_ PL_no_sock_func, "setnetent");
5024 #ifdef HAS_SETPROTOENT
5026 (void)PerlSock_setprotoent(TOPi);
5029 DIE(aTHX_ PL_no_sock_func, "setprotoent");
5035 #ifdef HAS_SETSERVENT
5037 (void)PerlSock_setservent(TOPi);
5040 DIE(aTHX_ PL_no_sock_func, "setservent");
5046 #ifdef HAS_ENDHOSTENT
5048 PerlSock_endhostent();
5052 DIE(aTHX_ PL_no_sock_func, "endhostent");
5058 #ifdef HAS_ENDNETENT
5060 PerlSock_endnetent();
5064 DIE(aTHX_ PL_no_sock_func, "endnetent");
5070 #ifdef HAS_ENDPROTOENT
5072 PerlSock_endprotoent();
5076 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5082 #ifdef HAS_ENDSERVENT
5084 PerlSock_endservent();
5088 DIE(aTHX_ PL_no_sock_func, "endservent");
5096 I32 which = PL_op->op_type;
5098 struct passwd *pwent = NULL;
5100 * We currently support only the SysV getsp* shadow password interface.
5101 * The interface is declared in <shadow.h> and often one needs to link
5102 * with -lsecurity or some such.
5103 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5106 * AIX getpwnam() is clever enough to return the encrypted password
5107 * only if the caller (euid?) is root.
5109 * There are at least three other shadow password APIs. Many platforms
5110 * seem to contain more than one interface for accessing the shadow
5111 * password databases, possibly for compatibility reasons.
5112 * The getsp*() is by far he simplest one, the other two interfaces
5113 * are much more complicated, but also very similar to each other.
5118 * struct pr_passwd *getprpw*();
5119 * The password is in
5120 * char getprpw*(...).ufld.fd_encrypt[]
5121 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5126 * struct es_passwd *getespw*();
5127 * The password is in
5128 * char *(getespw*(...).ufld.fd_encrypt)
5129 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5132 * struct userpw *getuserpw();
5133 * The password is in
5134 * char *(getuserpw(...)).spw_upw_passwd
5135 * (but the de facto standard getpwnam() should work okay)
5137 * Mention I_PROT here so that Configure probes for it.
5139 * In HP-UX for getprpw*() the manual page claims that one should include
5140 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5141 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5142 * and pp_sys.c already includes <shadow.h> if there is such.
5144 * Note that <sys/security.h> is already probed for, but currently
5145 * it is only included in special cases.
5147 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5148 * be preferred interface, even though also the getprpw*() interface
5149 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5150 * One also needs to call set_auth_parameters() in main() before
5151 * doing anything else, whether one is using getespw*() or getprpw*().
5153 * Note that accessing the shadow databases can be magnitudes
5154 * slower than accessing the standard databases.
5159 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5160 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5161 * the pw_comment is left uninitialized. */
5162 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5168 const char* const name = POPpbytex;
5169 pwent = getpwnam(name);
5175 pwent = getpwuid(uid);
5179 # ifdef HAS_GETPWENT
5181 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5182 if (pwent) pwent = getpwnam(pwent->pw_name);
5185 DIE(aTHX_ PL_no_func, "getpwent");
5191 if (GIMME != G_ARRAY) {
5192 PUSHs(sv = sv_newmortal());
5194 if (which == OP_GPWNAM)
5195 # if Uid_t_sign <= 0
5196 sv_setiv(sv, (IV)pwent->pw_uid);
5198 sv_setuv(sv, (UV)pwent->pw_uid);
5201 sv_setpv(sv, pwent->pw_name);
5207 mPUSHs(newSVpv(pwent->pw_name, 0));
5211 /* If we have getspnam(), we try to dig up the shadow
5212 * password. If we are underprivileged, the shadow
5213 * interface will set the errno to EACCES or similar,
5214 * and return a null pointer. If this happens, we will
5215 * use the dummy password (usually "*" or "x") from the
5216 * standard password database.
5218 * In theory we could skip the shadow call completely
5219 * if euid != 0 but in practice we cannot know which
5220 * security measures are guarding the shadow databases
5221 * on a random platform.
5223 * Resist the urge to use additional shadow interfaces.
5224 * Divert the urge to writing an extension instead.
5227 /* Some AIX setups falsely(?) detect some getspnam(), which
5228 * has a different API than the Solaris/IRIX one. */
5229 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5232 const struct spwd * const spwent = getspnam(pwent->pw_name);
5233 /* Save and restore errno so that
5234 * underprivileged attempts seem
5235 * to have never made the unsccessful
5236 * attempt to retrieve the shadow password. */
5238 if (spwent && spwent->sp_pwdp)
5239 sv_setpv(sv, spwent->sp_pwdp);
5243 if (!SvPOK(sv)) /* Use the standard password, then. */
5244 sv_setpv(sv, pwent->pw_passwd);
5247 # ifndef INCOMPLETE_TAINTS
5248 /* passwd is tainted because user himself can diddle with it.
5249 * admittedly not much and in a very limited way, but nevertheless. */
5253 # if Uid_t_sign <= 0
5254 mPUSHi(pwent->pw_uid);
5256 mPUSHu(pwent->pw_uid);
5259 # if Uid_t_sign <= 0
5260 mPUSHi(pwent->pw_gid);
5262 mPUSHu(pwent->pw_gid);
5264 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5265 * because of the poor interface of the Perl getpw*(),
5266 * not because there's some standard/convention saying so.
5267 * A better interface would have been to return a hash,
5268 * but we are accursed by our history, alas. --jhi. */
5270 mPUSHi(pwent->pw_change);
5273 mPUSHi(pwent->pw_quota);
5276 mPUSHs(newSVpv(pwent->pw_age, 0));
5278 /* I think that you can never get this compiled, but just in case. */
5279 PUSHs(sv_mortalcopy(&PL_sv_no));
5284 /* pw_class and pw_comment are mutually exclusive--.
5285 * see the above note for pw_change, pw_quota, and pw_age. */
5287 mPUSHs(newSVpv(pwent->pw_class, 0));
5290 mPUSHs(newSVpv(pwent->pw_comment, 0));
5292 /* I think that you can never get this compiled, but just in case. */
5293 PUSHs(sv_mortalcopy(&PL_sv_no));
5298 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5300 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5302 # ifndef INCOMPLETE_TAINTS
5303 /* pw_gecos is tainted because user himself can diddle with it. */
5307 mPUSHs(newSVpv(pwent->pw_dir, 0));
5309 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5310 # ifndef INCOMPLETE_TAINTS
5311 /* pw_shell is tainted because user himself can diddle with it. */
5316 mPUSHi(pwent->pw_expire);
5321 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5327 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5332 DIE(aTHX_ PL_no_func, "setpwent");
5338 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5343 DIE(aTHX_ PL_no_func, "endpwent");
5351 const I32 which = PL_op->op_type;
5352 const struct group *grent;
5354 if (which == OP_GGRNAM) {
5355 const char* const name = POPpbytex;
5356 grent = (const struct group *)getgrnam(name);
5358 else if (which == OP_GGRGID) {
5359 const Gid_t gid = POPi;
5360 grent = (const struct group *)getgrgid(gid);
5364 grent = (struct group *)getgrent();
5366 DIE(aTHX_ PL_no_func, "getgrent");
5370 if (GIMME != G_ARRAY) {
5371 SV * const sv = sv_newmortal();
5375 if (which == OP_GGRNAM)
5377 sv_setiv(sv, (IV)grent->gr_gid);
5379 sv_setuv(sv, (UV)grent->gr_gid);
5382 sv_setpv(sv, grent->gr_name);
5388 mPUSHs(newSVpv(grent->gr_name, 0));
5391 mPUSHs(newSVpv(grent->gr_passwd, 0));
5393 PUSHs(sv_mortalcopy(&PL_sv_no));
5397 mPUSHi(grent->gr_gid);
5399 mPUSHu(grent->gr_gid);
5402 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5403 /* In UNICOS/mk (_CRAYMPP) the multithreading
5404 * versions (getgrnam_r, getgrgid_r)
5405 * seem to return an illegal pointer
5406 * as the group members list, gr_mem.
5407 * getgrent() doesn't even have a _r version
5408 * but the gr_mem is poisonous anyway.
5409 * So yes, you cannot get the list of group
5410 * members if building multithreaded in UNICOS/mk. */
5411 PUSHs(space_join_names_mortal(grent->gr_mem));
5417 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5423 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5428 DIE(aTHX_ PL_no_func, "setgrent");
5434 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5439 DIE(aTHX_ PL_no_func, "endgrent");
5449 if (!(tmps = PerlProc_getlogin()))
5451 PUSHp(tmps, strlen(tmps));
5454 DIE(aTHX_ PL_no_func, "getlogin");
5458 /* Miscellaneous. */
5463 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5464 register I32 items = SP - MARK;
5465 unsigned long a[20];
5470 while (++MARK <= SP) {
5471 if (SvTAINTED(*MARK)) {
5477 TAINT_PROPER("syscall");
5480 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5481 * or where sizeof(long) != sizeof(char*). But such machines will
5482 * not likely have syscall implemented either, so who cares?
5484 while (++MARK <= SP) {
5485 if (SvNIOK(*MARK) || !i)
5486 a[i++] = SvIV(*MARK);
5487 else if (*MARK == &PL_sv_undef)
5490 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5496 DIE(aTHX_ "Too many args to syscall");
5498 DIE(aTHX_ "Too few args to syscall");
5500 retval = syscall(a[0]);
5503 retval = syscall(a[0],a[1]);
5506 retval = syscall(a[0],a[1],a[2]);
5509 retval = syscall(a[0],a[1],a[2],a[3]);
5512 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5515 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5518 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5521 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5525 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5528 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5531 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5535 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5539 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5543 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5544 a[10],a[11],a[12],a[13]);
5546 #endif /* atarist */
5552 DIE(aTHX_ PL_no_func, "syscall");
5556 #ifdef FCNTL_EMULATE_FLOCK
5558 /* XXX Emulate flock() with fcntl().
5559 What's really needed is a good file locking module.
5563 fcntl_emulate_flock(int fd, int operation)
5567 switch (operation & ~LOCK_NB) {
5569 flock.l_type = F_RDLCK;
5572 flock.l_type = F_WRLCK;
5575 flock.l_type = F_UNLCK;
5581 flock.l_whence = SEEK_SET;
5582 flock.l_start = flock.l_len = (Off_t)0;
5584 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5587 #endif /* FCNTL_EMULATE_FLOCK */
5589 #ifdef LOCKF_EMULATE_FLOCK
5591 /* XXX Emulate flock() with lockf(). This is just to increase
5592 portability of scripts. The calls are not completely
5593 interchangeable. What's really needed is a good file
5597 /* The lockf() constants might have been defined in <unistd.h>.
5598 Unfortunately, <unistd.h> causes troubles on some mixed
5599 (BSD/POSIX) systems, such as SunOS 4.1.3.
5601 Further, the lockf() constants aren't POSIX, so they might not be
5602 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5603 just stick in the SVID values and be done with it. Sigh.
5607 # define F_ULOCK 0 /* Unlock a previously locked region */
5610 # define F_LOCK 1 /* Lock a region for exclusive use */
5613 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5616 # define F_TEST 3 /* Test a region for other processes locks */
5620 lockf_emulate_flock(int fd, int operation)
5626 /* flock locks entire file so for lockf we need to do the same */
5627 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5628 if (pos > 0) /* is seekable and needs to be repositioned */
5629 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5630 pos = -1; /* seek failed, so don't seek back afterwards */
5633 switch (operation) {
5635 /* LOCK_SH - get a shared lock */
5637 /* LOCK_EX - get an exclusive lock */
5639 i = lockf (fd, F_LOCK, 0);
5642 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5643 case LOCK_SH|LOCK_NB:
5644 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5645 case LOCK_EX|LOCK_NB:
5646 i = lockf (fd, F_TLOCK, 0);
5648 if ((errno == EAGAIN) || (errno == EACCES))
5649 errno = EWOULDBLOCK;
5652 /* LOCK_UN - unlock (non-blocking is a no-op) */
5654 case LOCK_UN|LOCK_NB:
5655 i = lockf (fd, F_ULOCK, 0);
5658 /* Default - can't decipher operation */
5665 if (pos > 0) /* need to restore position of the handle */
5666 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5671 #endif /* LOCKF_EMULATE_FLOCK */
5675 * c-indentation-style: bsd
5677 * indent-tabs-mode: t
5680 * ex: set ts=8 sts=4 sw=4 noet: