3 * Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 * 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * But only a short way ahead its floor and the walls on either side were
13 * cloven by a great fissure, out of which the red glare came, now leaping
14 * up, now dying down into darkness; and all the while far below there was
15 * a rumour and a trouble as of great engines throbbing and labouring.
17 * [p.945 of _The Lord of the Rings_, VI/iii: "Mount Doom"]
20 /* This file contains system pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
26 * By 'system', we mean ops which interact with the OS, such as pp_open().
30 #define PERL_IN_PP_SYS_C
36 /* Shadow password support for solaris - pdo@cs.umd.edu
37 * Not just Solaris: at least HP-UX, IRIX, Linux.
38 * The API is from SysV.
40 * There are at least two more shadow interfaces,
41 * see the comments in pp_gpwent().
45 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
46 * and another MAXINT from "perl.h" <- <sys/param.h>. */
53 # include <sys/wait.h>
57 # include <sys/resource.h>
66 # include <sys/select.h>
70 /* XXX Configure test needed.
71 h_errno might not be a simple 'int', especially for multi-threaded
72 applications, see "extern int errno in perl.h". Creating such
73 a test requires taking into account the differences between
74 compiling multithreaded and singlethreaded ($ccflags et al).
75 HOST_NOT_FOUND is typically defined in <netdb.h>.
77 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
86 struct passwd *getpwnam (char *);
87 struct passwd *getpwuid (Uid_t);
92 struct passwd *getpwent (void);
93 #elif defined (VMS) && defined (my_getpwent)
94 struct passwd *Perl_my_getpwent (pTHX);
103 struct group *getgrnam (char *);
104 struct group *getgrgid (Gid_t);
108 struct group *getgrent (void);
114 # if defined(_MSC_VER) || defined(__MINGW32__)
115 # include <sys/utime.h>
122 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
125 # define my_chsize PerlLIO_chsize
128 # define my_chsize PerlLIO_chsize
130 I32 my_chsize(int fd, Off_t length);
136 #else /* no flock() */
138 /* fcntl.h might not have been included, even if it exists, because
139 the current Configure only sets I_FCNTL if it's needed to pick up
140 the *_OK constants. Make sure it has been included before testing
141 the fcntl() locking constants. */
142 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
146 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
147 # define FLOCK fcntl_emulate_flock
148 # define FCNTL_EMULATE_FLOCK
149 # else /* no flock() or fcntl(F_SETLK,...) */
151 # define FLOCK lockf_emulate_flock
152 # define LOCKF_EMULATE_FLOCK
154 # endif /* no flock() or fcntl(F_SETLK,...) */
157 static int FLOCK (int, int);
160 * These are the flock() constants. Since this sytems doesn't have
161 * flock(), the values of the constants are probably not available.
175 # endif /* emulating flock() */
177 #endif /* no flock() */
180 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
182 #if defined(I_SYS_ACCESS) && !defined(R_OK)
183 # include <sys/access.h>
186 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
187 # define FD_CLOEXEC 1 /* NeXT needs this */
193 /* Missing protos on LynxOS */
194 void sethostent(int);
195 void endhostent(void);
197 void endnetent(void);
198 void setprotoent(int);
199 void endprotoent(void);
200 void setservent(int);
201 void endservent(void);
204 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
206 /* F_OK unused: if stat() cannot find it... */
208 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
209 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
210 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
213 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
214 # ifdef I_SYS_SECURITY
215 # include <sys/security.h>
219 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
222 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
226 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
228 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
232 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
233 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
234 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
237 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
239 const Uid_t ruid = getuid();
240 const Uid_t euid = geteuid();
241 const Gid_t rgid = getgid();
242 const Gid_t egid = getegid();
245 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
246 Perl_croak(aTHX_ "switching effective uid is not implemented");
249 if (setreuid(euid, ruid))
252 if (setresuid(euid, ruid, (Uid_t)-1))
255 Perl_croak(aTHX_ "entering effective uid failed");
258 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
259 Perl_croak(aTHX_ "switching effective gid is not implemented");
262 if (setregid(egid, rgid))
265 if (setresgid(egid, rgid, (Gid_t)-1))
268 Perl_croak(aTHX_ "entering effective gid failed");
271 res = access(path, mode);
274 if (setreuid(ruid, euid))
277 if (setresuid(ruid, euid, (Uid_t)-1))
280 Perl_croak(aTHX_ "leaving effective uid failed");
283 if (setregid(rgid, egid))
286 if (setresgid(rgid, egid, (Gid_t)-1))
289 Perl_croak(aTHX_ "leaving effective gid failed");
293 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
300 const char * const tmps = POPpconstx;
301 const I32 gimme = GIMME_V;
302 const char *mode = "r";
305 if (PL_op->op_private & OPpOPEN_IN_RAW)
307 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
309 fp = PerlProc_popen(tmps, mode);
311 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
313 PerlIO_apply_layers(aTHX_ fp,mode,type);
315 if (gimme == G_VOID) {
317 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
320 else if (gimme == G_SCALAR) {
321 ENTER_with_name("backtick");
323 PL_rs = &PL_sv_undef;
324 sv_setpvs(TARG, ""); /* note that this preserves previous buffer */
325 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
327 LEAVE_with_name("backtick");
333 SV * const sv = newSV(79);
334 if (sv_gets(sv, fp, 0) == NULL) {
339 if (SvLEN(sv) - SvCUR(sv) > 20) {
340 SvPV_shrink_to_cur(sv);
345 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
346 TAINT; /* "I believe that this is not gratuitous!" */
349 STATUS_NATIVE_CHILD_SET(-1);
350 if (gimme == G_SCALAR)
361 tryAMAGICunTARGET(iter, -1);
363 /* Note that we only ever get here if File::Glob fails to load
364 * without at the same time croaking, for some reason, or if
365 * perl was built with PERL_EXTERNAL_GLOB */
367 ENTER_with_name("glob");
372 * The external globbing program may use things we can't control,
373 * so for security reasons we must assume the worst.
376 taint_proper(PL_no_security, "glob");
380 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
381 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
383 SAVESPTR(PL_rs); /* This is not permanent, either. */
384 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
387 *SvPVX(PL_rs) = '\n';
391 result = do_readline();
392 LEAVE_with_name("glob");
399 PL_last_in_gv = cGVOP_gv;
400 return do_readline();
411 do_join(TARG, &PL_sv_no, MARK, SP);
415 else if (SP == MARK) {
423 tmps = SvPV_const(tmpsv, len);
424 if ((!tmps || !len) && PL_errgv) {
425 SV * const error = ERRSV;
426 SvUPGRADE(error, SVt_PV);
427 if (SvPOK(error) && SvCUR(error))
428 sv_catpvs(error, "\t...caught");
430 tmps = SvPV_const(tmpsv, len);
433 tmpsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
435 Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv));
447 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
449 if (SP - MARK != 1) {
451 do_join(TARG, &PL_sv_no, MARK, SP);
453 tmps = SvPV_const(tmpsv, len);
459 tmps = SvROK(tmpsv) ? (const char *)NULL : SvPV_const(tmpsv, len);
462 SV * const error = ERRSV;
463 SvUPGRADE(error, SVt_PV);
464 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
466 SvSetSV(error,tmpsv);
467 else if (sv_isobject(error)) {
468 HV * const stash = SvSTASH(SvRV(error));
469 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
471 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
472 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
479 call_sv(MUTABLE_SV(GvCV(gv)),
480 G_SCALAR|G_EVAL|G_KEEPERR);
481 sv_setsv(error,*PL_stack_sp--);
487 if (SvPOK(error) && SvCUR(error))
488 sv_catpvs(error, "\t...propagated");
491 tmps = SvPV_const(tmpsv, len);
497 tmpsv = newSVpvs_flags("Died", SVs_TEMP);
499 DIE(aTHX_ "%"SVf, SVfARG(tmpsv));
516 GV * const gv = MUTABLE_GV(*++MARK);
519 DIE(aTHX_ PL_no_usym, "filehandle");
521 if ((io = GvIOp(gv))) {
523 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
526 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
527 "Opening dirhandle %s also as a file",
530 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
532 /* Method's args are same as ours ... */
533 /* ... except handle is replaced by the object */
534 *MARK-- = SvTIED_obj(MUTABLE_SV(io), mg);
537 ENTER_with_name("call_OPEN");
538 call_method("OPEN", G_SCALAR);
539 LEAVE_with_name("call_OPEN");
552 tmps = SvPV_const(sv, len);
553 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
556 PUSHi( (I32)PL_forkprocess );
557 else if (PL_forkprocess == 0) /* we are a new child */
567 GV * const gv = (MAXARG == 0) ? PL_defoutgv : MUTABLE_GV(POPs);
570 IO * const io = GvIO(gv);
572 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
575 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
577 ENTER_with_name("call_CLOSE");
578 call_method("CLOSE", G_SCALAR);
579 LEAVE_with_name("call_CLOSE");
586 PUSHs(boolSV(do_close(gv, TRUE)));
599 GV * const wgv = MUTABLE_GV(POPs);
600 GV * const rgv = MUTABLE_GV(POPs);
605 if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
606 DIE(aTHX_ PL_no_usym, "filehandle");
611 do_close(rgv, FALSE);
613 do_close(wgv, FALSE);
615 if (PerlProc_pipe(fd) < 0)
618 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
619 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
620 IoOFP(rstio) = IoIFP(rstio);
621 IoIFP(wstio) = IoOFP(wstio);
622 IoTYPE(rstio) = IoTYPE_RDONLY;
623 IoTYPE(wstio) = IoTYPE_WRONLY;
625 if (!IoIFP(rstio) || !IoOFP(wstio)) {
627 PerlIO_close(IoIFP(rstio));
629 PerlLIO_close(fd[0]);
631 PerlIO_close(IoOFP(wstio));
633 PerlLIO_close(fd[1]);
636 #if defined(HAS_FCNTL) && defined(F_SETFD)
637 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
638 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
645 DIE(aTHX_ PL_no_func, "pipe");
660 gv = MUTABLE_GV(POPs);
662 if (gv && (io = GvIO(gv))
663 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
666 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
668 ENTER_with_name("call_FILENO");
669 call_method("FILENO", G_SCALAR);
670 LEAVE_with_name("call_FILENO");
675 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
676 /* Can't do this because people seem to do things like
677 defined(fileno($foo)) to check whether $foo is a valid fh.
678 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
679 report_evil_fh(gv, io, PL_op->op_type);
684 PUSHi(PerlIO_fileno(fp));
697 anum = PerlLIO_umask(022);
698 /* setting it to 022 between the two calls to umask avoids
699 * to have a window where the umask is set to 0 -- meaning
700 * that another thread could create world-writeable files. */
702 (void)PerlLIO_umask(anum);
705 anum = PerlLIO_umask(POPi);
706 TAINT_PROPER("umask");
709 /* Only DIE if trying to restrict permissions on "user" (self).
710 * Otherwise it's harmless and more useful to just return undef
711 * since 'group' and 'other' concepts probably don't exist here. */
712 if (MAXARG >= 1 && (POPi & 0700))
713 DIE(aTHX_ "umask not implemented");
714 XPUSHs(&PL_sv_undef);
733 gv = MUTABLE_GV(POPs);
735 if (gv && (io = GvIO(gv))) {
736 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
739 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
743 ENTER_with_name("call_BINMODE");
744 call_method("BINMODE", G_SCALAR);
745 LEAVE_with_name("call_BINMODE");
752 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
753 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
754 report_evil_fh(gv, io, PL_op->op_type);
755 SETERRNO(EBADF,RMS_IFI);
762 const char *d = NULL;
765 d = SvPV_const(discp, len);
766 mode = mode_from_discipline(d, len);
767 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
768 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
769 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
790 const I32 markoff = MARK - PL_stack_base;
791 const char *methname;
792 int how = PERL_MAGIC_tied;
796 switch(SvTYPE(varsv)) {
798 methname = "TIEHASH";
799 HvEITER_set(MUTABLE_HV(varsv), 0);
802 methname = "TIEARRAY";
805 if (isGV_with_GP(varsv)) {
806 methname = "TIEHANDLE";
807 how = PERL_MAGIC_tiedscalar;
808 /* For tied filehandles, we apply tiedscalar magic to the IO
809 slot of the GP rather than the GV itself. AMS 20010812 */
811 GvIOp(varsv) = newIO();
812 varsv = MUTABLE_SV(GvIOp(varsv));
817 methname = "TIESCALAR";
818 how = PERL_MAGIC_tiedscalar;
822 if (sv_isobject(*MARK)) { /* Calls GET magic. */
823 ENTER_with_name("call_TIE");
824 PUSHSTACKi(PERLSI_MAGIC);
826 EXTEND(SP,(I32)items);
830 call_method(methname, G_SCALAR);
833 /* Not clear why we don't call call_method here too.
834 * perhaps to get different error message ?
837 const char *name = SvPV_nomg_const(*MARK, len);
838 stash = gv_stashpvn(name, len, 0);
839 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
840 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
841 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
843 ENTER_with_name("call_TIE");
844 PUSHSTACKi(PERLSI_MAGIC);
846 EXTEND(SP,(I32)items);
850 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
856 if (sv_isobject(sv)) {
857 sv_unmagic(varsv, how);
858 /* Croak if a self-tie on an aggregate is attempted. */
859 if (varsv == SvRV(sv) &&
860 (SvTYPE(varsv) == SVt_PVAV ||
861 SvTYPE(varsv) == SVt_PVHV))
863 "Self-ties of arrays and hashes are not supported");
864 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
866 LEAVE_with_name("call_TIE");
867 SP = PL_stack_base + markoff;
877 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
878 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
880 if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
883 if ((mg = SvTIED_mg(sv, how))) {
884 SV * const obj = SvRV(SvTIED_obj(sv, mg));
886 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
888 if (gv && isGV(gv) && (cv = GvCV(gv))) {
890 XPUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
891 mXPUSHi(SvREFCNT(obj) - 1);
893 ENTER_with_name("call_UNTIE");
894 call_sv(MUTABLE_SV(cv), G_VOID);
895 LEAVE_with_name("call_UNTIE");
898 else if (mg && SvREFCNT(obj) > 1) {
899 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
900 "untie attempted while %"UVuf" inner references still exist",
901 (UV)SvREFCNT(obj) - 1 ) ;
905 sv_unmagic(sv, how) ;
915 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
916 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
918 if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
921 if ((mg = SvTIED_mg(sv, how))) {
922 SV *osv = SvTIED_obj(sv, mg);
923 if (osv == mg->mg_obj)
924 osv = sv_mortalcopy(osv);
938 HV * const hv = MUTABLE_HV(POPs);
939 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
940 stash = gv_stashsv(sv, 0);
941 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
943 require_pv("AnyDBM_File.pm");
945 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
946 DIE(aTHX_ "No dbm on this machine");
956 mPUSHu(O_RDWR|O_CREAT);
961 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
964 if (!sv_isobject(TOPs)) {
972 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
976 if (sv_isobject(TOPs)) {
977 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
978 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
995 struct timeval timebuf;
996 struct timeval *tbuf = &timebuf;
999 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1004 # if BYTEORDER & 0xf0000
1005 # define ORDERBYTE (0x88888888 - BYTEORDER)
1007 # define ORDERBYTE (0x4444 - BYTEORDER)
1013 for (i = 1; i <= 3; i++) {
1014 SV * const sv = SP[i];
1017 if (SvREADONLY(sv)) {
1019 sv_force_normal_flags(sv, 0);
1020 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1021 DIE(aTHX_ "%s", PL_no_modify);
1024 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1025 SvPV_force_nolen(sv); /* force string conversion */
1032 /* little endians can use vecs directly */
1033 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1040 masksize = NFDBITS / NBBY;
1042 masksize = sizeof(long); /* documented int, everyone seems to use long */
1044 Zero(&fd_sets[0], 4, char*);
1047 # if SELECT_MIN_BITS == 1
1048 growsize = sizeof(fd_set);
1050 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1051 # undef SELECT_MIN_BITS
1052 # define SELECT_MIN_BITS __FD_SETSIZE
1054 /* If SELECT_MIN_BITS is greater than one we most probably will want
1055 * to align the sizes with SELECT_MIN_BITS/8 because for example
1056 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1057 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1058 * on (sets/tests/clears bits) is 32 bits. */
1059 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1067 timebuf.tv_sec = (long)value;
1068 value -= (NV)timebuf.tv_sec;
1069 timebuf.tv_usec = (long)(value * 1000000.0);
1074 for (i = 1; i <= 3; i++) {
1076 if (!SvOK(sv) || SvCUR(sv) == 0) {
1083 Sv_Grow(sv, growsize);
1087 while (++j <= growsize) {
1091 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1093 Newx(fd_sets[i], growsize, char);
1094 for (offset = 0; offset < growsize; offset += masksize) {
1095 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1096 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1099 fd_sets[i] = SvPVX(sv);
1103 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1104 /* Can't make just the (void*) conditional because that would be
1105 * cpp #if within cpp macro, and not all compilers like that. */
1106 nfound = PerlSock_select(
1108 (Select_fd_set_t) fd_sets[1],
1109 (Select_fd_set_t) fd_sets[2],
1110 (Select_fd_set_t) fd_sets[3],
1111 (void*) tbuf); /* Workaround for compiler bug. */
1113 nfound = PerlSock_select(
1115 (Select_fd_set_t) fd_sets[1],
1116 (Select_fd_set_t) fd_sets[2],
1117 (Select_fd_set_t) fd_sets[3],
1120 for (i = 1; i <= 3; i++) {
1123 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1125 for (offset = 0; offset < growsize; offset += masksize) {
1126 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1127 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1129 Safefree(fd_sets[i]);
1136 if (GIMME == G_ARRAY && tbuf) {
1137 value = (NV)(timebuf.tv_sec) +
1138 (NV)(timebuf.tv_usec) / 1000000.0;
1143 DIE(aTHX_ "select not implemented");
1149 =for apidoc setdefout
1151 Sets PL_defoutgv, the default file handle for output, to the passed in
1152 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1153 count of the passed in typeglob is increased by one, and the reference count
1154 of the typeglob that PL_defoutgv points to is decreased by one.
1160 Perl_setdefout(pTHX_ GV *gv)
1163 SvREFCNT_inc_simple_void(gv);
1164 SvREFCNT_dec(PL_defoutgv);
1172 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1173 GV * egv = GvEGV(PL_defoutgv);
1179 XPUSHs(&PL_sv_undef);
1181 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1182 if (gvp && *gvp == egv) {
1183 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1187 mXPUSHs(newRV(MUTABLE_SV(egv)));
1192 if (!GvIO(newdefout))
1193 gv_IOadd(newdefout);
1194 setdefout(newdefout);
1204 GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs);
1206 if (gv && (io = GvIO(gv))) {
1207 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1209 const I32 gimme = GIMME_V;
1211 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1214 call_method("GETC", gimme);
1217 if (gimme == G_SCALAR)
1218 SvSetMagicSV_nosteal(TARG, TOPs);
1222 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1223 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1224 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1225 report_evil_fh(gv, io, PL_op->op_type);
1226 SETERRNO(EBADF,RMS_IFI);
1230 sv_setpvs(TARG, " ");
1231 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1232 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1233 /* Find out how many bytes the char needs */
1234 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1237 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1238 SvCUR_set(TARG,1+len);
1247 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1250 register PERL_CONTEXT *cx;
1251 const I32 gimme = GIMME_V;
1253 PERL_ARGS_ASSERT_DOFORM;
1258 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1259 PUSHFORMAT(cx, retop);
1261 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1263 setdefout(gv); /* locally select filehandle so $% et al work */
1280 gv = MUTABLE_GV(POPs);
1295 goto not_a_format_reference;
1300 tmpsv = sv_newmortal();
1301 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1302 name = SvPV_nolen_const(tmpsv);
1304 DIE(aTHX_ "Undefined format \"%s\" called", name);
1306 not_a_format_reference:
1307 DIE(aTHX_ "Not a format reference");
1310 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1312 IoFLAGS(io) &= ~IOf_DIDTOP;
1313 return doform(cv,gv,PL_op->op_next);
1319 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1320 register IO * const io = GvIOp(gv);
1325 register PERL_CONTEXT *cx;
1327 if (!io || !(ofp = IoOFP(io)))
1330 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1331 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1333 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1334 PL_formtarget != PL_toptarget)
1338 if (!IoTOP_GV(io)) {
1341 if (!IoTOP_NAME(io)) {
1343 if (!IoFMT_NAME(io))
1344 IoFMT_NAME(io) = savepv(GvNAME(gv));
1345 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1346 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1347 if ((topgv && GvFORM(topgv)) ||
1348 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1349 IoTOP_NAME(io) = savesvpv(topname);
1351 IoTOP_NAME(io) = savepvs("top");
1353 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1354 if (!topgv || !GvFORM(topgv)) {
1355 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1358 IoTOP_GV(io) = topgv;
1360 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1361 I32 lines = IoLINES_LEFT(io);
1362 const char *s = SvPVX_const(PL_formtarget);
1363 if (lines <= 0) /* Yow, header didn't even fit!!! */
1365 while (lines-- > 0) {
1366 s = strchr(s, '\n');
1372 const STRLEN save = SvCUR(PL_formtarget);
1373 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1374 do_print(PL_formtarget, ofp);
1375 SvCUR_set(PL_formtarget, save);
1376 sv_chop(PL_formtarget, s);
1377 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1380 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1381 do_print(PL_formfeed, ofp);
1382 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1384 PL_formtarget = PL_toptarget;
1385 IoFLAGS(io) |= IOf_DIDTOP;
1388 DIE(aTHX_ "bad top format reference");
1391 SV * const sv = sv_newmortal();
1393 gv_efullname4(sv, fgv, NULL, FALSE);
1394 name = SvPV_nolen_const(sv);
1396 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1398 DIE(aTHX_ "Undefined top format called");
1400 if (cv && CvCLONE(cv))
1401 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1402 return doform(cv, gv, PL_op);
1406 POPBLOCK(cx,PL_curpm);
1412 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1414 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1415 else if (ckWARN(WARN_CLOSED))
1416 report_evil_fh(gv, io, PL_op->op_type);
1421 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1422 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1424 if (!do_print(PL_formtarget, fp))
1427 FmLINES(PL_formtarget) = 0;
1428 SvCUR_set(PL_formtarget, 0);
1429 *SvEND(PL_formtarget) = '\0';
1430 if (IoFLAGS(io) & IOf_FLUSH)
1431 (void)PerlIO_flush(fp);
1436 PL_formtarget = PL_bodytarget;
1438 PERL_UNUSED_VAR(newsp);
1439 PERL_UNUSED_VAR(gimme);
1440 return cx->blk_sub.retop;
1445 dVAR; dSP; dMARK; dORIGMARK;
1451 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1453 if (gv && (io = GvIO(gv))) {
1454 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1456 if (MARK == ORIGMARK) {
1459 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1463 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1466 call_method("PRINTF", G_SCALAR);
1469 MARK = ORIGMARK + 1;
1477 if (!(io = GvIO(gv))) {
1478 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1479 report_evil_fh(gv, io, PL_op->op_type);
1480 SETERRNO(EBADF,RMS_IFI);
1483 else if (!(fp = IoOFP(io))) {
1484 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1486 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1487 else if (ckWARN(WARN_CLOSED))
1488 report_evil_fh(gv, io, PL_op->op_type);
1490 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1494 if (SvTAINTED(MARK[1]))
1495 TAINT_PROPER("printf");
1496 do_sprintf(sv, SP - MARK, MARK + 1);
1497 if (!do_print(sv, fp))
1500 if (IoFLAGS(io) & IOf_FLUSH)
1501 if (PerlIO_flush(fp) == EOF)
1512 PUSHs(&PL_sv_undef);
1520 const int perm = (MAXARG > 3) ? POPi : 0666;
1521 const int mode = POPi;
1522 SV * const sv = POPs;
1523 GV * const gv = MUTABLE_GV(POPs);
1526 /* Need TIEHANDLE method ? */
1527 const char * const tmps = SvPV_const(sv, len);
1528 /* FIXME? do_open should do const */
1529 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1530 IoLINES(GvIOp(gv)) = 0;
1534 PUSHs(&PL_sv_undef);
1541 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1547 Sock_size_t bufsize;
1555 bool charstart = FALSE;
1556 STRLEN charskip = 0;
1559 GV * const gv = MUTABLE_GV(*++MARK);
1560 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1561 && gv && (io = GvIO(gv)) )
1563 const MAGIC * mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1567 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1569 call_method("READ", G_SCALAR);
1583 sv_setpvs(bufsv, "");
1584 length = SvIVx(*++MARK);
1587 offset = SvIVx(*++MARK);
1591 if (!io || !IoIFP(io)) {
1592 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1593 report_evil_fh(gv, io, PL_op->op_type);
1594 SETERRNO(EBADF,RMS_IFI);
1597 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1598 buffer = SvPVutf8_force(bufsv, blen);
1599 /* UTF-8 may not have been set if they are all low bytes */
1604 buffer = SvPV_force(bufsv, blen);
1605 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1608 DIE(aTHX_ "Negative length");
1616 if (PL_op->op_type == OP_RECV) {
1617 char namebuf[MAXPATHLEN];
1618 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1619 bufsize = sizeof (struct sockaddr_in);
1621 bufsize = sizeof namebuf;
1623 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1627 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1628 /* 'offset' means 'flags' here */
1629 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1630 (struct sockaddr *)namebuf, &bufsize);
1634 /* Bogus return without padding */
1635 bufsize = sizeof (struct sockaddr_in);
1637 SvCUR_set(bufsv, count);
1638 *SvEND(bufsv) = '\0';
1639 (void)SvPOK_only(bufsv);
1643 /* This should not be marked tainted if the fp is marked clean */
1644 if (!(IoFLAGS(io) & IOf_UNTAINT))
1645 SvTAINTED_on(bufsv);
1647 sv_setpvn(TARG, namebuf, bufsize);
1652 if (PL_op->op_type == OP_RECV)
1653 DIE(aTHX_ PL_no_sock_func, "recv");
1655 if (DO_UTF8(bufsv)) {
1656 /* offset adjust in characters not bytes */
1657 blen = sv_len_utf8(bufsv);
1660 if (-offset > (int)blen)
1661 DIE(aTHX_ "Offset outside string");
1664 if (DO_UTF8(bufsv)) {
1665 /* convert offset-as-chars to offset-as-bytes */
1666 if (offset >= (int)blen)
1667 offset += SvCUR(bufsv) - blen;
1669 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1672 bufsize = SvCUR(bufsv);
1673 /* Allocating length + offset + 1 isn't perfect in the case of reading
1674 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1676 (should be 2 * length + offset + 1, or possibly something longer if
1677 PL_encoding is true) */
1678 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1679 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1680 Zero(buffer+bufsize, offset-bufsize, char);
1682 buffer = buffer + offset;
1684 read_target = bufsv;
1686 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1687 concatenate it to the current buffer. */
1689 /* Truncate the existing buffer to the start of where we will be
1691 SvCUR_set(bufsv, offset);
1693 read_target = sv_newmortal();
1694 SvUPGRADE(read_target, SVt_PV);
1695 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1698 if (PL_op->op_type == OP_SYSREAD) {
1699 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1700 if (IoTYPE(io) == IoTYPE_SOCKET) {
1701 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1707 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1712 #ifdef HAS_SOCKET__bad_code_maybe
1713 if (IoTYPE(io) == IoTYPE_SOCKET) {
1714 char namebuf[MAXPATHLEN];
1715 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1716 bufsize = sizeof (struct sockaddr_in);
1718 bufsize = sizeof namebuf;
1720 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1721 (struct sockaddr *)namebuf, &bufsize);
1726 count = PerlIO_read(IoIFP(io), buffer, length);
1727 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1728 if (count == 0 && PerlIO_error(IoIFP(io)))
1732 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1733 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1736 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1737 *SvEND(read_target) = '\0';
1738 (void)SvPOK_only(read_target);
1739 if (fp_utf8 && !IN_BYTES) {
1740 /* Look at utf8 we got back and count the characters */
1741 const char *bend = buffer + count;
1742 while (buffer < bend) {
1744 skip = UTF8SKIP(buffer);
1747 if (buffer - charskip + skip > bend) {
1748 /* partial character - try for rest of it */
1749 length = skip - (bend-buffer);
1750 offset = bend - SvPVX_const(bufsv);
1762 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1763 provided amount read (count) was what was requested (length)
1765 if (got < wanted && count == length) {
1766 length = wanted - got;
1767 offset = bend - SvPVX_const(bufsv);
1770 /* return value is character count */
1774 else if (buffer_utf8) {
1775 /* Let svcatsv upgrade the bytes we read in to utf8.
1776 The buffer is a mortal so will be freed soon. */
1777 sv_catsv_nomg(bufsv, read_target);
1780 /* This should not be marked tainted if the fp is marked clean */
1781 if (!(IoFLAGS(io) & IOf_UNTAINT))
1782 SvTAINTED_on(bufsv);
1794 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1800 STRLEN orig_blen_bytes;
1801 const int op_type = PL_op->op_type;
1805 GV *const gv = MUTABLE_GV(*++MARK);
1806 if (PL_op->op_type == OP_SYSWRITE
1807 && gv && (io = GvIO(gv))) {
1808 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1812 if (MARK == SP - 1) {
1814 mXPUSHi(sv_len(sv));
1819 *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg);
1821 call_method("WRITE", G_SCALAR);
1837 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1839 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1840 if (io && IoIFP(io))
1841 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1843 report_evil_fh(gv, io, PL_op->op_type);
1845 SETERRNO(EBADF,RMS_IFI);
1849 /* Do this first to trigger any overloading. */
1850 buffer = SvPV_const(bufsv, blen);
1851 orig_blen_bytes = blen;
1852 doing_utf8 = DO_UTF8(bufsv);
1854 if (PerlIO_isutf8(IoIFP(io))) {
1855 if (!SvUTF8(bufsv)) {
1856 /* We don't modify the original scalar. */
1857 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1858 buffer = (char *) tmpbuf;
1862 else if (doing_utf8) {
1863 STRLEN tmplen = blen;
1864 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1867 buffer = (char *) tmpbuf;
1871 assert((char *)result == buffer);
1872 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1876 if (op_type == OP_SYSWRITE) {
1877 Size_t length = 0; /* This length is in characters. */
1883 /* The SV is bytes, and we've had to upgrade it. */
1884 blen_chars = orig_blen_bytes;
1886 /* The SV really is UTF-8. */
1887 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1888 /* Don't call sv_len_utf8 again because it will call magic
1889 or overloading a second time, and we might get back a
1890 different result. */
1891 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1893 /* It's safe, and it may well be cached. */
1894 blen_chars = sv_len_utf8(bufsv);
1902 length = blen_chars;
1904 #if Size_t_size > IVSIZE
1905 length = (Size_t)SvNVx(*++MARK);
1907 length = (Size_t)SvIVx(*++MARK);
1909 if ((SSize_t)length < 0) {
1911 DIE(aTHX_ "Negative length");
1916 offset = SvIVx(*++MARK);
1918 if (-offset > (IV)blen_chars) {
1920 DIE(aTHX_ "Offset outside string");
1922 offset += blen_chars;
1923 } else if (offset > (IV)blen_chars) {
1925 DIE(aTHX_ "Offset outside string");
1929 if (length > blen_chars - offset)
1930 length = blen_chars - offset;
1932 /* Here we convert length from characters to bytes. */
1933 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1934 /* Either we had to convert the SV, or the SV is magical, or
1935 the SV has overloading, in which case we can't or mustn't
1936 or mustn't call it again. */
1938 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1939 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1941 /* It's a real UTF-8 SV, and it's not going to change under
1942 us. Take advantage of any cache. */
1944 I32 len_I32 = length;
1946 /* Convert the start and end character positions to bytes.
1947 Remember that the second argument to sv_pos_u2b is relative
1949 sv_pos_u2b(bufsv, &start, &len_I32);
1956 buffer = buffer+offset;
1958 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1959 if (IoTYPE(io) == IoTYPE_SOCKET) {
1960 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1966 /* See the note at doio.c:do_print about filesize limits. --jhi */
1967 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1973 const int flags = SvIVx(*++MARK);
1976 char * const sockbuf = SvPVx(*++MARK, mlen);
1977 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1978 flags, (struct sockaddr *)sockbuf, mlen);
1982 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1987 DIE(aTHX_ PL_no_sock_func, "send");
1994 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
1997 #if Size_t_size > IVSIZE
2018 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2019 else if (PL_op->op_flags & OPf_SPECIAL)
2020 gv = PL_last_in_gv = GvEGV(PL_argvgv); /* eof() - ARGV magic */
2022 gv = PL_last_in_gv; /* eof */
2027 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2029 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2031 * in Perl 5.12 and later, the additional paramter is a bitmask:
2034 * 2 = eof() <- ARGV magic
2037 mPUSHi(1); /* 1 = eof(FH) - simple, explicit FH */
2038 else if (PL_op->op_flags & OPf_SPECIAL)
2039 mPUSHi(2); /* 2 = eof() - ARGV magic */
2041 mPUSHi(0); /* 0 = eof - simple, implicit FH */
2044 call_method("EOF", G_SCALAR);
2050 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2051 if (io && !IoIFP(io)) {
2052 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2054 IoFLAGS(io) &= ~IOf_START;
2055 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2057 sv_setpvs(GvSV(gv), "-");
2059 GvSV(gv) = newSVpvs("-");
2060 SvSETMAGIC(GvSV(gv));
2062 else if (!nextargv(gv))
2067 PUSHs(boolSV(do_eof(gv)));
2078 PL_last_in_gv = MUTABLE_GV(POPs);
2081 if (gv && (io = GvIO(gv))) {
2082 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2085 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2088 call_method("TELL", G_SCALAR);
2096 SETERRNO(EBADF,RMS_IFI);
2101 #if LSEEKSIZE > IVSIZE
2102 PUSHn( do_tell(gv) );
2104 PUSHi( do_tell(gv) );
2112 const int whence = POPi;
2113 #if LSEEKSIZE > IVSIZE
2114 const Off_t offset = (Off_t)SvNVx(POPs);
2116 const Off_t offset = (Off_t)SvIVx(POPs);
2119 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2122 if (gv && (io = GvIO(gv))) {
2123 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2126 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2127 #if LSEEKSIZE > IVSIZE
2128 mXPUSHn((NV) offset);
2135 call_method("SEEK", G_SCALAR);
2142 if (PL_op->op_type == OP_SEEK)
2143 PUSHs(boolSV(do_seek(gv, offset, whence)));
2145 const Off_t sought = do_sysseek(gv, offset, whence);
2147 PUSHs(&PL_sv_undef);
2149 SV* const sv = sought ?
2150 #if LSEEKSIZE > IVSIZE
2155 : newSVpvn(zero_but_true, ZBTLEN);
2166 /* There seems to be no consensus on the length type of truncate()
2167 * and ftruncate(), both off_t and size_t have supporters. In
2168 * general one would think that when using large files, off_t is
2169 * at least as wide as size_t, so using an off_t should be okay. */
2170 /* XXX Configure probe for the length type of *truncate() needed XXX */
2173 #if Off_t_size > IVSIZE
2178 /* Checking for length < 0 is problematic as the type might or
2179 * might not be signed: if it is not, clever compilers will moan. */
2180 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2187 if (PL_op->op_flags & OPf_SPECIAL) {
2188 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2197 TAINT_PROPER("truncate");
2198 if (!(fp = IoIFP(io))) {
2204 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2206 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2213 SV * const sv = POPs;
2216 if (isGV_with_GP(sv)) {
2217 tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */
2218 goto do_ftruncate_gv;
2220 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2221 tmpgv = MUTABLE_GV(SvRV(sv)); /* \*main::FRED for example */
2222 goto do_ftruncate_gv;
2224 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2225 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2226 goto do_ftruncate_io;
2229 name = SvPV_nolen_const(sv);
2230 TAINT_PROPER("truncate");
2232 if (truncate(name, len) < 0)
2236 const int tmpfd = PerlLIO_open(name, O_RDWR);
2241 if (my_chsize(tmpfd, len) < 0)
2243 PerlLIO_close(tmpfd);
2252 SETERRNO(EBADF,RMS_IFI);
2260 SV * const argsv = POPs;
2261 const unsigned int func = POPu;
2262 const int optype = PL_op->op_type;
2263 GV * const gv = MUTABLE_GV(POPs);
2264 IO * const io = gv ? GvIOn(gv) : NULL;
2268 if (!io || !argsv || !IoIFP(io)) {
2269 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2270 report_evil_fh(gv, io, PL_op->op_type);
2271 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2275 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2278 s = SvPV_force(argsv, len);
2279 need = IOCPARM_LEN(func);
2281 s = Sv_Grow(argsv, need + 1);
2282 SvCUR_set(argsv, need);
2285 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2288 retval = SvIV(argsv);
2289 s = INT2PTR(char*,retval); /* ouch */
2292 TAINT_PROPER(PL_op_desc[optype]);
2294 if (optype == OP_IOCTL)
2296 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2298 DIE(aTHX_ "ioctl is not implemented");
2302 DIE(aTHX_ "fcntl is not implemented");
2304 #if defined(OS2) && defined(__EMX__)
2305 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2307 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2311 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2313 if (s[SvCUR(argsv)] != 17)
2314 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2316 s[SvCUR(argsv)] = 0; /* put our null back */
2317 SvSETMAGIC(argsv); /* Assume it has changed */
2326 PUSHp(zero_but_true, ZBTLEN);
2339 const int argtype = POPi;
2340 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
2342 if (gv && (io = GvIO(gv)))
2348 /* XXX Looks to me like io is always NULL at this point */
2350 (void)PerlIO_flush(fp);
2351 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2354 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2355 report_evil_fh(gv, io, PL_op->op_type);
2357 SETERRNO(EBADF,RMS_IFI);
2362 DIE(aTHX_ PL_no_func, "flock()");
2373 const int protocol = POPi;
2374 const int type = POPi;
2375 const int domain = POPi;
2376 GV * const gv = MUTABLE_GV(POPs);
2377 register IO * const io = gv ? GvIOn(gv) : NULL;
2381 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2382 report_evil_fh(gv, io, PL_op->op_type);
2383 if (io && IoIFP(io))
2384 do_close(gv, FALSE);
2385 SETERRNO(EBADF,LIB_INVARG);
2390 do_close(gv, FALSE);
2392 TAINT_PROPER("socket");
2393 fd = PerlSock_socket(domain, type, protocol);
2396 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2397 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2398 IoTYPE(io) = IoTYPE_SOCKET;
2399 if (!IoIFP(io) || !IoOFP(io)) {
2400 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2401 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2402 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2405 #if defined(HAS_FCNTL) && defined(F_SETFD)
2406 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2410 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2415 DIE(aTHX_ PL_no_sock_func, "socket");
2422 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2424 const int protocol = POPi;
2425 const int type = POPi;
2426 const int domain = POPi;
2427 GV * const gv2 = MUTABLE_GV(POPs);
2428 GV * const gv1 = MUTABLE_GV(POPs);
2429 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2430 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2433 if (!gv1 || !gv2 || !io1 || !io2) {
2434 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2436 report_evil_fh(gv1, io1, PL_op->op_type);
2438 report_evil_fh(gv1, io2, PL_op->op_type);
2440 if (io1 && IoIFP(io1))
2441 do_close(gv1, FALSE);
2442 if (io2 && IoIFP(io2))
2443 do_close(gv2, FALSE);
2448 do_close(gv1, FALSE);
2450 do_close(gv2, FALSE);
2452 TAINT_PROPER("socketpair");
2453 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2455 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2456 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2457 IoTYPE(io1) = IoTYPE_SOCKET;
2458 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2459 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2460 IoTYPE(io2) = IoTYPE_SOCKET;
2461 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2462 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2463 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2464 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2465 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2466 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2467 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2470 #if defined(HAS_FCNTL) && defined(F_SETFD)
2471 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2472 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2477 DIE(aTHX_ PL_no_sock_func, "socketpair");
2486 SV * const addrsv = POPs;
2487 /* OK, so on what platform does bind modify addr? */
2489 GV * const gv = MUTABLE_GV(POPs);
2490 register IO * const io = GvIOn(gv);
2493 if (!io || !IoIFP(io))
2496 addr = SvPV_const(addrsv, len);
2497 TAINT_PROPER("bind");
2498 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2504 if (ckWARN(WARN_CLOSED))
2505 report_evil_fh(gv, io, PL_op->op_type);
2506 SETERRNO(EBADF,SS_IVCHAN);
2509 DIE(aTHX_ PL_no_sock_func, "bind");
2518 SV * const addrsv = POPs;
2519 GV * const gv = MUTABLE_GV(POPs);
2520 register IO * const io = GvIOn(gv);
2524 if (!io || !IoIFP(io))
2527 addr = SvPV_const(addrsv, len);
2528 TAINT_PROPER("connect");
2529 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2535 if (ckWARN(WARN_CLOSED))
2536 report_evil_fh(gv, io, PL_op->op_type);
2537 SETERRNO(EBADF,SS_IVCHAN);
2540 DIE(aTHX_ PL_no_sock_func, "connect");
2549 const int backlog = POPi;
2550 GV * const gv = MUTABLE_GV(POPs);
2551 register IO * const io = gv ? GvIOn(gv) : NULL;
2553 if (!gv || !io || !IoIFP(io))
2556 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2562 if (ckWARN(WARN_CLOSED))
2563 report_evil_fh(gv, io, PL_op->op_type);
2564 SETERRNO(EBADF,SS_IVCHAN);
2567 DIE(aTHX_ PL_no_sock_func, "listen");
2578 char namebuf[MAXPATHLEN];
2579 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2580 Sock_size_t len = sizeof (struct sockaddr_in);
2582 Sock_size_t len = sizeof namebuf;
2584 GV * const ggv = MUTABLE_GV(POPs);
2585 GV * const ngv = MUTABLE_GV(POPs);
2594 if (!gstio || !IoIFP(gstio))
2598 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2601 /* Some platforms indicate zero length when an AF_UNIX client is
2602 * not bound. Simulate a non-zero-length sockaddr structure in
2604 namebuf[0] = 0; /* sun_len */
2605 namebuf[1] = AF_UNIX; /* sun_family */
2613 do_close(ngv, FALSE);
2614 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2615 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2616 IoTYPE(nstio) = IoTYPE_SOCKET;
2617 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2618 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2619 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2620 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2623 #if defined(HAS_FCNTL) && defined(F_SETFD)
2624 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2628 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2629 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2631 #ifdef __SCO_VERSION__
2632 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2635 PUSHp(namebuf, len);
2639 if (ckWARN(WARN_CLOSED))
2640 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2641 SETERRNO(EBADF,SS_IVCHAN);
2647 DIE(aTHX_ PL_no_sock_func, "accept");
2656 const int how = POPi;
2657 GV * const gv = MUTABLE_GV(POPs);
2658 register IO * const io = GvIOn(gv);
2660 if (!io || !IoIFP(io))
2663 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2667 if (ckWARN(WARN_CLOSED))
2668 report_evil_fh(gv, io, PL_op->op_type);
2669 SETERRNO(EBADF,SS_IVCHAN);
2672 DIE(aTHX_ PL_no_sock_func, "shutdown");
2681 const int optype = PL_op->op_type;
2682 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2683 const unsigned int optname = (unsigned int) POPi;
2684 const unsigned int lvl = (unsigned int) POPi;
2685 GV * const gv = MUTABLE_GV(POPs);
2686 register IO * const io = GvIOn(gv);
2690 if (!io || !IoIFP(io))
2693 fd = PerlIO_fileno(IoIFP(io));
2697 (void)SvPOK_only(sv);
2701 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2708 #if defined(__SYMBIAN32__)
2709 # define SETSOCKOPT_OPTION_VALUE_T void *
2711 # define SETSOCKOPT_OPTION_VALUE_T const char *
2713 /* XXX TODO: We need to have a proper type (a Configure probe,
2714 * etc.) for what the C headers think of the third argument of
2715 * setsockopt(), the option_value read-only buffer: is it
2716 * a "char *", or a "void *", const or not. Some compilers
2717 * don't take kindly to e.g. assuming that "char *" implicitly
2718 * promotes to a "void *", or to explicitly promoting/demoting
2719 * consts to non/vice versa. The "const void *" is the SUS
2720 * definition, but that does not fly everywhere for the above
2722 SETSOCKOPT_OPTION_VALUE_T buf;
2726 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2730 aint = (int)SvIV(sv);
2731 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2734 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2743 if (ckWARN(WARN_CLOSED))
2744 report_evil_fh(gv, io, optype);
2745 SETERRNO(EBADF,SS_IVCHAN);
2750 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2759 const int optype = PL_op->op_type;
2760 GV * const gv = MUTABLE_GV(POPs);
2761 register IO * const io = GvIOn(gv);
2766 if (!io || !IoIFP(io))
2769 sv = sv_2mortal(newSV(257));
2770 (void)SvPOK_only(sv);
2774 fd = PerlIO_fileno(IoIFP(io));
2776 case OP_GETSOCKNAME:
2777 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2780 case OP_GETPEERNAME:
2781 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2783 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2785 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";
2786 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2787 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2788 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2789 sizeof(u_short) + sizeof(struct in_addr))) {
2796 #ifdef BOGUS_GETNAME_RETURN
2797 /* Interactive Unix, getpeername() and getsockname()
2798 does not return valid namelen */
2799 if (len == BOGUS_GETNAME_RETURN)
2800 len = sizeof(struct sockaddr);
2808 if (ckWARN(WARN_CLOSED))
2809 report_evil_fh(gv, io, optype);
2810 SETERRNO(EBADF,SS_IVCHAN);
2815 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2831 if (PL_op->op_flags & OPf_REF) {
2833 if (PL_op->op_type == OP_LSTAT) {
2834 if (gv != PL_defgv) {
2835 do_fstat_warning_check:
2836 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2837 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2838 } else if (PL_laststype != OP_LSTAT)
2839 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2843 if (gv != PL_defgv) {
2844 PL_laststype = OP_STAT;
2846 sv_setpvs(PL_statname, "");
2853 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2854 } else if (IoDIRP(io)) {
2856 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2858 PL_laststatval = -1;
2864 if (PL_laststatval < 0) {
2865 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2866 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2871 SV* const sv = POPs;
2872 if (isGV_with_GP(sv)) {
2873 gv = MUTABLE_GV(sv);
2875 } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2876 gv = MUTABLE_GV(SvRV(sv));
2877 if (PL_op->op_type == OP_LSTAT)
2878 goto do_fstat_warning_check;
2880 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2881 io = MUTABLE_IO(SvRV(sv));
2882 if (PL_op->op_type == OP_LSTAT)
2883 goto do_fstat_warning_check;
2884 goto do_fstat_have_io;
2887 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2889 PL_laststype = PL_op->op_type;
2890 if (PL_op->op_type == OP_LSTAT)
2891 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2893 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2894 if (PL_laststatval < 0) {
2895 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2896 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2902 if (gimme != G_ARRAY) {
2903 if (gimme != G_VOID)
2904 XPUSHs(boolSV(max));
2910 mPUSHi(PL_statcache.st_dev);
2911 mPUSHi(PL_statcache.st_ino);
2912 mPUSHu(PL_statcache.st_mode);
2913 mPUSHu(PL_statcache.st_nlink);
2914 #if Uid_t_size > IVSIZE
2915 mPUSHn(PL_statcache.st_uid);
2917 # if Uid_t_sign <= 0
2918 mPUSHi(PL_statcache.st_uid);
2920 mPUSHu(PL_statcache.st_uid);
2923 #if Gid_t_size > IVSIZE
2924 mPUSHn(PL_statcache.st_gid);
2926 # if Gid_t_sign <= 0
2927 mPUSHi(PL_statcache.st_gid);
2929 mPUSHu(PL_statcache.st_gid);
2932 #ifdef USE_STAT_RDEV
2933 mPUSHi(PL_statcache.st_rdev);
2935 PUSHs(newSVpvs_flags("", SVs_TEMP));
2937 #if Off_t_size > IVSIZE
2938 mPUSHn(PL_statcache.st_size);
2940 mPUSHi(PL_statcache.st_size);
2943 mPUSHn(PL_statcache.st_atime);
2944 mPUSHn(PL_statcache.st_mtime);
2945 mPUSHn(PL_statcache.st_ctime);
2947 mPUSHi(PL_statcache.st_atime);
2948 mPUSHi(PL_statcache.st_mtime);
2949 mPUSHi(PL_statcache.st_ctime);
2951 #ifdef USE_STAT_BLOCKS
2952 mPUSHu(PL_statcache.st_blksize);
2953 mPUSHu(PL_statcache.st_blocks);
2955 PUSHs(newSVpvs_flags("", SVs_TEMP));
2956 PUSHs(newSVpvs_flags("", SVs_TEMP));
2962 /* This macro is used by the stacked filetest operators :
2963 * if the previous filetest failed, short-circuit and pass its value.
2964 * Else, discard it from the stack and continue. --rgs
2966 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2967 if (!SvTRUE(TOPs)) { RETURN; } \
2968 else { (void)POPs; PUTBACK; } \
2975 /* Not const, because things tweak this below. Not bool, because there's
2976 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2977 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2978 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2979 /* Giving some sort of initial value silences compilers. */
2981 int access_mode = R_OK;
2983 int access_mode = 0;
2986 /* access_mode is never used, but leaving use_access in makes the
2987 conditional compiling below much clearer. */
2990 int stat_mode = S_IRUSR;
2992 bool effective = FALSE;
2996 switch (PL_op->op_type) {
2997 case OP_FTRREAD: opchar = 'R'; break;
2998 case OP_FTRWRITE: opchar = 'W'; break;
2999 case OP_FTREXEC: opchar = 'X'; break;
3000 case OP_FTEREAD: opchar = 'r'; break;
3001 case OP_FTEWRITE: opchar = 'w'; break;
3002 case OP_FTEEXEC: opchar = 'x'; break;
3004 tryAMAGICftest(opchar);
3006 STACKED_FTEST_CHECK;
3008 switch (PL_op->op_type) {
3010 #if !(defined(HAS_ACCESS) && defined(R_OK))
3016 #if defined(HAS_ACCESS) && defined(W_OK)
3021 stat_mode = S_IWUSR;
3025 #if defined(HAS_ACCESS) && defined(X_OK)
3030 stat_mode = S_IXUSR;
3034 #ifdef PERL_EFF_ACCESS
3037 stat_mode = S_IWUSR;
3041 #ifndef PERL_EFF_ACCESS
3048 #ifdef PERL_EFF_ACCESS
3053 stat_mode = S_IXUSR;
3059 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3060 const char *name = POPpx;
3062 # ifdef PERL_EFF_ACCESS
3063 result = PERL_EFF_ACCESS(name, access_mode);
3065 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3071 result = access(name, access_mode);
3073 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3088 if (cando(stat_mode, effective, &PL_statcache))
3097 const int op_type = PL_op->op_type;
3102 case OP_FTIS: opchar = 'e'; break;
3103 case OP_FTSIZE: opchar = 's'; break;
3104 case OP_FTMTIME: opchar = 'M'; break;
3105 case OP_FTCTIME: opchar = 'C'; break;
3106 case OP_FTATIME: opchar = 'A'; break;
3108 tryAMAGICftest(opchar);
3110 STACKED_FTEST_CHECK;
3116 if (op_type == OP_FTIS)
3119 /* You can't dTARGET inside OP_FTIS, because you'll get
3120 "panic: pad_sv po" - the op is not flagged to have a target. */
3124 #if Off_t_size > IVSIZE
3125 PUSHn(PL_statcache.st_size);
3127 PUSHi(PL_statcache.st_size);
3131 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3134 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3137 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3151 switch (PL_op->op_type) {
3152 case OP_FTROWNED: opchar = 'O'; break;
3153 case OP_FTEOWNED: opchar = 'o'; break;
3154 case OP_FTZERO: opchar = 'z'; break;
3155 case OP_FTSOCK: opchar = 'S'; break;
3156 case OP_FTCHR: opchar = 'c'; break;
3157 case OP_FTBLK: opchar = 'b'; break;
3158 case OP_FTFILE: opchar = 'f'; break;
3159 case OP_FTDIR: opchar = 'd'; break;
3160 case OP_FTPIPE: opchar = 'p'; break;
3161 case OP_FTSUID: opchar = 'u'; break;
3162 case OP_FTSGID: opchar = 'g'; break;
3163 case OP_FTSVTX: opchar = 'k'; break;
3165 tryAMAGICftest(opchar);
3167 /* I believe that all these three are likely to be defined on most every
3168 system these days. */
3170 if(PL_op->op_type == OP_FTSUID)
3174 if(PL_op->op_type == OP_FTSGID)
3178 if(PL_op->op_type == OP_FTSVTX)
3182 STACKED_FTEST_CHECK;
3188 switch (PL_op->op_type) {
3190 if (PL_statcache.st_uid == PL_uid)
3194 if (PL_statcache.st_uid == PL_euid)
3198 if (PL_statcache.st_size == 0)
3202 if (S_ISSOCK(PL_statcache.st_mode))
3206 if (S_ISCHR(PL_statcache.st_mode))
3210 if (S_ISBLK(PL_statcache.st_mode))
3214 if (S_ISREG(PL_statcache.st_mode))
3218 if (S_ISDIR(PL_statcache.st_mode))
3222 if (S_ISFIFO(PL_statcache.st_mode))
3227 if (PL_statcache.st_mode & S_ISUID)
3233 if (PL_statcache.st_mode & S_ISGID)
3239 if (PL_statcache.st_mode & S_ISVTX)
3253 tryAMAGICftest('l');
3254 result = my_lstat();
3259 if (S_ISLNK(PL_statcache.st_mode))
3272 tryAMAGICftest('t');
3274 STACKED_FTEST_CHECK;
3276 if (PL_op->op_flags & OPf_REF)
3278 else if (isGV(TOPs))
3279 gv = MUTABLE_GV(POPs);
3280 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3281 gv = MUTABLE_GV(SvRV(POPs));
3283 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3285 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3286 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3287 else if (tmpsv && SvOK(tmpsv)) {
3288 const char *tmps = SvPV_nolen_const(tmpsv);
3296 if (PerlLIO_isatty(fd))
3301 #if defined(atarist) /* this will work with atariST. Configure will
3302 make guesses for other systems. */
3303 # define FILE_base(f) ((f)->_base)
3304 # define FILE_ptr(f) ((f)->_ptr)
3305 # define FILE_cnt(f) ((f)->_cnt)
3306 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3317 register STDCHAR *s;
3323 tryAMAGICftest(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3325 STACKED_FTEST_CHECK;
3327 if (PL_op->op_flags & OPf_REF)
3329 else if (isGV(TOPs))
3330 gv = MUTABLE_GV(POPs);
3331 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3332 gv = MUTABLE_GV(SvRV(POPs));
3338 if (gv == PL_defgv) {
3340 io = GvIO(PL_statgv);
3343 goto really_filename;
3348 PL_laststatval = -1;
3349 sv_setpvs(PL_statname, "");
3350 io = GvIO(PL_statgv);
3352 if (io && IoIFP(io)) {
3353 if (! PerlIO_has_base(IoIFP(io)))
3354 DIE(aTHX_ "-T and -B not implemented on filehandles");
3355 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3356 if (PL_laststatval < 0)
3358 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3359 if (PL_op->op_type == OP_FTTEXT)
3364 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3365 i = PerlIO_getc(IoIFP(io));
3367 (void)PerlIO_ungetc(IoIFP(io),i);
3369 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3371 len = PerlIO_get_bufsiz(IoIFP(io));
3372 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3373 /* sfio can have large buffers - limit to 512 */
3378 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3380 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3382 SETERRNO(EBADF,RMS_IFI);
3390 PL_laststype = OP_STAT;
3391 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3392 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3393 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3395 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3398 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3399 if (PL_laststatval < 0) {
3400 (void)PerlIO_close(fp);
3403 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3404 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3405 (void)PerlIO_close(fp);
3407 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3408 RETPUSHNO; /* special case NFS directories */
3409 RETPUSHYES; /* null file is anything */
3414 /* now scan s to look for textiness */
3415 /* XXX ASCII dependent code */
3417 #if defined(DOSISH) || defined(USEMYBINMODE)
3418 /* ignore trailing ^Z on short files */
3419 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3423 for (i = 0; i < len; i++, s++) {
3424 if (!*s) { /* null never allowed in text */
3429 else if (!(isPRINT(*s) || isSPACE(*s)))
3432 else if (*s & 128) {
3434 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3437 /* utf8 characters don't count as odd */
3438 if (UTF8_IS_START(*s)) {
3439 int ulen = UTF8SKIP(s);
3440 if (ulen < len - i) {
3442 for (j = 1; j < ulen; j++) {
3443 if (!UTF8_IS_CONTINUATION(s[j]))
3446 --ulen; /* loop does extra increment */
3456 *s != '\n' && *s != '\r' && *s != '\b' &&
3457 *s != '\t' && *s != '\f' && *s != 27)
3462 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3473 const char *tmps = NULL;
3477 SV * const sv = POPs;
3478 if (PL_op->op_flags & OPf_SPECIAL) {
3479 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3481 else if (isGV_with_GP(sv)) {
3482 gv = MUTABLE_GV(sv);
3484 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
3485 gv = MUTABLE_GV(SvRV(sv));
3488 tmps = SvPV_nolen_const(sv);
3492 if( !gv && (!tmps || !*tmps) ) {
3493 HV * const table = GvHVn(PL_envgv);
3496 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3497 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3499 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3504 deprecate("chdir('') or chdir(undef) as chdir()");
3505 tmps = SvPV_nolen_const(*svp);
3509 TAINT_PROPER("chdir");
3514 TAINT_PROPER("chdir");
3517 IO* const io = GvIO(gv);
3520 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3521 } else if (IoIFP(io)) {
3522 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3525 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3526 report_evil_fh(gv, io, PL_op->op_type);
3527 SETERRNO(EBADF, RMS_IFI);
3532 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3533 report_evil_fh(gv, io, PL_op->op_type);
3534 SETERRNO(EBADF,RMS_IFI);
3538 DIE(aTHX_ PL_no_func, "fchdir");
3542 PUSHi( PerlDir_chdir(tmps) >= 0 );
3544 /* Clear the DEFAULT element of ENV so we'll get the new value
3546 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3553 dVAR; dSP; dMARK; dTARGET;
3554 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3565 char * const tmps = POPpx;
3566 TAINT_PROPER("chroot");
3567 PUSHi( chroot(tmps) >= 0 );
3570 DIE(aTHX_ PL_no_func, "chroot");
3579 const char * const tmps2 = POPpconstx;
3580 const char * const tmps = SvPV_nolen_const(TOPs);
3581 TAINT_PROPER("rename");
3583 anum = PerlLIO_rename(tmps, tmps2);
3585 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3586 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3589 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3590 (void)UNLINK(tmps2);
3591 if (!(anum = link(tmps, tmps2)))
3592 anum = UNLINK(tmps);
3600 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3604 const int op_type = PL_op->op_type;
3608 if (op_type == OP_LINK)
3609 DIE(aTHX_ PL_no_func, "link");
3611 # ifndef HAS_SYMLINK
3612 if (op_type == OP_SYMLINK)
3613 DIE(aTHX_ PL_no_func, "symlink");
3617 const char * const tmps2 = POPpconstx;
3618 const char * const tmps = SvPV_nolen_const(TOPs);
3619 TAINT_PROPER(PL_op_desc[op_type]);
3621 # if defined(HAS_LINK)
3622 # if defined(HAS_SYMLINK)
3623 /* Both present - need to choose which. */
3624 (op_type == OP_LINK) ?
3625 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3627 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3628 PerlLIO_link(tmps, tmps2);
3631 # if defined(HAS_SYMLINK)
3632 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3633 symlink(tmps, tmps2);
3638 SETi( result >= 0 );
3645 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3657 char buf[MAXPATHLEN];
3660 #ifndef INCOMPLETE_TAINTS
3664 len = readlink(tmps, buf, sizeof(buf) - 1);
3672 RETSETUNDEF; /* just pretend it's a normal file */
3676 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3678 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3680 char * const save_filename = filename;
3685 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3687 PERL_ARGS_ASSERT_DOONELINER;
3689 Newx(cmdline, size, char);
3690 my_strlcpy(cmdline, cmd, size);
3691 my_strlcat(cmdline, " ", size);
3692 for (s = cmdline + strlen(cmdline); *filename; ) {
3696 if (s - cmdline < size)
3697 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3698 myfp = PerlProc_popen(cmdline, "r");
3702 SV * const tmpsv = sv_newmortal();
3703 /* Need to save/restore 'PL_rs' ?? */
3704 s = sv_gets(tmpsv, myfp, 0);
3705 (void)PerlProc_pclose(myfp);
3709 #ifdef HAS_SYS_ERRLIST
3714 /* you don't see this */
3715 const char * const errmsg =
3716 #ifdef HAS_SYS_ERRLIST
3724 if (instr(s, errmsg)) {
3731 #define EACCES EPERM
3733 if (instr(s, "cannot make"))
3734 SETERRNO(EEXIST,RMS_FEX);
3735 else if (instr(s, "existing file"))
3736 SETERRNO(EEXIST,RMS_FEX);
3737 else if (instr(s, "ile exists"))
3738 SETERRNO(EEXIST,RMS_FEX);
3739 else if (instr(s, "non-exist"))
3740 SETERRNO(ENOENT,RMS_FNF);
3741 else if (instr(s, "does not exist"))
3742 SETERRNO(ENOENT,RMS_FNF);
3743 else if (instr(s, "not empty"))
3744 SETERRNO(EBUSY,SS_DEVOFFLINE);
3745 else if (instr(s, "cannot access"))
3746 SETERRNO(EACCES,RMS_PRV);
3748 SETERRNO(EPERM,RMS_PRV);
3751 else { /* some mkdirs return no failure indication */
3752 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3753 if (PL_op->op_type == OP_RMDIR)
3758 SETERRNO(EACCES,RMS_PRV); /* a guess */
3767 /* This macro removes trailing slashes from a directory name.
3768 * Different operating and file systems take differently to
3769 * trailing slashes. According to POSIX 1003.1 1996 Edition
3770 * any number of trailing slashes should be allowed.
3771 * Thusly we snip them away so that even non-conforming
3772 * systems are happy.
3773 * We should probably do this "filtering" for all
3774 * the functions that expect (potentially) directory names:
3775 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3776 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3778 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3779 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3782 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3783 (tmps) = savepvn((tmps), (len)); \
3793 const int mode = (MAXARG > 1) ? POPi : 0777;
3795 TRIMSLASHES(tmps,len,copy);
3797 TAINT_PROPER("mkdir");
3799 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3803 SETi( dooneliner("mkdir", tmps) );
3804 oldumask = PerlLIO_umask(0);
3805 PerlLIO_umask(oldumask);
3806 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3821 TRIMSLASHES(tmps,len,copy);
3822 TAINT_PROPER("rmdir");
3824 SETi( PerlDir_rmdir(tmps) >= 0 );
3826 SETi( dooneliner("rmdir", tmps) );
3833 /* Directory calls. */
3837 #if defined(Direntry_t) && defined(HAS_READDIR)
3839 const char * const dirname = POPpconstx;
3840 GV * const gv = MUTABLE_GV(POPs);
3841 register IO * const io = GvIOn(gv);
3846 if ((IoIFP(io) || IoOFP(io)))
3847 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3848 "Opening filehandle %s also as a directory",
3851 PerlDir_close(IoDIRP(io));
3852 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3858 SETERRNO(EBADF,RMS_DIR);
3861 DIE(aTHX_ PL_no_dir_func, "opendir");
3868 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3869 DIE(aTHX_ PL_no_dir_func, "readdir");
3872 #if !defined(I_DIRENT) && !defined(VMS)
3873 Direntry_t *readdir (DIR *);
3879 const I32 gimme = GIMME;
3880 GV * const gv = MUTABLE_GV(POPs);
3881 register const Direntry_t *dp;
3882 register IO * const io = GvIOn(gv);
3884 if (!io || !IoDIRP(io)) {
3885 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3886 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3891 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3895 sv = newSVpvn(dp->d_name, dp->d_namlen);
3897 sv = newSVpv(dp->d_name, 0);
3899 #ifndef INCOMPLETE_TAINTS
3900 if (!(IoFLAGS(io) & IOf_UNTAINT))
3904 } while (gimme == G_ARRAY);
3906 if (!dp && gimme != G_ARRAY)
3913 SETERRNO(EBADF,RMS_ISI);
3914 if (GIMME == G_ARRAY)
3923 #if defined(HAS_TELLDIR) || defined(telldir)
3925 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3926 /* XXX netbsd still seemed to.
3927 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3928 --JHI 1999-Feb-02 */
3929 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3930 long telldir (DIR *);
3932 GV * const gv = MUTABLE_GV(POPs);
3933 register IO * const io = GvIOn(gv);
3935 if (!io || !IoDIRP(io)) {
3936 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3937 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3941 PUSHi( PerlDir_tell(IoDIRP(io)) );
3945 SETERRNO(EBADF,RMS_ISI);
3948 DIE(aTHX_ PL_no_dir_func, "telldir");
3955 #if defined(HAS_SEEKDIR) || defined(seekdir)
3957 const long along = POPl;
3958 GV * const gv = MUTABLE_GV(POPs);
3959 register IO * const io = GvIOn(gv);
3961 if (!io || !IoDIRP(io)) {
3962 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3963 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3966 (void)PerlDir_seek(IoDIRP(io), along);
3971 SETERRNO(EBADF,RMS_ISI);
3974 DIE(aTHX_ PL_no_dir_func, "seekdir");
3981 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3983 GV * const gv = MUTABLE_GV(POPs);
3984 register IO * const io = GvIOn(gv);
3986 if (!io || !IoDIRP(io)) {
3987 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3988 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3991 (void)PerlDir_rewind(IoDIRP(io));
3995 SETERRNO(EBADF,RMS_ISI);
3998 DIE(aTHX_ PL_no_dir_func, "rewinddir");
4005 #if defined(Direntry_t) && defined(HAS_READDIR)
4007 GV * const gv = MUTABLE_GV(POPs);
4008 register IO * const io = GvIOn(gv);
4010 if (!io || !IoDIRP(io)) {
4011 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4012 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
4015 #ifdef VOID_CLOSEDIR
4016 PerlDir_close(IoDIRP(io));
4018 if (PerlDir_close(IoDIRP(io)) < 0) {
4019 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4028 SETERRNO(EBADF,RMS_IFI);
4031 DIE(aTHX_ PL_no_dir_func, "closedir");
4036 /* Process control. */
4045 PERL_FLUSHALL_FOR_CHILD;
4046 childpid = PerlProc_fork();
4050 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
4052 SvREADONLY_off(GvSV(tmpgv));
4053 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4054 SvREADONLY_on(GvSV(tmpgv));
4056 #ifdef THREADS_HAVE_PIDS
4057 PL_ppid = (IV)getppid();
4059 #ifdef PERL_USES_PL_PIDSTATUS
4060 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4066 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4071 PERL_FLUSHALL_FOR_CHILD;
4072 childpid = PerlProc_fork();
4078 DIE(aTHX_ PL_no_func, "fork");
4086 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4091 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4092 childpid = wait4pid(-1, &argflags, 0);
4094 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4099 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4100 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4101 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4103 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4108 DIE(aTHX_ PL_no_func, "wait");
4115 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4117 const int optype = POPi;
4118 const Pid_t pid = TOPi;
4122 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4123 result = wait4pid(pid, &argflags, optype);
4125 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4130 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4131 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4132 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4134 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4139 DIE(aTHX_ PL_no_func, "waitpid");
4146 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4147 #if defined(__LIBCATAMOUNT__)
4148 PL_statusvalue = -1;
4157 while (++MARK <= SP) {
4158 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4163 TAINT_PROPER("system");
4165 PERL_FLUSHALL_FOR_CHILD;
4166 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4172 if (PerlProc_pipe(pp) >= 0)
4174 while ((childpid = PerlProc_fork()) == -1) {
4175 if (errno != EAGAIN) {
4180 PerlLIO_close(pp[0]);
4181 PerlLIO_close(pp[1]);
4188 Sigsave_t ihand,qhand; /* place to save signals during system() */
4192 PerlLIO_close(pp[1]);
4194 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4195 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4198 result = wait4pid(childpid, &status, 0);
4199 } while (result == -1 && errno == EINTR);
4201 (void)rsignal_restore(SIGINT, &ihand);
4202 (void)rsignal_restore(SIGQUIT, &qhand);
4204 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4205 do_execfree(); /* free any memory child malloced on fork */
4212 while (n < sizeof(int)) {
4213 n1 = PerlLIO_read(pp[0],
4214 (void*)(((char*)&errkid)+n),
4220 PerlLIO_close(pp[0]);
4221 if (n) { /* Error */
4222 if (n != sizeof(int))
4223 DIE(aTHX_ "panic: kid popen errno read");
4224 errno = errkid; /* Propagate errno from kid */
4225 STATUS_NATIVE_CHILD_SET(-1);
4228 XPUSHi(STATUS_CURRENT);
4232 PerlLIO_close(pp[0]);
4233 #if defined(HAS_FCNTL) && defined(F_SETFD)
4234 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4237 if (PL_op->op_flags & OPf_STACKED) {
4238 SV * const really = *++MARK;
4239 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4241 else if (SP - MARK != 1)
4242 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4244 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4248 #else /* ! FORK or VMS or OS/2 */
4251 if (PL_op->op_flags & OPf_STACKED) {
4252 SV * const really = *++MARK;
4253 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4254 value = (I32)do_aspawn(really, MARK, SP);
4256 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4259 else if (SP - MARK != 1) {
4260 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4261 value = (I32)do_aspawn(NULL, MARK, SP);
4263 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4267 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4269 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4271 STATUS_NATIVE_CHILD_SET(value);
4274 XPUSHi(result ? value : STATUS_CURRENT);
4275 #endif /* !FORK or VMS or OS/2 */
4282 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4287 while (++MARK <= SP) {
4288 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4293 TAINT_PROPER("exec");
4295 PERL_FLUSHALL_FOR_CHILD;
4296 if (PL_op->op_flags & OPf_STACKED) {
4297 SV * const really = *++MARK;
4298 value = (I32)do_aexec(really, MARK, SP);
4300 else if (SP - MARK != 1)
4302 value = (I32)vms_do_aexec(NULL, MARK, SP);
4306 (void ) do_aspawn(NULL, MARK, SP);
4310 value = (I32)do_aexec(NULL, MARK, SP);
4315 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4318 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4321 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4335 # ifdef THREADS_HAVE_PIDS
4336 if (PL_ppid != 1 && getppid() == 1)
4337 /* maybe the parent process has died. Refresh ppid cache */
4341 XPUSHi( getppid() );
4345 DIE(aTHX_ PL_no_func, "getppid");
4355 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4358 pgrp = (I32)BSD_GETPGRP(pid);
4360 if (pid != 0 && pid != PerlProc_getpid())
4361 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4367 DIE(aTHX_ PL_no_func, "getpgrp()");
4388 TAINT_PROPER("setpgrp");
4390 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4392 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4393 || (pid != 0 && pid != PerlProc_getpid()))
4395 DIE(aTHX_ "setpgrp can't take arguments");
4397 SETi( setpgrp() >= 0 );
4398 #endif /* USE_BSDPGRP */
4401 DIE(aTHX_ PL_no_func, "setpgrp()");
4408 #ifdef HAS_GETPRIORITY
4410 const int who = POPi;
4411 const int which = TOPi;
4412 SETi( getpriority(which, who) );
4415 DIE(aTHX_ PL_no_func, "getpriority()");
4422 #ifdef HAS_SETPRIORITY
4424 const int niceval = POPi;
4425 const int who = POPi;
4426 const int which = TOPi;
4427 TAINT_PROPER("setpriority");
4428 SETi( setpriority(which, who, niceval) >= 0 );
4431 DIE(aTHX_ PL_no_func, "setpriority()");
4442 XPUSHn( time(NULL) );
4444 XPUSHi( time(NULL) );
4456 (void)PerlProc_times(&PL_timesbuf);
4458 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4459 /* struct tms, though same data */
4463 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4464 if (GIMME == G_ARRAY) {
4465 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4466 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4467 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4475 if (GIMME == G_ARRAY) {
4482 DIE(aTHX_ "times not implemented");
4485 #endif /* HAS_TIMES */
4488 /* The 32 bit int year limits the times we can represent to these
4489 boundaries with a few days wiggle room to account for time zone
4492 /* Sat Jan 3 00:00:00 -2147481748 */
4493 #define TIME_LOWER_BOUND -67768100567755200.0
4494 /* Sun Dec 29 12:00:00 2147483647 */
4495 #define TIME_UPPER_BOUND 67767976233316800.0
4504 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4505 static const char * const dayname[] =
4506 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4507 static const char * const monname[] =
4508 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4509 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4514 when = (Time64_T)now;
4517 double input = Perl_floor(POPn);
4518 when = (Time64_T)input;
4519 if (when != input) {
4520 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4521 "%s(%.0f) too large", opname, input);
4525 if ( TIME_LOWER_BOUND > when ) {
4526 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4527 "%s(%.0f) too small", opname, when);
4530 else if( when > TIME_UPPER_BOUND ) {
4531 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4532 "%s(%.0f) too large", opname, when);
4536 if (PL_op->op_type == OP_LOCALTIME)
4537 err = S_localtime64_r(&when, &tmbuf);
4539 err = S_gmtime64_r(&when, &tmbuf);
4543 /* XXX %lld broken for quads */
4544 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4545 "%s(%.0f) failed", opname, (double)when);
4548 if (GIMME != G_ARRAY) { /* scalar context */
4550 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4551 double year = (double)tmbuf.tm_year + 1900;
4558 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4559 dayname[tmbuf.tm_wday],
4560 monname[tmbuf.tm_mon],
4568 else { /* list context */
4574 mPUSHi(tmbuf.tm_sec);
4575 mPUSHi(tmbuf.tm_min);
4576 mPUSHi(tmbuf.tm_hour);
4577 mPUSHi(tmbuf.tm_mday);
4578 mPUSHi(tmbuf.tm_mon);
4579 mPUSHn(tmbuf.tm_year);
4580 mPUSHi(tmbuf.tm_wday);
4581 mPUSHi(tmbuf.tm_yday);
4582 mPUSHi(tmbuf.tm_isdst);
4593 anum = alarm((unsigned int)anum);
4600 DIE(aTHX_ PL_no_func, "alarm");
4612 (void)time(&lasttime);
4617 PerlProc_sleep((unsigned int)duration);
4620 XPUSHi(when - lasttime);
4624 /* Shared memory. */
4625 /* Merged with some message passing. */
4629 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4630 dVAR; dSP; dMARK; dTARGET;
4631 const int op_type = PL_op->op_type;
4636 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4639 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4642 value = (I32)(do_semop(MARK, SP) >= 0);
4645 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4661 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4662 dVAR; dSP; dMARK; dTARGET;
4663 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4670 DIE(aTHX_ "System V IPC is not implemented on this machine");
4677 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4678 dVAR; dSP; dMARK; dTARGET;
4679 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4687 PUSHp(zero_but_true, ZBTLEN);
4695 /* I can't const this further without getting warnings about the types of
4696 various arrays passed in from structures. */
4698 S_space_join_names_mortal(pTHX_ char *const *array)
4702 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4704 if (array && *array) {
4705 target = newSVpvs_flags("", SVs_TEMP);
4707 sv_catpv(target, *array);
4710 sv_catpvs(target, " ");
4713 target = sv_mortalcopy(&PL_sv_no);
4718 /* Get system info. */
4722 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4724 I32 which = PL_op->op_type;
4725 register char **elem;
4727 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4728 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4729 struct hostent *gethostbyname(Netdb_name_t);
4730 struct hostent *gethostent(void);
4732 struct hostent *hent = NULL;
4736 if (which == OP_GHBYNAME) {
4737 #ifdef HAS_GETHOSTBYNAME
4738 const char* const name = POPpbytex;
4739 hent = PerlSock_gethostbyname(name);
4741 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4744 else if (which == OP_GHBYADDR) {
4745 #ifdef HAS_GETHOSTBYADDR
4746 const int addrtype = POPi;
4747 SV * const addrsv = POPs;
4749 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4751 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4753 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4757 #ifdef HAS_GETHOSTENT
4758 hent = PerlSock_gethostent();
4760 DIE(aTHX_ PL_no_sock_func, "gethostent");
4763 #ifdef HOST_NOT_FOUND
4765 #ifdef USE_REENTRANT_API
4766 # ifdef USE_GETHOSTENT_ERRNO
4767 h_errno = PL_reentrant_buffer->_gethostent_errno;
4770 STATUS_UNIX_SET(h_errno);
4774 if (GIMME != G_ARRAY) {
4775 PUSHs(sv = sv_newmortal());
4777 if (which == OP_GHBYNAME) {
4779 sv_setpvn(sv, hent->h_addr, hent->h_length);
4782 sv_setpv(sv, (char*)hent->h_name);
4788 mPUSHs(newSVpv((char*)hent->h_name, 0));
4789 PUSHs(space_join_names_mortal(hent->h_aliases));
4790 mPUSHi(hent->h_addrtype);
4791 len = hent->h_length;
4794 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4795 mXPUSHp(*elem, len);
4799 mPUSHp(hent->h_addr, len);
4801 PUSHs(sv_mortalcopy(&PL_sv_no));
4806 DIE(aTHX_ PL_no_sock_func, "gethostent");
4813 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4815 I32 which = PL_op->op_type;
4817 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4818 struct netent *getnetbyaddr(Netdb_net_t, int);
4819 struct netent *getnetbyname(Netdb_name_t);
4820 struct netent *getnetent(void);
4822 struct netent *nent;
4824 if (which == OP_GNBYNAME){
4825 #ifdef HAS_GETNETBYNAME
4826 const char * const name = POPpbytex;
4827 nent = PerlSock_getnetbyname(name);
4829 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4832 else if (which == OP_GNBYADDR) {
4833 #ifdef HAS_GETNETBYADDR
4834 const int addrtype = POPi;
4835 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4836 nent = PerlSock_getnetbyaddr(addr, addrtype);
4838 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4842 #ifdef HAS_GETNETENT
4843 nent = PerlSock_getnetent();
4845 DIE(aTHX_ PL_no_sock_func, "getnetent");
4848 #ifdef HOST_NOT_FOUND
4850 #ifdef USE_REENTRANT_API
4851 # ifdef USE_GETNETENT_ERRNO
4852 h_errno = PL_reentrant_buffer->_getnetent_errno;
4855 STATUS_UNIX_SET(h_errno);
4860 if (GIMME != G_ARRAY) {
4861 PUSHs(sv = sv_newmortal());
4863 if (which == OP_GNBYNAME)
4864 sv_setiv(sv, (IV)nent->n_net);
4866 sv_setpv(sv, nent->n_name);
4872 mPUSHs(newSVpv(nent->n_name, 0));
4873 PUSHs(space_join_names_mortal(nent->n_aliases));
4874 mPUSHi(nent->n_addrtype);
4875 mPUSHi(nent->n_net);
4880 DIE(aTHX_ PL_no_sock_func, "getnetent");
4887 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4889 I32 which = PL_op->op_type;
4891 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4892 struct protoent *getprotobyname(Netdb_name_t);
4893 struct protoent *getprotobynumber(int);
4894 struct protoent *getprotoent(void);
4896 struct protoent *pent;
4898 if (which == OP_GPBYNAME) {
4899 #ifdef HAS_GETPROTOBYNAME
4900 const char* const name = POPpbytex;
4901 pent = PerlSock_getprotobyname(name);
4903 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4906 else if (which == OP_GPBYNUMBER) {
4907 #ifdef HAS_GETPROTOBYNUMBER
4908 const int number = POPi;
4909 pent = PerlSock_getprotobynumber(number);
4911 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4915 #ifdef HAS_GETPROTOENT
4916 pent = PerlSock_getprotoent();
4918 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4922 if (GIMME != G_ARRAY) {
4923 PUSHs(sv = sv_newmortal());
4925 if (which == OP_GPBYNAME)
4926 sv_setiv(sv, (IV)pent->p_proto);
4928 sv_setpv(sv, pent->p_name);
4934 mPUSHs(newSVpv(pent->p_name, 0));
4935 PUSHs(space_join_names_mortal(pent->p_aliases));
4936 mPUSHi(pent->p_proto);
4941 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4948 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4950 I32 which = PL_op->op_type;
4952 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4953 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4954 struct servent *getservbyport(int, Netdb_name_t);
4955 struct servent *getservent(void);
4957 struct servent *sent;
4959 if (which == OP_GSBYNAME) {
4960 #ifdef HAS_GETSERVBYNAME
4961 const char * const proto = POPpbytex;
4962 const char * const name = POPpbytex;
4963 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4965 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4968 else if (which == OP_GSBYPORT) {
4969 #ifdef HAS_GETSERVBYPORT
4970 const char * const proto = POPpbytex;
4971 unsigned short port = (unsigned short)POPu;
4973 port = PerlSock_htons(port);
4975 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4977 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4981 #ifdef HAS_GETSERVENT
4982 sent = PerlSock_getservent();
4984 DIE(aTHX_ PL_no_sock_func, "getservent");
4988 if (GIMME != G_ARRAY) {
4989 PUSHs(sv = sv_newmortal());
4991 if (which == OP_GSBYNAME) {
4993 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4995 sv_setiv(sv, (IV)(sent->s_port));
4999 sv_setpv(sv, sent->s_name);
5005 mPUSHs(newSVpv(sent->s_name, 0));
5006 PUSHs(space_join_names_mortal(sent->s_aliases));
5008 mPUSHi(PerlSock_ntohs(sent->s_port));
5010 mPUSHi(sent->s_port);
5012 mPUSHs(newSVpv(sent->s_proto, 0));
5017 DIE(aTHX_ PL_no_sock_func, "getservent");
5024 #ifdef HAS_SETHOSTENT
5026 PerlSock_sethostent(TOPi);
5029 DIE(aTHX_ PL_no_sock_func, "sethostent");
5036 #ifdef HAS_SETNETENT
5038 (void)PerlSock_setnetent(TOPi);
5041 DIE(aTHX_ PL_no_sock_func, "setnetent");
5048 #ifdef HAS_SETPROTOENT
5050 (void)PerlSock_setprotoent(TOPi);
5053 DIE(aTHX_ PL_no_sock_func, "setprotoent");
5060 #ifdef HAS_SETSERVENT
5062 (void)PerlSock_setservent(TOPi);
5065 DIE(aTHX_ PL_no_sock_func, "setservent");
5072 #ifdef HAS_ENDHOSTENT
5074 PerlSock_endhostent();
5078 DIE(aTHX_ PL_no_sock_func, "endhostent");
5085 #ifdef HAS_ENDNETENT
5087 PerlSock_endnetent();
5091 DIE(aTHX_ PL_no_sock_func, "endnetent");
5098 #ifdef HAS_ENDPROTOENT
5100 PerlSock_endprotoent();
5104 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5111 #ifdef HAS_ENDSERVENT
5113 PerlSock_endservent();
5117 DIE(aTHX_ PL_no_sock_func, "endservent");
5126 I32 which = PL_op->op_type;
5128 struct passwd *pwent = NULL;
5130 * We currently support only the SysV getsp* shadow password interface.
5131 * The interface is declared in <shadow.h> and often one needs to link
5132 * with -lsecurity or some such.
5133 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5136 * AIX getpwnam() is clever enough to return the encrypted password
5137 * only if the caller (euid?) is root.
5139 * There are at least three other shadow password APIs. Many platforms
5140 * seem to contain more than one interface for accessing the shadow
5141 * password databases, possibly for compatibility reasons.
5142 * The getsp*() is by far he simplest one, the other two interfaces
5143 * are much more complicated, but also very similar to each other.
5148 * struct pr_passwd *getprpw*();
5149 * The password is in
5150 * char getprpw*(...).ufld.fd_encrypt[]
5151 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5156 * struct es_passwd *getespw*();
5157 * The password is in
5158 * char *(getespw*(...).ufld.fd_encrypt)
5159 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5162 * struct userpw *getuserpw();
5163 * The password is in
5164 * char *(getuserpw(...)).spw_upw_passwd
5165 * (but the de facto standard getpwnam() should work okay)
5167 * Mention I_PROT here so that Configure probes for it.
5169 * In HP-UX for getprpw*() the manual page claims that one should include
5170 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5171 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5172 * and pp_sys.c already includes <shadow.h> if there is such.
5174 * Note that <sys/security.h> is already probed for, but currently
5175 * it is only included in special cases.
5177 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5178 * be preferred interface, even though also the getprpw*() interface
5179 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5180 * One also needs to call set_auth_parameters() in main() before
5181 * doing anything else, whether one is using getespw*() or getprpw*().
5183 * Note that accessing the shadow databases can be magnitudes
5184 * slower than accessing the standard databases.
5189 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5190 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5191 * the pw_comment is left uninitialized. */
5192 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5198 const char* const name = POPpbytex;
5199 pwent = getpwnam(name);
5205 pwent = getpwuid(uid);
5209 # ifdef HAS_GETPWENT
5211 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5212 if (pwent) pwent = getpwnam(pwent->pw_name);
5215 DIE(aTHX_ PL_no_func, "getpwent");
5221 if (GIMME != G_ARRAY) {
5222 PUSHs(sv = sv_newmortal());
5224 if (which == OP_GPWNAM)
5225 # if Uid_t_sign <= 0
5226 sv_setiv(sv, (IV)pwent->pw_uid);
5228 sv_setuv(sv, (UV)pwent->pw_uid);
5231 sv_setpv(sv, pwent->pw_name);
5237 mPUSHs(newSVpv(pwent->pw_name, 0));
5241 /* If we have getspnam(), we try to dig up the shadow
5242 * password. If we are underprivileged, the shadow
5243 * interface will set the errno to EACCES or similar,
5244 * and return a null pointer. If this happens, we will
5245 * use the dummy password (usually "*" or "x") from the
5246 * standard password database.
5248 * In theory we could skip the shadow call completely
5249 * if euid != 0 but in practice we cannot know which
5250 * security measures are guarding the shadow databases
5251 * on a random platform.
5253 * Resist the urge to use additional shadow interfaces.
5254 * Divert the urge to writing an extension instead.
5257 /* Some AIX setups falsely(?) detect some getspnam(), which
5258 * has a different API than the Solaris/IRIX one. */
5259 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5262 const struct spwd * const spwent = getspnam(pwent->pw_name);
5263 /* Save and restore errno so that
5264 * underprivileged attempts seem
5265 * to have never made the unsccessful
5266 * attempt to retrieve the shadow password. */
5268 if (spwent && spwent->sp_pwdp)
5269 sv_setpv(sv, spwent->sp_pwdp);
5273 if (!SvPOK(sv)) /* Use the standard password, then. */
5274 sv_setpv(sv, pwent->pw_passwd);
5277 # ifndef INCOMPLETE_TAINTS
5278 /* passwd is tainted because user himself can diddle with it.
5279 * admittedly not much and in a very limited way, but nevertheless. */
5283 # if Uid_t_sign <= 0
5284 mPUSHi(pwent->pw_uid);
5286 mPUSHu(pwent->pw_uid);
5289 # if Uid_t_sign <= 0
5290 mPUSHi(pwent->pw_gid);
5292 mPUSHu(pwent->pw_gid);
5294 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5295 * because of the poor interface of the Perl getpw*(),
5296 * not because there's some standard/convention saying so.
5297 * A better interface would have been to return a hash,
5298 * but we are accursed by our history, alas. --jhi. */
5300 mPUSHi(pwent->pw_change);
5303 mPUSHi(pwent->pw_quota);
5306 mPUSHs(newSVpv(pwent->pw_age, 0));
5308 /* I think that you can never get this compiled, but just in case. */
5309 PUSHs(sv_mortalcopy(&PL_sv_no));
5314 /* pw_class and pw_comment are mutually exclusive--.
5315 * see the above note for pw_change, pw_quota, and pw_age. */
5317 mPUSHs(newSVpv(pwent->pw_class, 0));
5320 mPUSHs(newSVpv(pwent->pw_comment, 0));
5322 /* I think that you can never get this compiled, but just in case. */
5323 PUSHs(sv_mortalcopy(&PL_sv_no));
5328 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5330 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5332 # ifndef INCOMPLETE_TAINTS
5333 /* pw_gecos is tainted because user himself can diddle with it. */
5337 mPUSHs(newSVpv(pwent->pw_dir, 0));
5339 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5340 # ifndef INCOMPLETE_TAINTS
5341 /* pw_shell is tainted because user himself can diddle with it. */
5346 mPUSHi(pwent->pw_expire);
5351 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5358 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5363 DIE(aTHX_ PL_no_func, "setpwent");
5370 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5375 DIE(aTHX_ PL_no_func, "endpwent");
5384 const I32 which = PL_op->op_type;
5385 const struct group *grent;
5387 if (which == OP_GGRNAM) {
5388 const char* const name = POPpbytex;
5389 grent = (const struct group *)getgrnam(name);
5391 else if (which == OP_GGRGID) {
5392 const Gid_t gid = POPi;
5393 grent = (const struct group *)getgrgid(gid);
5397 grent = (struct group *)getgrent();
5399 DIE(aTHX_ PL_no_func, "getgrent");
5403 if (GIMME != G_ARRAY) {
5404 SV * const sv = sv_newmortal();
5408 if (which == OP_GGRNAM)
5410 sv_setiv(sv, (IV)grent->gr_gid);
5412 sv_setuv(sv, (UV)grent->gr_gid);
5415 sv_setpv(sv, grent->gr_name);
5421 mPUSHs(newSVpv(grent->gr_name, 0));
5424 mPUSHs(newSVpv(grent->gr_passwd, 0));
5426 PUSHs(sv_mortalcopy(&PL_sv_no));
5430 mPUSHi(grent->gr_gid);
5432 mPUSHu(grent->gr_gid);
5435 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5436 /* In UNICOS/mk (_CRAYMPP) the multithreading
5437 * versions (getgrnam_r, getgrgid_r)
5438 * seem to return an illegal pointer
5439 * as the group members list, gr_mem.
5440 * getgrent() doesn't even have a _r version
5441 * but the gr_mem is poisonous anyway.
5442 * So yes, you cannot get the list of group
5443 * members if building multithreaded in UNICOS/mk. */
5444 PUSHs(space_join_names_mortal(grent->gr_mem));
5450 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5457 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5462 DIE(aTHX_ PL_no_func, "setgrent");
5469 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5474 DIE(aTHX_ PL_no_func, "endgrent");
5485 if (!(tmps = PerlProc_getlogin()))
5487 PUSHp(tmps, strlen(tmps));
5490 DIE(aTHX_ PL_no_func, "getlogin");
5495 /* Miscellaneous. */
5500 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5501 register I32 items = SP - MARK;
5502 unsigned long a[20];
5507 while (++MARK <= SP) {
5508 if (SvTAINTED(*MARK)) {
5514 TAINT_PROPER("syscall");
5517 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5518 * or where sizeof(long) != sizeof(char*). But such machines will
5519 * not likely have syscall implemented either, so who cares?
5521 while (++MARK <= SP) {
5522 if (SvNIOK(*MARK) || !i)
5523 a[i++] = SvIV(*MARK);
5524 else if (*MARK == &PL_sv_undef)
5527 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5533 DIE(aTHX_ "Too many args to syscall");
5535 DIE(aTHX_ "Too few args to syscall");
5537 retval = syscall(a[0]);
5540 retval = syscall(a[0],a[1]);
5543 retval = syscall(a[0],a[1],a[2]);
5546 retval = syscall(a[0],a[1],a[2],a[3]);
5549 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5552 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5555 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5558 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5562 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5565 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5568 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5572 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5576 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5580 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5581 a[10],a[11],a[12],a[13]);
5583 #endif /* atarist */
5589 DIE(aTHX_ PL_no_func, "syscall");
5594 #ifdef FCNTL_EMULATE_FLOCK
5596 /* XXX Emulate flock() with fcntl().
5597 What's really needed is a good file locking module.
5601 fcntl_emulate_flock(int fd, int operation)
5606 switch (operation & ~LOCK_NB) {
5608 flock.l_type = F_RDLCK;
5611 flock.l_type = F_WRLCK;
5614 flock.l_type = F_UNLCK;
5620 flock.l_whence = SEEK_SET;
5621 flock.l_start = flock.l_len = (Off_t)0;
5623 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5624 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5625 errno = EWOULDBLOCK;
5629 #endif /* FCNTL_EMULATE_FLOCK */
5631 #ifdef LOCKF_EMULATE_FLOCK
5633 /* XXX Emulate flock() with lockf(). This is just to increase
5634 portability of scripts. The calls are not completely
5635 interchangeable. What's really needed is a good file
5639 /* The lockf() constants might have been defined in <unistd.h>.
5640 Unfortunately, <unistd.h> causes troubles on some mixed
5641 (BSD/POSIX) systems, such as SunOS 4.1.3.
5643 Further, the lockf() constants aren't POSIX, so they might not be
5644 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5645 just stick in the SVID values and be done with it. Sigh.
5649 # define F_ULOCK 0 /* Unlock a previously locked region */
5652 # define F_LOCK 1 /* Lock a region for exclusive use */
5655 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5658 # define F_TEST 3 /* Test a region for other processes locks */
5662 lockf_emulate_flock(int fd, int operation)
5668 /* flock locks entire file so for lockf we need to do the same */
5669 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5670 if (pos > 0) /* is seekable and needs to be repositioned */
5671 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5672 pos = -1; /* seek failed, so don't seek back afterwards */
5675 switch (operation) {
5677 /* LOCK_SH - get a shared lock */
5679 /* LOCK_EX - get an exclusive lock */
5681 i = lockf (fd, F_LOCK, 0);
5684 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5685 case LOCK_SH|LOCK_NB:
5686 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5687 case LOCK_EX|LOCK_NB:
5688 i = lockf (fd, F_TLOCK, 0);
5690 if ((errno == EAGAIN) || (errno == EACCES))
5691 errno = EWOULDBLOCK;
5694 /* LOCK_UN - unlock (non-blocking is a no-op) */
5696 case LOCK_UN|LOCK_NB:
5697 i = lockf (fd, F_ULOCK, 0);
5700 /* Default - can't decipher operation */
5707 if (pos > 0) /* need to restore position of the handle */
5708 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5713 #endif /* LOCKF_EMULATE_FLOCK */
5717 * c-indentation-style: bsd
5719 * indent-tabs-mode: t
5722 * ex: set ts=8 sts=4 sw=4 noet: