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
38 /* Shadow password support for solaris - pdo@cs.umd.edu
39 * Not just Solaris: at least HP-UX, IRIX, Linux.
40 * The API is from SysV.
42 * There are at least two more shadow interfaces,
43 * see the comments in pp_gpwent().
47 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
48 * and another MAXINT from "perl.h" <- <sys/param.h>. */
55 # include <sys/wait.h>
59 # include <sys/resource.h>
68 # include <sys/select.h>
72 /* XXX Configure test needed.
73 h_errno might not be a simple 'int', especially for multi-threaded
74 applications, see "extern int errno in perl.h". Creating such
75 a test requires taking into account the differences between
76 compiling multithreaded and singlethreaded ($ccflags et al).
77 HOST_NOT_FOUND is typically defined in <netdb.h>.
79 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
88 struct passwd *getpwnam (char *);
89 struct passwd *getpwuid (Uid_t);
94 struct passwd *getpwent (void);
95 #elif defined (VMS) && defined (my_getpwent)
96 struct passwd *Perl_my_getpwent (pTHX);
105 struct group *getgrnam (char *);
106 struct group *getgrgid (Gid_t);
110 struct group *getgrent (void);
116 # if defined(_MSC_VER) || defined(__MINGW32__)
117 # include <sys/utime.h>
124 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
127 # define my_chsize PerlLIO_chsize
130 # define my_chsize PerlLIO_chsize
132 I32 my_chsize(int fd, Off_t length);
138 #else /* no flock() */
140 /* fcntl.h might not have been included, even if it exists, because
141 the current Configure only sets I_FCNTL if it's needed to pick up
142 the *_OK constants. Make sure it has been included before testing
143 the fcntl() locking constants. */
144 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
148 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
149 # define FLOCK fcntl_emulate_flock
150 # define FCNTL_EMULATE_FLOCK
151 # else /* no flock() or fcntl(F_SETLK,...) */
153 # define FLOCK lockf_emulate_flock
154 # define LOCKF_EMULATE_FLOCK
156 # endif /* no flock() or fcntl(F_SETLK,...) */
159 static int FLOCK (int, int);
162 * These are the flock() constants. Since this sytems doesn't have
163 * flock(), the values of the constants are probably not available.
177 # endif /* emulating flock() */
179 #endif /* no flock() */
182 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
184 #if defined(I_SYS_ACCESS) && !defined(R_OK)
185 # include <sys/access.h>
188 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
189 # define FD_CLOEXEC 1 /* NeXT needs this */
195 /* Missing protos on LynxOS */
196 void sethostent(int);
197 void endhostent(void);
199 void endnetent(void);
200 void setprotoent(int);
201 void endprotoent(void);
202 void setservent(int);
203 void endservent(void);
206 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
208 /* F_OK unused: if stat() cannot find it... */
210 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
211 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
212 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
215 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
216 # ifdef I_SYS_SECURITY
217 # include <sys/security.h>
221 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
224 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
228 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
230 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
234 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
235 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
236 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
239 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
241 const Uid_t ruid = getuid();
242 const Uid_t euid = geteuid();
243 const Gid_t rgid = getgid();
244 const Gid_t egid = getegid();
248 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
249 Perl_croak(aTHX_ "switching effective uid is not implemented");
252 if (setreuid(euid, ruid))
255 if (setresuid(euid, ruid, (Uid_t)-1))
258 Perl_croak(aTHX_ "entering effective uid failed");
261 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
262 Perl_croak(aTHX_ "switching effective gid is not implemented");
265 if (setregid(egid, rgid))
268 if (setresgid(egid, rgid, (Gid_t)-1))
271 Perl_croak(aTHX_ "entering effective gid failed");
274 res = access(path, mode);
277 if (setreuid(ruid, euid))
280 if (setresuid(ruid, euid, (Uid_t)-1))
283 Perl_croak(aTHX_ "leaving effective uid failed");
286 if (setregid(rgid, egid))
289 if (setresgid(rgid, egid, (Gid_t)-1))
292 Perl_croak(aTHX_ "leaving effective gid failed");
297 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
304 const char * const tmps = POPpconstx;
305 const I32 gimme = GIMME_V;
306 const char *mode = "r";
309 if (PL_op->op_private & OPpOPEN_IN_RAW)
311 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
313 fp = PerlProc_popen(tmps, mode);
315 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
317 PerlIO_apply_layers(aTHX_ fp,mode,type);
319 if (gimme == G_VOID) {
321 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
324 else if (gimme == G_SCALAR) {
327 PL_rs = &PL_sv_undef;
328 sv_setpvs(TARG, ""); /* note that this preserves previous buffer */
329 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
337 SV * const sv = newSV(79);
338 if (sv_gets(sv, fp, 0) == NULL) {
343 if (SvLEN(sv) - SvCUR(sv) > 20) {
344 SvPV_shrink_to_cur(sv);
349 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
350 TAINT; /* "I believe that this is not gratuitous!" */
353 STATUS_NATIVE_CHILD_SET(-1);
354 if (gimme == G_SCALAR)
365 tryAMAGICunTARGET(iter, -1);
367 /* Note that we only ever get here if File::Glob fails to load
368 * without at the same time croaking, for some reason, or if
369 * perl was built with PERL_EXTERNAL_GLOB */
376 * The external globbing program may use things we can't control,
377 * so for security reasons we must assume the worst.
380 taint_proper(PL_no_security, "glob");
384 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
385 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
387 SAVESPTR(PL_rs); /* This is not permanent, either. */
388 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
391 *SvPVX(PL_rs) = '\n';
395 result = do_readline();
403 PL_last_in_gv = cGVOP_gv;
404 return do_readline();
415 do_join(TARG, &PL_sv_no, MARK, SP);
419 else if (SP == MARK) {
427 tmps = SvPV_const(tmpsv, len);
428 if ((!tmps || !len) && PL_errgv) {
429 SV * const error = ERRSV;
430 SvUPGRADE(error, SVt_PV);
431 if (SvPOK(error) && SvCUR(error))
432 sv_catpvs(error, "\t...caught");
434 tmps = SvPV_const(tmpsv, len);
437 tmpsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
439 Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv));
451 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
453 if (SP - MARK != 1) {
455 do_join(TARG, &PL_sv_no, MARK, SP);
457 tmps = SvPV_const(tmpsv, len);
463 tmps = SvROK(tmpsv) ? (const char *)NULL : SvPV_const(tmpsv, len);
466 SV * const error = ERRSV;
467 SvUPGRADE(error, SVt_PV);
468 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
470 SvSetSV(error,tmpsv);
471 else if (sv_isobject(error)) {
472 HV * const stash = SvSTASH(SvRV(error));
473 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
475 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
476 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
483 call_sv(MUTABLE_SV(GvCV(gv)),
484 G_SCALAR|G_EVAL|G_KEEPERR);
485 sv_setsv(error,*PL_stack_sp--);
491 if (SvPOK(error) && SvCUR(error))
492 sv_catpvs(error, "\t...propagated");
495 tmps = SvPV_const(tmpsv, len);
501 tmpsv = newSVpvs_flags("Died", SVs_TEMP);
503 DIE(aTHX_ "%"SVf, SVfARG(tmpsv));
519 GV * const gv = MUTABLE_GV(*++MARK);
522 DIE(aTHX_ PL_no_usym, "filehandle");
524 if ((io = GvIOp(gv))) {
526 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
528 if (IoDIRP(io) && ckWARN2(WARN_IO, WARN_DEPRECATED))
529 Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
530 "Opening dirhandle %s also as a file", GvENAME(gv));
532 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
534 /* Method's args are same as ours ... */
535 /* ... except handle is replaced by the object */
536 *MARK-- = SvTIED_obj(MUTABLE_SV(io), mg);
540 call_method("OPEN", G_SCALAR);
554 tmps = SvPV_const(sv, len);
555 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
558 PUSHi( (I32)PL_forkprocess );
559 else if (PL_forkprocess == 0) /* we are a new child */
569 GV * const gv = (MAXARG == 0) ? PL_defoutgv : MUTABLE_GV(POPs);
572 IO * const io = GvIO(gv);
574 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
577 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
580 call_method("CLOSE", G_SCALAR);
588 PUSHs(boolSV(do_close(gv, TRUE)));
601 GV * const wgv = MUTABLE_GV(POPs);
602 GV * const rgv = MUTABLE_GV(POPs);
607 if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
608 DIE(aTHX_ PL_no_usym, "filehandle");
613 do_close(rgv, FALSE);
615 do_close(wgv, FALSE);
617 if (PerlProc_pipe(fd) < 0)
620 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
621 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
622 IoOFP(rstio) = IoIFP(rstio);
623 IoIFP(wstio) = IoOFP(wstio);
624 IoTYPE(rstio) = IoTYPE_RDONLY;
625 IoTYPE(wstio) = IoTYPE_WRONLY;
627 if (!IoIFP(rstio) || !IoOFP(wstio)) {
629 PerlIO_close(IoIFP(rstio));
631 PerlLIO_close(fd[0]);
633 PerlIO_close(IoOFP(wstio));
635 PerlLIO_close(fd[1]);
638 #if defined(HAS_FCNTL) && defined(F_SETFD)
639 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
640 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
647 DIE(aTHX_ PL_no_func, "pipe");
661 gv = MUTABLE_GV(POPs);
663 if (gv && (io = GvIO(gv))
664 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
667 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
670 call_method("FILENO", G_SCALAR);
676 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
677 /* Can't do this because people seem to do things like
678 defined(fileno($foo)) to check whether $foo is a valid fh.
679 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
680 report_evil_fh(gv, io, PL_op->op_type);
685 PUSHi(PerlIO_fileno(fp));
698 anum = PerlLIO_umask(022);
699 /* setting it to 022 between the two calls to umask avoids
700 * to have a window where the umask is set to 0 -- meaning
701 * that another thread could create world-writeable files. */
703 (void)PerlLIO_umask(anum);
706 anum = PerlLIO_umask(POPi);
707 TAINT_PROPER("umask");
710 /* Only DIE if trying to restrict permissions on "user" (self).
711 * Otherwise it's harmless and more useful to just return undef
712 * since 'group' and 'other' concepts probably don't exist here. */
713 if (MAXARG >= 1 && (POPi & 0700))
714 DIE(aTHX_ "umask not implemented");
715 XPUSHs(&PL_sv_undef);
734 gv = MUTABLE_GV(POPs);
736 if (gv && (io = GvIO(gv))) {
737 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
740 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
745 call_method("BINMODE", G_SCALAR);
753 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
754 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
755 report_evil_fh(gv, io, PL_op->op_type);
756 SETERRNO(EBADF,RMS_IFI);
763 const char *d = NULL;
766 d = SvPV_const(discp, len);
767 mode = mode_from_discipline(d, len);
768 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
769 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
770 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
791 const I32 markoff = MARK - PL_stack_base;
792 const char *methname;
793 int how = PERL_MAGIC_tied;
797 switch(SvTYPE(varsv)) {
799 methname = "TIEHASH";
800 HvEITER_set(MUTABLE_HV(varsv), 0);
803 methname = "TIEARRAY";
806 if (isGV_with_GP(varsv)) {
807 #ifdef GV_UNIQUE_CHECK
808 if (GvUNIQUE((const GV *)varsv)) {
809 Perl_croak(aTHX_ "Attempt to tie unique GV");
812 methname = "TIEHANDLE";
813 how = PERL_MAGIC_tiedscalar;
814 /* For tied filehandles, we apply tiedscalar magic to the IO
815 slot of the GP rather than the GV itself. AMS 20010812 */
817 GvIOp(varsv) = newIO();
818 varsv = MUTABLE_SV(GvIOp(varsv));
823 methname = "TIESCALAR";
824 how = PERL_MAGIC_tiedscalar;
828 if (sv_isobject(*MARK)) { /* Calls GET magic. */
830 PUSHSTACKi(PERLSI_MAGIC);
832 EXTEND(SP,(I32)items);
836 call_method(methname, G_SCALAR);
839 /* Not clear why we don't call call_method here too.
840 * perhaps to get different error message ?
843 const char *name = SvPV_nomg_const(*MARK, len);
844 stash = gv_stashpvn(name, len, 0);
845 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
846 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
847 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
850 PUSHSTACKi(PERLSI_MAGIC);
852 EXTEND(SP,(I32)items);
856 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
862 if (sv_isobject(sv)) {
863 sv_unmagic(varsv, how);
864 /* Croak if a self-tie on an aggregate is attempted. */
865 if (varsv == SvRV(sv) &&
866 (SvTYPE(varsv) == SVt_PVAV ||
867 SvTYPE(varsv) == SVt_PVHV))
869 "Self-ties of arrays and hashes are not supported");
870 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
873 SP = PL_stack_base + markoff;
883 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
884 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
886 if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
889 if ((mg = SvTIED_mg(sv, how))) {
890 SV * const obj = SvRV(SvTIED_obj(sv, mg));
892 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
894 if (gv && isGV(gv) && (cv = GvCV(gv))) {
896 XPUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
897 mXPUSHi(SvREFCNT(obj) - 1);
900 call_sv(MUTABLE_SV(cv), G_VOID);
904 else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
905 Perl_warner(aTHX_ packWARN(WARN_UNTIE),
906 "untie attempted while %"UVuf" inner references still exist",
907 (UV)SvREFCNT(obj) - 1 ) ;
911 sv_unmagic(sv, how) ;
921 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
922 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
924 if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
927 if ((mg = SvTIED_mg(sv, how))) {
928 SV *osv = SvTIED_obj(sv, mg);
929 if (osv == mg->mg_obj)
930 osv = sv_mortalcopy(osv);
944 HV * const hv = MUTABLE_HV(POPs);
945 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
946 stash = gv_stashsv(sv, 0);
947 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
949 require_pv("AnyDBM_File.pm");
951 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
952 DIE(aTHX_ "No dbm on this machine");
962 mPUSHu(O_RDWR|O_CREAT);
967 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
970 if (!sv_isobject(TOPs)) {
978 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
982 if (sv_isobject(TOPs)) {
983 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
984 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1001 struct timeval timebuf;
1002 struct timeval *tbuf = &timebuf;
1005 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1010 # if BYTEORDER & 0xf0000
1011 # define ORDERBYTE (0x88888888 - BYTEORDER)
1013 # define ORDERBYTE (0x4444 - BYTEORDER)
1019 for (i = 1; i <= 3; i++) {
1020 SV * const sv = SP[i];
1023 if (SvREADONLY(sv)) {
1025 sv_force_normal_flags(sv, 0);
1026 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1027 DIE(aTHX_ "%s", PL_no_modify);
1030 if (ckWARN(WARN_MISC))
1031 Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1032 SvPV_force_nolen(sv); /* force string conversion */
1039 /* little endians can use vecs directly */
1040 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1047 masksize = NFDBITS / NBBY;
1049 masksize = sizeof(long); /* documented int, everyone seems to use long */
1051 Zero(&fd_sets[0], 4, char*);
1054 # if SELECT_MIN_BITS == 1
1055 growsize = sizeof(fd_set);
1057 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1058 # undef SELECT_MIN_BITS
1059 # define SELECT_MIN_BITS __FD_SETSIZE
1061 /* If SELECT_MIN_BITS is greater than one we most probably will want
1062 * to align the sizes with SELECT_MIN_BITS/8 because for example
1063 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1064 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1065 * on (sets/tests/clears bits) is 32 bits. */
1066 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1074 timebuf.tv_sec = (long)value;
1075 value -= (NV)timebuf.tv_sec;
1076 timebuf.tv_usec = (long)(value * 1000000.0);
1081 for (i = 1; i <= 3; i++) {
1083 if (!SvOK(sv) || SvCUR(sv) == 0) {
1090 Sv_Grow(sv, growsize);
1094 while (++j <= growsize) {
1098 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1100 Newx(fd_sets[i], growsize, char);
1101 for (offset = 0; offset < growsize; offset += masksize) {
1102 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1103 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1106 fd_sets[i] = SvPVX(sv);
1110 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1111 /* Can't make just the (void*) conditional because that would be
1112 * cpp #if within cpp macro, and not all compilers like that. */
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],
1118 (void*) tbuf); /* Workaround for compiler bug. */
1120 nfound = PerlSock_select(
1122 (Select_fd_set_t) fd_sets[1],
1123 (Select_fd_set_t) fd_sets[2],
1124 (Select_fd_set_t) fd_sets[3],
1127 for (i = 1; i <= 3; i++) {
1130 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1132 for (offset = 0; offset < growsize; offset += masksize) {
1133 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1134 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1136 Safefree(fd_sets[i]);
1143 if (GIMME == G_ARRAY && tbuf) {
1144 value = (NV)(timebuf.tv_sec) +
1145 (NV)(timebuf.tv_usec) / 1000000.0;
1150 DIE(aTHX_ "select not implemented");
1155 =for apidoc setdefout
1157 Sets PL_defoutgv, the default file handle for output, to the passed in
1158 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1159 count of the passed in typeglob is increased by one, and the reference count
1160 of the typeglob that PL_defoutgv points to is decreased by one.
1166 Perl_setdefout(pTHX_ GV *gv)
1169 SvREFCNT_inc_simple_void(gv);
1171 SvREFCNT_dec(PL_defoutgv);
1179 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1180 GV * egv = GvEGV(PL_defoutgv);
1186 XPUSHs(&PL_sv_undef);
1188 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1189 if (gvp && *gvp == egv) {
1190 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1194 mXPUSHs(newRV(MUTABLE_SV(egv)));
1199 if (!GvIO(newdefout))
1200 gv_IOadd(newdefout);
1201 setdefout(newdefout);
1211 GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs);
1213 if (gv && (io = GvIO(gv))) {
1214 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1216 const I32 gimme = GIMME_V;
1218 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1221 call_method("GETC", gimme);
1224 if (gimme == G_SCALAR)
1225 SvSetMagicSV_nosteal(TARG, TOPs);
1229 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1230 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1231 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1232 report_evil_fh(gv, io, PL_op->op_type);
1233 SETERRNO(EBADF,RMS_IFI);
1237 sv_setpvs(TARG, " ");
1238 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1239 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1240 /* Find out how many bytes the char needs */
1241 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1244 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1245 SvCUR_set(TARG,1+len);
1254 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1257 register PERL_CONTEXT *cx;
1258 const I32 gimme = GIMME_V;
1260 PERL_ARGS_ASSERT_DOFORM;
1265 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1266 PUSHFORMAT(cx, retop);
1268 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1270 setdefout(gv); /* locally select filehandle so $% et al work */
1287 gv = MUTABLE_GV(POPs);
1302 goto not_a_format_reference;
1307 tmpsv = sv_newmortal();
1308 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1309 name = SvPV_nolen_const(tmpsv);
1311 DIE(aTHX_ "Undefined format \"%s\" called", name);
1313 not_a_format_reference:
1314 DIE(aTHX_ "Not a format reference");
1317 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1319 IoFLAGS(io) &= ~IOf_DIDTOP;
1320 return doform(cv,gv,PL_op->op_next);
1326 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1327 register IO * const io = GvIOp(gv);
1332 register PERL_CONTEXT *cx;
1334 if (!io || !(ofp = IoOFP(io)))
1337 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1338 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1340 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1341 PL_formtarget != PL_toptarget)
1345 if (!IoTOP_GV(io)) {
1348 if (!IoTOP_NAME(io)) {
1350 if (!IoFMT_NAME(io))
1351 IoFMT_NAME(io) = savepv(GvNAME(gv));
1352 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1353 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1354 if ((topgv && GvFORM(topgv)) ||
1355 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1356 IoTOP_NAME(io) = savesvpv(topname);
1358 IoTOP_NAME(io) = savepvs("top");
1360 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1361 if (!topgv || !GvFORM(topgv)) {
1362 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1365 IoTOP_GV(io) = topgv;
1367 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1368 I32 lines = IoLINES_LEFT(io);
1369 const char *s = SvPVX_const(PL_formtarget);
1370 if (lines <= 0) /* Yow, header didn't even fit!!! */
1372 while (lines-- > 0) {
1373 s = strchr(s, '\n');
1379 const STRLEN save = SvCUR(PL_formtarget);
1380 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1381 do_print(PL_formtarget, ofp);
1382 SvCUR_set(PL_formtarget, save);
1383 sv_chop(PL_formtarget, s);
1384 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1387 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1388 do_print(PL_formfeed, ofp);
1389 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1391 PL_formtarget = PL_toptarget;
1392 IoFLAGS(io) |= IOf_DIDTOP;
1395 DIE(aTHX_ "bad top format reference");
1398 SV * const sv = sv_newmortal();
1400 gv_efullname4(sv, fgv, NULL, FALSE);
1401 name = SvPV_nolen_const(sv);
1403 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1405 DIE(aTHX_ "Undefined top format called");
1407 if (cv && CvCLONE(cv))
1408 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1409 return doform(cv, gv, PL_op);
1413 POPBLOCK(cx,PL_curpm);
1419 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1421 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1422 else if (ckWARN(WARN_CLOSED))
1423 report_evil_fh(gv, io, PL_op->op_type);
1428 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1429 if (ckWARN(WARN_IO))
1430 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1432 if (!do_print(PL_formtarget, fp))
1435 FmLINES(PL_formtarget) = 0;
1436 SvCUR_set(PL_formtarget, 0);
1437 *SvEND(PL_formtarget) = '\0';
1438 if (IoFLAGS(io) & IOf_FLUSH)
1439 (void)PerlIO_flush(fp);
1444 PL_formtarget = PL_bodytarget;
1446 PERL_UNUSED_VAR(newsp);
1447 PERL_UNUSED_VAR(gimme);
1448 return cx->blk_sub.retop;
1453 dVAR; dSP; dMARK; dORIGMARK;
1459 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1461 if (gv && (io = GvIO(gv))) {
1462 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1464 if (MARK == ORIGMARK) {
1467 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1471 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1474 call_method("PRINTF", G_SCALAR);
1477 MARK = ORIGMARK + 1;
1485 if (!(io = GvIO(gv))) {
1486 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1487 report_evil_fh(gv, io, PL_op->op_type);
1488 SETERRNO(EBADF,RMS_IFI);
1491 else if (!(fp = IoOFP(io))) {
1492 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1494 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1495 else if (ckWARN(WARN_CLOSED))
1496 report_evil_fh(gv, io, PL_op->op_type);
1498 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1502 if (SvTAINTED(MARK[1]))
1503 TAINT_PROPER("printf");
1504 do_sprintf(sv, SP - MARK, MARK + 1);
1505 if (!do_print(sv, fp))
1508 if (IoFLAGS(io) & IOf_FLUSH)
1509 if (PerlIO_flush(fp) == EOF)
1520 PUSHs(&PL_sv_undef);
1528 const int perm = (MAXARG > 3) ? POPi : 0666;
1529 const int mode = POPi;
1530 SV * const sv = POPs;
1531 GV * const gv = MUTABLE_GV(POPs);
1534 /* Need TIEHANDLE method ? */
1535 const char * const tmps = SvPV_const(sv, len);
1536 /* FIXME? do_open should do const */
1537 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1538 IoLINES(GvIOp(gv)) = 0;
1542 PUSHs(&PL_sv_undef);
1549 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1555 Sock_size_t bufsize;
1563 bool charstart = FALSE;
1564 STRLEN charskip = 0;
1567 GV * const gv = MUTABLE_GV(*++MARK);
1568 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1569 && gv && (io = GvIO(gv)) )
1571 const MAGIC * mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1575 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1577 call_method("READ", G_SCALAR);
1591 sv_setpvs(bufsv, "");
1592 length = SvIVx(*++MARK);
1595 offset = SvIVx(*++MARK);
1599 if (!io || !IoIFP(io)) {
1600 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1601 report_evil_fh(gv, io, PL_op->op_type);
1602 SETERRNO(EBADF,RMS_IFI);
1605 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1606 buffer = SvPVutf8_force(bufsv, blen);
1607 /* UTF-8 may not have been set if they are all low bytes */
1612 buffer = SvPV_force(bufsv, blen);
1613 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1616 DIE(aTHX_ "Negative length");
1624 if (PL_op->op_type == OP_RECV) {
1625 char namebuf[MAXPATHLEN];
1626 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1627 bufsize = sizeof (struct sockaddr_in);
1629 bufsize = sizeof namebuf;
1631 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1635 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1636 /* 'offset' means 'flags' here */
1637 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1638 (struct sockaddr *)namebuf, &bufsize);
1642 /* Bogus return without padding */
1643 bufsize = sizeof (struct sockaddr_in);
1645 SvCUR_set(bufsv, count);
1646 *SvEND(bufsv) = '\0';
1647 (void)SvPOK_only(bufsv);
1651 /* This should not be marked tainted if the fp is marked clean */
1652 if (!(IoFLAGS(io) & IOf_UNTAINT))
1653 SvTAINTED_on(bufsv);
1655 sv_setpvn(TARG, namebuf, bufsize);
1660 if (PL_op->op_type == OP_RECV)
1661 DIE(aTHX_ PL_no_sock_func, "recv");
1663 if (DO_UTF8(bufsv)) {
1664 /* offset adjust in characters not bytes */
1665 blen = sv_len_utf8(bufsv);
1668 if (-offset > (int)blen)
1669 DIE(aTHX_ "Offset outside string");
1672 if (DO_UTF8(bufsv)) {
1673 /* convert offset-as-chars to offset-as-bytes */
1674 if (offset >= (int)blen)
1675 offset += SvCUR(bufsv) - blen;
1677 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1680 bufsize = SvCUR(bufsv);
1681 /* Allocating length + offset + 1 isn't perfect in the case of reading
1682 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1684 (should be 2 * length + offset + 1, or possibly something longer if
1685 PL_encoding is true) */
1686 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1687 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1688 Zero(buffer+bufsize, offset-bufsize, char);
1690 buffer = buffer + offset;
1692 read_target = bufsv;
1694 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1695 concatenate it to the current buffer. */
1697 /* Truncate the existing buffer to the start of where we will be
1699 SvCUR_set(bufsv, offset);
1701 read_target = sv_newmortal();
1702 SvUPGRADE(read_target, SVt_PV);
1703 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1706 if (PL_op->op_type == OP_SYSREAD) {
1707 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1708 if (IoTYPE(io) == IoTYPE_SOCKET) {
1709 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1715 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1720 #ifdef HAS_SOCKET__bad_code_maybe
1721 if (IoTYPE(io) == IoTYPE_SOCKET) {
1722 char namebuf[MAXPATHLEN];
1723 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1724 bufsize = sizeof (struct sockaddr_in);
1726 bufsize = sizeof namebuf;
1728 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1729 (struct sockaddr *)namebuf, &bufsize);
1734 count = PerlIO_read(IoIFP(io), buffer, length);
1735 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1736 if (count == 0 && PerlIO_error(IoIFP(io)))
1740 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1741 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1744 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1745 *SvEND(read_target) = '\0';
1746 (void)SvPOK_only(read_target);
1747 if (fp_utf8 && !IN_BYTES) {
1748 /* Look at utf8 we got back and count the characters */
1749 const char *bend = buffer + count;
1750 while (buffer < bend) {
1752 skip = UTF8SKIP(buffer);
1755 if (buffer - charskip + skip > bend) {
1756 /* partial character - try for rest of it */
1757 length = skip - (bend-buffer);
1758 offset = bend - SvPVX_const(bufsv);
1770 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1771 provided amount read (count) was what was requested (length)
1773 if (got < wanted && count == length) {
1774 length = wanted - got;
1775 offset = bend - SvPVX_const(bufsv);
1778 /* return value is character count */
1782 else if (buffer_utf8) {
1783 /* Let svcatsv upgrade the bytes we read in to utf8.
1784 The buffer is a mortal so will be freed soon. */
1785 sv_catsv_nomg(bufsv, read_target);
1788 /* This should not be marked tainted if the fp is marked clean */
1789 if (!(IoFLAGS(io) & IOf_UNTAINT))
1790 SvTAINTED_on(bufsv);
1802 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1808 STRLEN orig_blen_bytes;
1809 const int op_type = PL_op->op_type;
1813 GV *const gv = MUTABLE_GV(*++MARK);
1814 if (PL_op->op_type == OP_SYSWRITE
1815 && gv && (io = GvIO(gv))) {
1816 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1820 if (MARK == SP - 1) {
1822 mXPUSHi(sv_len(sv));
1827 *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg);
1829 call_method("WRITE", G_SCALAR);
1845 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1847 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1848 if (io && IoIFP(io))
1849 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1851 report_evil_fh(gv, io, PL_op->op_type);
1853 SETERRNO(EBADF,RMS_IFI);
1857 /* Do this first to trigger any overloading. */
1858 buffer = SvPV_const(bufsv, blen);
1859 orig_blen_bytes = blen;
1860 doing_utf8 = DO_UTF8(bufsv);
1862 if (PerlIO_isutf8(IoIFP(io))) {
1863 if (!SvUTF8(bufsv)) {
1864 /* We don't modify the original scalar. */
1865 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1866 buffer = (char *) tmpbuf;
1870 else if (doing_utf8) {
1871 STRLEN tmplen = blen;
1872 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1875 buffer = (char *) tmpbuf;
1879 assert((char *)result == buffer);
1880 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1884 if (op_type == OP_SYSWRITE) {
1885 Size_t length = 0; /* This length is in characters. */
1891 /* The SV is bytes, and we've had to upgrade it. */
1892 blen_chars = orig_blen_bytes;
1894 /* The SV really is UTF-8. */
1895 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1896 /* Don't call sv_len_utf8 again because it will call magic
1897 or overloading a second time, and we might get back a
1898 different result. */
1899 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1901 /* It's safe, and it may well be cached. */
1902 blen_chars = sv_len_utf8(bufsv);
1910 length = blen_chars;
1912 #if Size_t_size > IVSIZE
1913 length = (Size_t)SvNVx(*++MARK);
1915 length = (Size_t)SvIVx(*++MARK);
1917 if ((SSize_t)length < 0) {
1919 DIE(aTHX_ "Negative length");
1924 offset = SvIVx(*++MARK);
1926 if (-offset > (IV)blen_chars) {
1928 DIE(aTHX_ "Offset outside string");
1930 offset += blen_chars;
1931 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1933 DIE(aTHX_ "Offset outside string");
1937 if (length > blen_chars - offset)
1938 length = blen_chars - offset;
1940 /* Here we convert length from characters to bytes. */
1941 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1942 /* Either we had to convert the SV, or the SV is magical, or
1943 the SV has overloading, in which case we can't or mustn't
1944 or mustn't call it again. */
1946 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1947 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1949 /* It's a real UTF-8 SV, and it's not going to change under
1950 us. Take advantage of any cache. */
1952 I32 len_I32 = length;
1954 /* Convert the start and end character positions to bytes.
1955 Remember that the second argument to sv_pos_u2b is relative
1957 sv_pos_u2b(bufsv, &start, &len_I32);
1964 buffer = buffer+offset;
1966 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1967 if (IoTYPE(io) == IoTYPE_SOCKET) {
1968 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1974 /* See the note at doio.c:do_print about filesize limits. --jhi */
1975 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1981 const int flags = SvIVx(*++MARK);
1984 char * const sockbuf = SvPVx(*++MARK, mlen);
1985 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1986 flags, (struct sockaddr *)sockbuf, mlen);
1990 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1995 DIE(aTHX_ PL_no_sock_func, "send");
2002 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2005 #if Size_t_size > IVSIZE
2026 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2027 else if (PL_op->op_flags & OPf_SPECIAL)
2028 gv = PL_last_in_gv = GvEGV(PL_argvgv); /* eof() - ARGV magic */
2030 gv = PL_last_in_gv; /* eof */
2035 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2037 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2039 * in Perl 5.12 and later, the additional paramter is a bitmask:
2042 * 2 = eof() <- ARGV magic
2045 mPUSHi(1); /* 1 = eof(FH) - simple, explicit FH */
2046 else if (PL_op->op_flags & OPf_SPECIAL)
2047 mPUSHi(2); /* 2 = eof() - ARGV magic */
2049 mPUSHi(0); /* 0 = eof - simple, implicit FH */
2052 call_method("EOF", G_SCALAR);
2058 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2059 if (io && !IoIFP(io)) {
2060 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2062 IoFLAGS(io) &= ~IOf_START;
2063 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2065 sv_setpvs(GvSV(gv), "-");
2067 GvSV(gv) = newSVpvs("-");
2068 SvSETMAGIC(GvSV(gv));
2070 else if (!nextargv(gv))
2075 PUSHs(boolSV(do_eof(gv)));
2086 PL_last_in_gv = MUTABLE_GV(POPs);
2089 if (gv && (io = GvIO(gv))) {
2090 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2093 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2096 call_method("TELL", G_SCALAR);
2103 #if LSEEKSIZE > IVSIZE
2104 PUSHn( do_tell(gv) );
2106 PUSHi( do_tell(gv) );
2114 const int whence = POPi;
2115 #if LSEEKSIZE > IVSIZE
2116 const Off_t offset = (Off_t)SvNVx(POPs);
2118 const Off_t offset = (Off_t)SvIVx(POPs);
2121 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2124 if (gv && (io = GvIO(gv))) {
2125 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2128 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2129 #if LSEEKSIZE > IVSIZE
2130 mXPUSHn((NV) offset);
2137 call_method("SEEK", G_SCALAR);
2144 if (PL_op->op_type == OP_SEEK)
2145 PUSHs(boolSV(do_seek(gv, offset, whence)));
2147 const Off_t sought = do_sysseek(gv, offset, whence);
2149 PUSHs(&PL_sv_undef);
2151 SV* const sv = sought ?
2152 #if LSEEKSIZE > IVSIZE
2157 : newSVpvn(zero_but_true, ZBTLEN);
2168 /* There seems to be no consensus on the length type of truncate()
2169 * and ftruncate(), both off_t and size_t have supporters. In
2170 * general one would think that when using large files, off_t is
2171 * at least as wide as size_t, so using an off_t should be okay. */
2172 /* XXX Configure probe for the length type of *truncate() needed XXX */
2175 #if Off_t_size > IVSIZE
2180 /* Checking for length < 0 is problematic as the type might or
2181 * might not be signed: if it is not, clever compilers will moan. */
2182 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2189 if (PL_op->op_flags & OPf_SPECIAL) {
2190 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2199 TAINT_PROPER("truncate");
2200 if (!(fp = IoIFP(io))) {
2206 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2208 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2215 SV * const sv = POPs;
2218 if (isGV_with_GP(sv)) {
2219 tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */
2220 goto do_ftruncate_gv;
2222 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2223 tmpgv = MUTABLE_GV(SvRV(sv)); /* \*main::FRED for example */
2224 goto do_ftruncate_gv;
2226 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2227 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2228 goto do_ftruncate_io;
2231 name = SvPV_nolen_const(sv);
2232 TAINT_PROPER("truncate");
2234 if (truncate(name, len) < 0)
2238 const int tmpfd = PerlLIO_open(name, O_RDWR);
2243 if (my_chsize(tmpfd, len) < 0)
2245 PerlLIO_close(tmpfd);
2254 SETERRNO(EBADF,RMS_IFI);
2262 SV * const argsv = POPs;
2263 const unsigned int func = POPu;
2264 const int optype = PL_op->op_type;
2265 GV * const gv = MUTABLE_GV(POPs);
2266 IO * const io = gv ? GvIOn(gv) : NULL;
2270 if (!io || !argsv || !IoIFP(io)) {
2271 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2272 report_evil_fh(gv, io, PL_op->op_type);
2273 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2277 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2280 s = SvPV_force(argsv, len);
2281 need = IOCPARM_LEN(func);
2283 s = Sv_Grow(argsv, need + 1);
2284 SvCUR_set(argsv, need);
2287 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2290 retval = SvIV(argsv);
2291 s = INT2PTR(char*,retval); /* ouch */
2294 TAINT_PROPER(PL_op_desc[optype]);
2296 if (optype == OP_IOCTL)
2298 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2300 DIE(aTHX_ "ioctl is not implemented");
2304 DIE(aTHX_ "fcntl is not implemented");
2306 #if defined(OS2) && defined(__EMX__)
2307 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2309 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2313 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2315 if (s[SvCUR(argsv)] != 17)
2316 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2318 s[SvCUR(argsv)] = 0; /* put our null back */
2319 SvSETMAGIC(argsv); /* Assume it has changed */
2328 PUSHp(zero_but_true, ZBTLEN);
2341 const int argtype = POPi;
2342 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
2344 if (gv && (io = GvIO(gv)))
2350 /* XXX Looks to me like io is always NULL at this point */
2352 (void)PerlIO_flush(fp);
2353 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2356 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2357 report_evil_fh(gv, io, PL_op->op_type);
2359 SETERRNO(EBADF,RMS_IFI);
2364 DIE(aTHX_ PL_no_func, "flock()");
2374 const int protocol = POPi;
2375 const int type = POPi;
2376 const int domain = POPi;
2377 GV * const gv = MUTABLE_GV(POPs);
2378 register IO * const io = gv ? GvIOn(gv) : NULL;
2382 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2383 report_evil_fh(gv, io, PL_op->op_type);
2384 if (io && IoIFP(io))
2385 do_close(gv, FALSE);
2386 SETERRNO(EBADF,LIB_INVARG);
2391 do_close(gv, FALSE);
2393 TAINT_PROPER("socket");
2394 fd = PerlSock_socket(domain, type, protocol);
2397 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2398 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2399 IoTYPE(io) = IoTYPE_SOCKET;
2400 if (!IoIFP(io) || !IoOFP(io)) {
2401 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2402 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2403 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2406 #if defined(HAS_FCNTL) && defined(F_SETFD)
2407 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2411 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2416 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");
2485 SV * const addrsv = POPs;
2486 /* OK, so on what platform does bind modify addr? */
2488 GV * const gv = MUTABLE_GV(POPs);
2489 register IO * const io = GvIOn(gv);
2492 if (!io || !IoIFP(io))
2495 addr = SvPV_const(addrsv, len);
2496 TAINT_PROPER("bind");
2497 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2503 if (ckWARN(WARN_CLOSED))
2504 report_evil_fh(gv, io, PL_op->op_type);
2505 SETERRNO(EBADF,SS_IVCHAN);
2508 DIE(aTHX_ PL_no_sock_func, "bind");
2516 SV * const addrsv = POPs;
2517 GV * const gv = MUTABLE_GV(POPs);
2518 register IO * const io = GvIOn(gv);
2522 if (!io || !IoIFP(io))
2525 addr = SvPV_const(addrsv, len);
2526 TAINT_PROPER("connect");
2527 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2533 if (ckWARN(WARN_CLOSED))
2534 report_evil_fh(gv, io, PL_op->op_type);
2535 SETERRNO(EBADF,SS_IVCHAN);
2538 DIE(aTHX_ PL_no_sock_func, "connect");
2546 const int backlog = POPi;
2547 GV * const gv = MUTABLE_GV(POPs);
2548 register IO * const io = gv ? GvIOn(gv) : NULL;
2550 if (!gv || !io || !IoIFP(io))
2553 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2559 if (ckWARN(WARN_CLOSED))
2560 report_evil_fh(gv, io, PL_op->op_type);
2561 SETERRNO(EBADF,SS_IVCHAN);
2564 DIE(aTHX_ PL_no_sock_func, "listen");
2574 char namebuf[MAXPATHLEN];
2575 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2576 Sock_size_t len = sizeof (struct sockaddr_in);
2578 Sock_size_t len = sizeof namebuf;
2580 GV * const ggv = MUTABLE_GV(POPs);
2581 GV * const ngv = MUTABLE_GV(POPs);
2590 if (!gstio || !IoIFP(gstio))
2594 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2597 /* Some platforms indicate zero length when an AF_UNIX client is
2598 * not bound. Simulate a non-zero-length sockaddr structure in
2600 namebuf[0] = 0; /* sun_len */
2601 namebuf[1] = AF_UNIX; /* sun_family */
2609 do_close(ngv, FALSE);
2610 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2611 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2612 IoTYPE(nstio) = IoTYPE_SOCKET;
2613 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2614 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2615 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2616 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2619 #if defined(HAS_FCNTL) && defined(F_SETFD)
2620 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2624 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2625 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2627 #ifdef __SCO_VERSION__
2628 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2631 PUSHp(namebuf, len);
2635 if (ckWARN(WARN_CLOSED))
2636 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2637 SETERRNO(EBADF,SS_IVCHAN);
2643 DIE(aTHX_ PL_no_sock_func, "accept");
2651 const int how = POPi;
2652 GV * const gv = MUTABLE_GV(POPs);
2653 register IO * const io = GvIOn(gv);
2655 if (!io || !IoIFP(io))
2658 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2662 if (ckWARN(WARN_CLOSED))
2663 report_evil_fh(gv, io, PL_op->op_type);
2664 SETERRNO(EBADF,SS_IVCHAN);
2667 DIE(aTHX_ PL_no_sock_func, "shutdown");
2675 const int optype = PL_op->op_type;
2676 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2677 const unsigned int optname = (unsigned int) POPi;
2678 const unsigned int lvl = (unsigned int) POPi;
2679 GV * const gv = MUTABLE_GV(POPs);
2680 register IO * const io = GvIOn(gv);
2684 if (!io || !IoIFP(io))
2687 fd = PerlIO_fileno(IoIFP(io));
2691 (void)SvPOK_only(sv);
2695 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2702 #if defined(__SYMBIAN32__)
2703 # define SETSOCKOPT_OPTION_VALUE_T void *
2705 # define SETSOCKOPT_OPTION_VALUE_T const char *
2707 /* XXX TODO: We need to have a proper type (a Configure probe,
2708 * etc.) for what the C headers think of the third argument of
2709 * setsockopt(), the option_value read-only buffer: is it
2710 * a "char *", or a "void *", const or not. Some compilers
2711 * don't take kindly to e.g. assuming that "char *" implicitly
2712 * promotes to a "void *", or to explicitly promoting/demoting
2713 * consts to non/vice versa. The "const void *" is the SUS
2714 * definition, but that does not fly everywhere for the above
2716 SETSOCKOPT_OPTION_VALUE_T buf;
2720 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2724 aint = (int)SvIV(sv);
2725 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2728 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2737 if (ckWARN(WARN_CLOSED))
2738 report_evil_fh(gv, io, optype);
2739 SETERRNO(EBADF,SS_IVCHAN);
2744 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2752 const int optype = PL_op->op_type;
2753 GV * const gv = MUTABLE_GV(POPs);
2754 register IO * const io = GvIOn(gv);
2759 if (!io || !IoIFP(io))
2762 sv = sv_2mortal(newSV(257));
2763 (void)SvPOK_only(sv);
2767 fd = PerlIO_fileno(IoIFP(io));
2769 case OP_GETSOCKNAME:
2770 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2773 case OP_GETPEERNAME:
2774 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2776 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2778 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";
2779 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2780 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2781 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2782 sizeof(u_short) + sizeof(struct in_addr))) {
2789 #ifdef BOGUS_GETNAME_RETURN
2790 /* Interactive Unix, getpeername() and getsockname()
2791 does not return valid namelen */
2792 if (len == BOGUS_GETNAME_RETURN)
2793 len = sizeof(struct sockaddr);
2801 if (ckWARN(WARN_CLOSED))
2802 report_evil_fh(gv, io, optype);
2803 SETERRNO(EBADF,SS_IVCHAN);
2808 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2823 if (PL_op->op_flags & OPf_REF) {
2825 if (PL_op->op_type == OP_LSTAT) {
2826 if (gv != PL_defgv) {
2827 do_fstat_warning_check:
2828 if (ckWARN(WARN_IO))
2829 Perl_warner(aTHX_ packWARN(WARN_IO),
2830 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2831 } else if (PL_laststype != OP_LSTAT)
2832 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2836 if (gv != PL_defgv) {
2837 PL_laststype = OP_STAT;
2839 sv_setpvs(PL_statname, "");
2846 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2847 } else if (IoDIRP(io)) {
2849 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2851 PL_laststatval = -1;
2857 if (PL_laststatval < 0) {
2858 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2859 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2864 SV* const sv = POPs;
2865 if (isGV_with_GP(sv)) {
2866 gv = MUTABLE_GV(sv);
2868 } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2869 gv = MUTABLE_GV(SvRV(sv));
2870 if (PL_op->op_type == OP_LSTAT)
2871 goto do_fstat_warning_check;
2873 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2874 io = MUTABLE_IO(SvRV(sv));
2875 if (PL_op->op_type == OP_LSTAT)
2876 goto do_fstat_warning_check;
2877 goto do_fstat_have_io;
2880 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2882 PL_laststype = PL_op->op_type;
2883 if (PL_op->op_type == OP_LSTAT)
2884 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2886 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2887 if (PL_laststatval < 0) {
2888 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2889 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2895 if (gimme != G_ARRAY) {
2896 if (gimme != G_VOID)
2897 XPUSHs(boolSV(max));
2903 mPUSHi(PL_statcache.st_dev);
2904 mPUSHi(PL_statcache.st_ino);
2905 mPUSHu(PL_statcache.st_mode);
2906 mPUSHu(PL_statcache.st_nlink);
2907 #if Uid_t_size > IVSIZE
2908 mPUSHn(PL_statcache.st_uid);
2910 # if Uid_t_sign <= 0
2911 mPUSHi(PL_statcache.st_uid);
2913 mPUSHu(PL_statcache.st_uid);
2916 #if Gid_t_size > IVSIZE
2917 mPUSHn(PL_statcache.st_gid);
2919 # if Gid_t_sign <= 0
2920 mPUSHi(PL_statcache.st_gid);
2922 mPUSHu(PL_statcache.st_gid);
2925 #ifdef USE_STAT_RDEV
2926 mPUSHi(PL_statcache.st_rdev);
2928 PUSHs(newSVpvs_flags("", SVs_TEMP));
2930 #if Off_t_size > IVSIZE
2931 mPUSHn(PL_statcache.st_size);
2933 mPUSHi(PL_statcache.st_size);
2936 mPUSHn(PL_statcache.st_atime);
2937 mPUSHn(PL_statcache.st_mtime);
2938 mPUSHn(PL_statcache.st_ctime);
2940 mPUSHi(PL_statcache.st_atime);
2941 mPUSHi(PL_statcache.st_mtime);
2942 mPUSHi(PL_statcache.st_ctime);
2944 #ifdef USE_STAT_BLOCKS
2945 mPUSHu(PL_statcache.st_blksize);
2946 mPUSHu(PL_statcache.st_blocks);
2948 PUSHs(newSVpvs_flags("", SVs_TEMP));
2949 PUSHs(newSVpvs_flags("", SVs_TEMP));
2955 /* This macro is used by the stacked filetest operators :
2956 * if the previous filetest failed, short-circuit and pass its value.
2957 * Else, discard it from the stack and continue. --rgs
2959 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2960 if (!SvTRUE(TOPs)) { RETURN; } \
2961 else { (void)POPs; PUTBACK; } \
2968 /* Not const, because things tweak this below. Not bool, because there's
2969 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2970 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2971 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2972 /* Giving some sort of initial value silences compilers. */
2974 int access_mode = R_OK;
2976 int access_mode = 0;
2979 /* access_mode is never used, but leaving use_access in makes the
2980 conditional compiling below much clearer. */
2983 int stat_mode = S_IRUSR;
2985 bool effective = FALSE;
2988 STACKED_FTEST_CHECK;
2990 switch (PL_op->op_type) {
2992 #if !(defined(HAS_ACCESS) && defined(R_OK))
2998 #if defined(HAS_ACCESS) && defined(W_OK)
3003 stat_mode = S_IWUSR;
3007 #if defined(HAS_ACCESS) && defined(X_OK)
3012 stat_mode = S_IXUSR;
3016 #ifdef PERL_EFF_ACCESS
3019 stat_mode = S_IWUSR;
3023 #ifndef PERL_EFF_ACCESS
3030 #ifdef PERL_EFF_ACCESS
3035 stat_mode = S_IXUSR;
3041 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3042 const char *name = POPpx;
3044 # ifdef PERL_EFF_ACCESS
3045 result = PERL_EFF_ACCESS(name, access_mode);
3047 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3053 result = access(name, access_mode);
3055 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3070 if (cando(stat_mode, effective, &PL_statcache))
3079 const int op_type = PL_op->op_type;
3081 STACKED_FTEST_CHECK;
3086 if (op_type == OP_FTIS)
3089 /* You can't dTARGET inside OP_FTIS, because you'll get
3090 "panic: pad_sv po" - the op is not flagged to have a target. */
3094 #if Off_t_size > IVSIZE
3095 PUSHn(PL_statcache.st_size);
3097 PUSHi(PL_statcache.st_size);
3101 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3104 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3107 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3120 /* I believe that all these three are likely to be defined on most every
3121 system these days. */
3123 if(PL_op->op_type == OP_FTSUID)
3127 if(PL_op->op_type == OP_FTSGID)
3131 if(PL_op->op_type == OP_FTSVTX)
3135 STACKED_FTEST_CHECK;
3140 switch (PL_op->op_type) {
3142 if (PL_statcache.st_uid == PL_uid)
3146 if (PL_statcache.st_uid == PL_euid)
3150 if (PL_statcache.st_size == 0)
3154 if (S_ISSOCK(PL_statcache.st_mode))
3158 if (S_ISCHR(PL_statcache.st_mode))
3162 if (S_ISBLK(PL_statcache.st_mode))
3166 if (S_ISREG(PL_statcache.st_mode))
3170 if (S_ISDIR(PL_statcache.st_mode))
3174 if (S_ISFIFO(PL_statcache.st_mode))
3179 if (PL_statcache.st_mode & S_ISUID)
3185 if (PL_statcache.st_mode & S_ISGID)
3191 if (PL_statcache.st_mode & S_ISVTX)
3202 I32 result = my_lstat();
3206 if (S_ISLNK(PL_statcache.st_mode))
3219 STACKED_FTEST_CHECK;
3221 if (PL_op->op_flags & OPf_REF)
3223 else if (isGV(TOPs))
3224 gv = MUTABLE_GV(POPs);
3225 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3226 gv = MUTABLE_GV(SvRV(POPs));
3228 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3230 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3231 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3232 else if (tmpsv && SvOK(tmpsv)) {
3233 const char *tmps = SvPV_nolen_const(tmpsv);
3241 if (PerlLIO_isatty(fd))
3246 #if defined(atarist) /* this will work with atariST. Configure will
3247 make guesses for other systems. */
3248 # define FILE_base(f) ((f)->_base)
3249 # define FILE_ptr(f) ((f)->_ptr)
3250 # define FILE_cnt(f) ((f)->_cnt)
3251 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3262 register STDCHAR *s;
3268 STACKED_FTEST_CHECK;
3270 if (PL_op->op_flags & OPf_REF)
3272 else if (isGV(TOPs))
3273 gv = MUTABLE_GV(POPs);
3274 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3275 gv = MUTABLE_GV(SvRV(POPs));
3281 if (gv == PL_defgv) {
3283 io = GvIO(PL_statgv);
3286 goto really_filename;
3291 PL_laststatval = -1;
3292 sv_setpvs(PL_statname, "");
3293 io = GvIO(PL_statgv);
3295 if (io && IoIFP(io)) {
3296 if (! PerlIO_has_base(IoIFP(io)))
3297 DIE(aTHX_ "-T and -B not implemented on filehandles");
3298 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3299 if (PL_laststatval < 0)
3301 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3302 if (PL_op->op_type == OP_FTTEXT)
3307 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3308 i = PerlIO_getc(IoIFP(io));
3310 (void)PerlIO_ungetc(IoIFP(io),i);
3312 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3314 len = PerlIO_get_bufsiz(IoIFP(io));
3315 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3316 /* sfio can have large buffers - limit to 512 */
3321 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3323 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3325 SETERRNO(EBADF,RMS_IFI);
3333 PL_laststype = OP_STAT;
3334 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3335 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3336 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3338 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3341 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3342 if (PL_laststatval < 0) {
3343 (void)PerlIO_close(fp);
3346 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3347 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3348 (void)PerlIO_close(fp);
3350 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3351 RETPUSHNO; /* special case NFS directories */
3352 RETPUSHYES; /* null file is anything */
3357 /* now scan s to look for textiness */
3358 /* XXX ASCII dependent code */
3360 #if defined(DOSISH) || defined(USEMYBINMODE)
3361 /* ignore trailing ^Z on short files */
3362 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3366 for (i = 0; i < len; i++, s++) {
3367 if (!*s) { /* null never allowed in text */
3372 else if (!(isPRINT(*s) || isSPACE(*s)))
3375 else if (*s & 128) {
3377 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3380 /* utf8 characters don't count as odd */
3381 if (UTF8_IS_START(*s)) {
3382 int ulen = UTF8SKIP(s);
3383 if (ulen < len - i) {
3385 for (j = 1; j < ulen; j++) {
3386 if (!UTF8_IS_CONTINUATION(s[j]))
3389 --ulen; /* loop does extra increment */
3399 *s != '\n' && *s != '\r' && *s != '\b' &&
3400 *s != '\t' && *s != '\f' && *s != 27)
3405 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3416 const char *tmps = NULL;
3420 SV * const sv = POPs;
3421 if (PL_op->op_flags & OPf_SPECIAL) {
3422 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3424 else if (isGV_with_GP(sv)) {
3425 gv = MUTABLE_GV(sv);
3427 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
3428 gv = MUTABLE_GV(SvRV(sv));
3431 tmps = SvPV_nolen_const(sv);
3435 if( !gv && (!tmps || !*tmps) ) {
3436 HV * const table = GvHVn(PL_envgv);
3439 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3440 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3442 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3447 deprecate("chdir('') or chdir(undef) as chdir()");
3448 tmps = SvPV_nolen_const(*svp);
3452 TAINT_PROPER("chdir");
3457 TAINT_PROPER("chdir");
3460 IO* const io = GvIO(gv);
3463 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3464 } else if (IoIFP(io)) {
3465 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3468 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3469 report_evil_fh(gv, io, PL_op->op_type);
3470 SETERRNO(EBADF, RMS_IFI);
3475 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3476 report_evil_fh(gv, io, PL_op->op_type);
3477 SETERRNO(EBADF,RMS_IFI);
3481 DIE(aTHX_ PL_no_func, "fchdir");
3485 PUSHi( PerlDir_chdir(tmps) >= 0 );
3487 /* Clear the DEFAULT element of ENV so we'll get the new value
3489 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3496 dVAR; dSP; dMARK; dTARGET;
3497 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3508 char * const tmps = POPpx;
3509 TAINT_PROPER("chroot");
3510 PUSHi( chroot(tmps) >= 0 );
3513 DIE(aTHX_ PL_no_func, "chroot");
3521 const char * const tmps2 = POPpconstx;
3522 const char * const tmps = SvPV_nolen_const(TOPs);
3523 TAINT_PROPER("rename");
3525 anum = PerlLIO_rename(tmps, tmps2);
3527 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3528 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3531 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3532 (void)UNLINK(tmps2);
3533 if (!(anum = link(tmps, tmps2)))
3534 anum = UNLINK(tmps);
3542 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3546 const int op_type = PL_op->op_type;
3550 if (op_type == OP_LINK)
3551 DIE(aTHX_ PL_no_func, "link");
3553 # ifndef HAS_SYMLINK
3554 if (op_type == OP_SYMLINK)
3555 DIE(aTHX_ PL_no_func, "symlink");
3559 const char * const tmps2 = POPpconstx;
3560 const char * const tmps = SvPV_nolen_const(TOPs);
3561 TAINT_PROPER(PL_op_desc[op_type]);
3563 # if defined(HAS_LINK)
3564 # if defined(HAS_SYMLINK)
3565 /* Both present - need to choose which. */
3566 (op_type == OP_LINK) ?
3567 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3569 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3570 PerlLIO_link(tmps, tmps2);
3573 # if defined(HAS_SYMLINK)
3574 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3575 symlink(tmps, tmps2);
3580 SETi( result >= 0 );
3587 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3598 char buf[MAXPATHLEN];
3601 #ifndef INCOMPLETE_TAINTS
3605 len = readlink(tmps, buf, sizeof(buf) - 1);
3613 RETSETUNDEF; /* just pretend it's a normal file */
3617 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3619 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3621 char * const save_filename = filename;
3626 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3628 PERL_ARGS_ASSERT_DOONELINER;
3630 Newx(cmdline, size, char);
3631 my_strlcpy(cmdline, cmd, size);
3632 my_strlcat(cmdline, " ", size);
3633 for (s = cmdline + strlen(cmdline); *filename; ) {
3637 if (s - cmdline < size)
3638 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3639 myfp = PerlProc_popen(cmdline, "r");
3643 SV * const tmpsv = sv_newmortal();
3644 /* Need to save/restore 'PL_rs' ?? */
3645 s = sv_gets(tmpsv, myfp, 0);
3646 (void)PerlProc_pclose(myfp);
3650 #ifdef HAS_SYS_ERRLIST
3655 /* you don't see this */
3656 const char * const errmsg =
3657 #ifdef HAS_SYS_ERRLIST
3665 if (instr(s, errmsg)) {
3672 #define EACCES EPERM
3674 if (instr(s, "cannot make"))
3675 SETERRNO(EEXIST,RMS_FEX);
3676 else if (instr(s, "existing file"))
3677 SETERRNO(EEXIST,RMS_FEX);
3678 else if (instr(s, "ile exists"))
3679 SETERRNO(EEXIST,RMS_FEX);
3680 else if (instr(s, "non-exist"))
3681 SETERRNO(ENOENT,RMS_FNF);
3682 else if (instr(s, "does not exist"))
3683 SETERRNO(ENOENT,RMS_FNF);
3684 else if (instr(s, "not empty"))
3685 SETERRNO(EBUSY,SS_DEVOFFLINE);
3686 else if (instr(s, "cannot access"))
3687 SETERRNO(EACCES,RMS_PRV);
3689 SETERRNO(EPERM,RMS_PRV);
3692 else { /* some mkdirs return no failure indication */
3693 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3694 if (PL_op->op_type == OP_RMDIR)
3699 SETERRNO(EACCES,RMS_PRV); /* a guess */
3708 /* This macro removes trailing slashes from a directory name.
3709 * Different operating and file systems take differently to
3710 * trailing slashes. According to POSIX 1003.1 1996 Edition
3711 * any number of trailing slashes should be allowed.
3712 * Thusly we snip them away so that even non-conforming
3713 * systems are happy.
3714 * We should probably do this "filtering" for all
3715 * the functions that expect (potentially) directory names:
3716 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3717 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3719 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3720 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3723 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3724 (tmps) = savepvn((tmps), (len)); \
3734 const int mode = (MAXARG > 1) ? POPi : 0777;
3736 TRIMSLASHES(tmps,len,copy);
3738 TAINT_PROPER("mkdir");
3740 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3744 SETi( dooneliner("mkdir", tmps) );
3745 oldumask = PerlLIO_umask(0);
3746 PerlLIO_umask(oldumask);
3747 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3762 TRIMSLASHES(tmps,len,copy);
3763 TAINT_PROPER("rmdir");
3765 SETi( PerlDir_rmdir(tmps) >= 0 );
3767 SETi( dooneliner("rmdir", tmps) );
3774 /* Directory calls. */
3778 #if defined(Direntry_t) && defined(HAS_READDIR)
3780 const char * const dirname = POPpconstx;
3781 GV * const gv = MUTABLE_GV(POPs);
3782 register IO * const io = GvIOn(gv);
3787 if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED))
3788 Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3789 "Opening filehandle %s also as a directory", GvENAME(gv));
3791 PerlDir_close(IoDIRP(io));
3792 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3798 SETERRNO(EBADF,RMS_DIR);
3801 DIE(aTHX_ PL_no_dir_func, "opendir");
3807 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3808 DIE(aTHX_ PL_no_dir_func, "readdir");
3810 #if !defined(I_DIRENT) && !defined(VMS)
3811 Direntry_t *readdir (DIR *);
3817 const I32 gimme = GIMME;
3818 GV * const gv = MUTABLE_GV(POPs);
3819 register const Direntry_t *dp;
3820 register IO * const io = GvIOn(gv);
3822 if (!io || !IoDIRP(io)) {
3823 if(ckWARN(WARN_IO)) {
3824 Perl_warner(aTHX_ packWARN(WARN_IO),
3825 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3831 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3835 sv = newSVpvn(dp->d_name, dp->d_namlen);
3837 sv = newSVpv(dp->d_name, 0);
3839 #ifndef INCOMPLETE_TAINTS
3840 if (!(IoFLAGS(io) & IOf_UNTAINT))
3844 } while (gimme == G_ARRAY);
3846 if (!dp && gimme != G_ARRAY)
3853 SETERRNO(EBADF,RMS_ISI);
3854 if (GIMME == G_ARRAY)
3863 #if defined(HAS_TELLDIR) || defined(telldir)
3865 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3866 /* XXX netbsd still seemed to.
3867 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3868 --JHI 1999-Feb-02 */
3869 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3870 long telldir (DIR *);
3872 GV * const gv = MUTABLE_GV(POPs);
3873 register IO * const io = GvIOn(gv);
3875 if (!io || !IoDIRP(io)) {
3876 if(ckWARN(WARN_IO)) {
3877 Perl_warner(aTHX_ packWARN(WARN_IO),
3878 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3883 PUSHi( PerlDir_tell(IoDIRP(io)) );
3887 SETERRNO(EBADF,RMS_ISI);
3890 DIE(aTHX_ PL_no_dir_func, "telldir");
3896 #if defined(HAS_SEEKDIR) || defined(seekdir)
3898 const long along = POPl;
3899 GV * const gv = MUTABLE_GV(POPs);
3900 register IO * const io = GvIOn(gv);
3902 if (!io || !IoDIRP(io)) {
3903 if(ckWARN(WARN_IO)) {
3904 Perl_warner(aTHX_ packWARN(WARN_IO),
3905 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3909 (void)PerlDir_seek(IoDIRP(io), along);
3914 SETERRNO(EBADF,RMS_ISI);
3917 DIE(aTHX_ PL_no_dir_func, "seekdir");
3923 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3925 GV * const gv = MUTABLE_GV(POPs);
3926 register IO * const io = GvIOn(gv);
3928 if (!io || !IoDIRP(io)) {
3929 if(ckWARN(WARN_IO)) {
3930 Perl_warner(aTHX_ packWARN(WARN_IO),
3931 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3935 (void)PerlDir_rewind(IoDIRP(io));
3939 SETERRNO(EBADF,RMS_ISI);
3942 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3948 #if defined(Direntry_t) && defined(HAS_READDIR)
3950 GV * const gv = MUTABLE_GV(POPs);
3951 register IO * const io = GvIOn(gv);
3953 if (!io || !IoDIRP(io)) {
3954 if(ckWARN(WARN_IO)) {
3955 Perl_warner(aTHX_ packWARN(WARN_IO),
3956 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3960 #ifdef VOID_CLOSEDIR
3961 PerlDir_close(IoDIRP(io));
3963 if (PerlDir_close(IoDIRP(io)) < 0) {
3964 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3973 SETERRNO(EBADF,RMS_IFI);
3976 DIE(aTHX_ PL_no_dir_func, "closedir");
3980 /* Process control. */
3989 PERL_FLUSHALL_FOR_CHILD;
3990 childpid = PerlProc_fork();
3994 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3996 SvREADONLY_off(GvSV(tmpgv));
3997 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3998 SvREADONLY_on(GvSV(tmpgv));
4000 #ifdef THREADS_HAVE_PIDS
4001 PL_ppid = (IV)getppid();
4003 #ifdef PERL_USES_PL_PIDSTATUS
4004 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4010 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4015 PERL_FLUSHALL_FOR_CHILD;
4016 childpid = PerlProc_fork();
4022 DIE(aTHX_ PL_no_func, "fork");
4029 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4034 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4035 childpid = wait4pid(-1, &argflags, 0);
4037 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4042 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4043 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4044 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4046 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4051 DIE(aTHX_ PL_no_func, "wait");
4057 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4059 const int optype = POPi;
4060 const Pid_t pid = TOPi;
4064 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4065 result = wait4pid(pid, &argflags, optype);
4067 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4072 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4073 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4074 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4076 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4081 DIE(aTHX_ PL_no_func, "waitpid");
4087 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4088 #if defined(__LIBCATAMOUNT__)
4089 PL_statusvalue = -1;
4098 while (++MARK <= SP) {
4099 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4104 TAINT_PROPER("system");
4106 PERL_FLUSHALL_FOR_CHILD;
4107 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4113 if (PerlProc_pipe(pp) >= 0)
4115 while ((childpid = PerlProc_fork()) == -1) {
4116 if (errno != EAGAIN) {
4121 PerlLIO_close(pp[0]);
4122 PerlLIO_close(pp[1]);
4129 Sigsave_t ihand,qhand; /* place to save signals during system() */
4133 PerlLIO_close(pp[1]);
4135 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4136 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4139 result = wait4pid(childpid, &status, 0);
4140 } while (result == -1 && errno == EINTR);
4142 (void)rsignal_restore(SIGINT, &ihand);
4143 (void)rsignal_restore(SIGQUIT, &qhand);
4145 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4146 do_execfree(); /* free any memory child malloced on fork */
4153 while (n < sizeof(int)) {
4154 n1 = PerlLIO_read(pp[0],
4155 (void*)(((char*)&errkid)+n),
4161 PerlLIO_close(pp[0]);
4162 if (n) { /* Error */
4163 if (n != sizeof(int))
4164 DIE(aTHX_ "panic: kid popen errno read");
4165 errno = errkid; /* Propagate errno from kid */
4166 STATUS_NATIVE_CHILD_SET(-1);
4169 XPUSHi(STATUS_CURRENT);
4173 PerlLIO_close(pp[0]);
4174 #if defined(HAS_FCNTL) && defined(F_SETFD)
4175 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4178 if (PL_op->op_flags & OPf_STACKED) {
4179 SV * const really = *++MARK;
4180 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4182 else if (SP - MARK != 1)
4183 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4185 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4189 #else /* ! FORK or VMS or OS/2 */
4192 if (PL_op->op_flags & OPf_STACKED) {
4193 SV * const really = *++MARK;
4194 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4195 value = (I32)do_aspawn(really, MARK, SP);
4197 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4200 else if (SP - MARK != 1) {
4201 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4202 value = (I32)do_aspawn(NULL, MARK, SP);
4204 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4208 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4210 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4212 STATUS_NATIVE_CHILD_SET(value);
4215 XPUSHi(result ? value : STATUS_CURRENT);
4216 #endif /* !FORK or VMS or OS/2 */
4223 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4228 while (++MARK <= SP) {
4229 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4234 TAINT_PROPER("exec");
4236 PERL_FLUSHALL_FOR_CHILD;
4237 if (PL_op->op_flags & OPf_STACKED) {
4238 SV * const really = *++MARK;
4239 value = (I32)do_aexec(really, MARK, SP);
4241 else if (SP - MARK != 1)
4243 value = (I32)vms_do_aexec(NULL, MARK, SP);
4247 (void ) do_aspawn(NULL, MARK, SP);
4251 value = (I32)do_aexec(NULL, MARK, SP);
4256 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4259 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4262 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4276 # ifdef THREADS_HAVE_PIDS
4277 if (PL_ppid != 1 && getppid() == 1)
4278 /* maybe the parent process has died. Refresh ppid cache */
4282 XPUSHi( getppid() );
4286 DIE(aTHX_ PL_no_func, "getppid");
4295 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4298 pgrp = (I32)BSD_GETPGRP(pid);
4300 if (pid != 0 && pid != PerlProc_getpid())
4301 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4307 DIE(aTHX_ PL_no_func, "getpgrp()");
4327 TAINT_PROPER("setpgrp");
4329 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4331 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4332 || (pid != 0 && pid != PerlProc_getpid()))
4334 DIE(aTHX_ "setpgrp can't take arguments");
4336 SETi( setpgrp() >= 0 );
4337 #endif /* USE_BSDPGRP */
4340 DIE(aTHX_ PL_no_func, "setpgrp()");
4346 #ifdef HAS_GETPRIORITY
4348 const int who = POPi;
4349 const int which = TOPi;
4350 SETi( getpriority(which, who) );
4353 DIE(aTHX_ PL_no_func, "getpriority()");
4359 #ifdef HAS_SETPRIORITY
4361 const int niceval = POPi;
4362 const int who = POPi;
4363 const int which = TOPi;
4364 TAINT_PROPER("setpriority");
4365 SETi( setpriority(which, who, niceval) >= 0 );
4368 DIE(aTHX_ PL_no_func, "setpriority()");
4378 XPUSHn( time(NULL) );
4380 XPUSHi( time(NULL) );
4392 (void)PerlProc_times(&PL_timesbuf);
4394 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4395 /* struct tms, though same data */
4399 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4400 if (GIMME == G_ARRAY) {
4401 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4402 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4403 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4411 if (GIMME == G_ARRAY) {
4418 DIE(aTHX_ "times not implemented");
4420 #endif /* HAS_TIMES */
4429 const struct tm *err;
4436 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4437 static const char * const dayname[] =
4438 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4439 static const char * const monname[] =
4440 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4441 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4447 when = (Time_t)SvIVx(POPs);
4449 if (PL_op->op_type == OP_LOCALTIME)
4450 err = localtime(&when);
4452 err = gmtime(&when);
4460 when = (Time64_T)now;
4463 /* XXX POPq uses an SvIV so it won't work with 32 bit integer scalars
4464 using a double causes an unfortunate loss of accuracy on high numbers.
4465 What we really need is an SvQV.
4467 double input = POPn;
4468 when = (Time64_T)input;
4469 if( when != input ) {
4470 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4471 "%s(%.0f) too large", opname, input);
4475 if (PL_op->op_type == OP_LOCALTIME)
4476 err = localtime64_r(&when, &tmbuf);
4478 err = gmtime64_r(&when, &tmbuf);
4482 /* XXX %lld broken for quads */
4483 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
4484 "%s(%.0f) failed", opname, (double)when);
4487 if (GIMME != G_ARRAY) { /* scalar context */
4489 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4490 double year = (double)tmbuf.tm_year + 1900;
4497 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4498 dayname[tmbuf.tm_wday],
4499 monname[tmbuf.tm_mon],
4507 else { /* list context */
4513 mPUSHi(tmbuf.tm_sec);
4514 mPUSHi(tmbuf.tm_min);
4515 mPUSHi(tmbuf.tm_hour);
4516 mPUSHi(tmbuf.tm_mday);
4517 mPUSHi(tmbuf.tm_mon);
4518 mPUSHn(tmbuf.tm_year);
4519 mPUSHi(tmbuf.tm_wday);
4520 mPUSHi(tmbuf.tm_yday);
4521 mPUSHi(tmbuf.tm_isdst);
4532 anum = alarm((unsigned int)anum);
4539 DIE(aTHX_ PL_no_func, "alarm");
4550 (void)time(&lasttime);
4555 PerlProc_sleep((unsigned int)duration);
4558 XPUSHi(when - lasttime);
4562 /* Shared memory. */
4563 /* Merged with some message passing. */
4567 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4568 dVAR; dSP; dMARK; dTARGET;
4569 const int op_type = PL_op->op_type;
4574 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4577 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4580 value = (I32)(do_semop(MARK, SP) >= 0);
4583 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4599 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4600 dVAR; dSP; dMARK; dTARGET;
4601 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4608 DIE(aTHX_ "System V IPC is not implemented on this machine");
4614 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4615 dVAR; dSP; dMARK; dTARGET;
4616 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4624 PUSHp(zero_but_true, ZBTLEN);
4632 /* I can't const this further without getting warnings about the types of
4633 various arrays passed in from structures. */
4635 S_space_join_names_mortal(pTHX_ char *const *array)
4639 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4641 if (array && *array) {
4642 target = newSVpvs_flags("", SVs_TEMP);
4644 sv_catpv(target, *array);
4647 sv_catpvs(target, " ");
4650 target = sv_mortalcopy(&PL_sv_no);
4655 /* Get system info. */
4659 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4661 I32 which = PL_op->op_type;
4662 register char **elem;
4664 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4665 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4666 struct hostent *gethostbyname(Netdb_name_t);
4667 struct hostent *gethostent(void);
4669 struct hostent *hent;
4673 if (which == OP_GHBYNAME) {
4674 #ifdef HAS_GETHOSTBYNAME
4675 const char* const name = POPpbytex;
4676 hent = PerlSock_gethostbyname(name);
4678 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4681 else if (which == OP_GHBYADDR) {
4682 #ifdef HAS_GETHOSTBYADDR
4683 const int addrtype = POPi;
4684 SV * const addrsv = POPs;
4686 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4688 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4690 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4694 #ifdef HAS_GETHOSTENT
4695 hent = PerlSock_gethostent();
4697 DIE(aTHX_ PL_no_sock_func, "gethostent");
4700 #ifdef HOST_NOT_FOUND
4702 #ifdef USE_REENTRANT_API
4703 # ifdef USE_GETHOSTENT_ERRNO
4704 h_errno = PL_reentrant_buffer->_gethostent_errno;
4707 STATUS_UNIX_SET(h_errno);
4711 if (GIMME != G_ARRAY) {
4712 PUSHs(sv = sv_newmortal());
4714 if (which == OP_GHBYNAME) {
4716 sv_setpvn(sv, hent->h_addr, hent->h_length);
4719 sv_setpv(sv, (char*)hent->h_name);
4725 mPUSHs(newSVpv((char*)hent->h_name, 0));
4726 PUSHs(space_join_names_mortal(hent->h_aliases));
4727 mPUSHi(hent->h_addrtype);
4728 len = hent->h_length;
4731 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4732 mXPUSHp(*elem, len);
4736 mPUSHp(hent->h_addr, len);
4738 PUSHs(sv_mortalcopy(&PL_sv_no));
4743 DIE(aTHX_ PL_no_sock_func, "gethostent");
4749 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4751 I32 which = PL_op->op_type;
4753 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4754 struct netent *getnetbyaddr(Netdb_net_t, int);
4755 struct netent *getnetbyname(Netdb_name_t);
4756 struct netent *getnetent(void);
4758 struct netent *nent;
4760 if (which == OP_GNBYNAME){
4761 #ifdef HAS_GETNETBYNAME
4762 const char * const name = POPpbytex;
4763 nent = PerlSock_getnetbyname(name);
4765 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4768 else if (which == OP_GNBYADDR) {
4769 #ifdef HAS_GETNETBYADDR
4770 const int addrtype = POPi;
4771 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4772 nent = PerlSock_getnetbyaddr(addr, addrtype);
4774 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4778 #ifdef HAS_GETNETENT
4779 nent = PerlSock_getnetent();
4781 DIE(aTHX_ PL_no_sock_func, "getnetent");
4784 #ifdef HOST_NOT_FOUND
4786 #ifdef USE_REENTRANT_API
4787 # ifdef USE_GETNETENT_ERRNO
4788 h_errno = PL_reentrant_buffer->_getnetent_errno;
4791 STATUS_UNIX_SET(h_errno);
4796 if (GIMME != G_ARRAY) {
4797 PUSHs(sv = sv_newmortal());
4799 if (which == OP_GNBYNAME)
4800 sv_setiv(sv, (IV)nent->n_net);
4802 sv_setpv(sv, nent->n_name);
4808 mPUSHs(newSVpv(nent->n_name, 0));
4809 PUSHs(space_join_names_mortal(nent->n_aliases));
4810 mPUSHi(nent->n_addrtype);
4811 mPUSHi(nent->n_net);
4816 DIE(aTHX_ PL_no_sock_func, "getnetent");
4822 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4824 I32 which = PL_op->op_type;
4826 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4827 struct protoent *getprotobyname(Netdb_name_t);
4828 struct protoent *getprotobynumber(int);
4829 struct protoent *getprotoent(void);
4831 struct protoent *pent;
4833 if (which == OP_GPBYNAME) {
4834 #ifdef HAS_GETPROTOBYNAME
4835 const char* const name = POPpbytex;
4836 pent = PerlSock_getprotobyname(name);
4838 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4841 else if (which == OP_GPBYNUMBER) {
4842 #ifdef HAS_GETPROTOBYNUMBER
4843 const int number = POPi;
4844 pent = PerlSock_getprotobynumber(number);
4846 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4850 #ifdef HAS_GETPROTOENT
4851 pent = PerlSock_getprotoent();
4853 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4857 if (GIMME != G_ARRAY) {
4858 PUSHs(sv = sv_newmortal());
4860 if (which == OP_GPBYNAME)
4861 sv_setiv(sv, (IV)pent->p_proto);
4863 sv_setpv(sv, pent->p_name);
4869 mPUSHs(newSVpv(pent->p_name, 0));
4870 PUSHs(space_join_names_mortal(pent->p_aliases));
4871 mPUSHi(pent->p_proto);
4876 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4882 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4884 I32 which = PL_op->op_type;
4886 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4887 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4888 struct servent *getservbyport(int, Netdb_name_t);
4889 struct servent *getservent(void);
4891 struct servent *sent;
4893 if (which == OP_GSBYNAME) {
4894 #ifdef HAS_GETSERVBYNAME
4895 const char * const proto = POPpbytex;
4896 const char * const name = POPpbytex;
4897 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4899 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4902 else if (which == OP_GSBYPORT) {
4903 #ifdef HAS_GETSERVBYPORT
4904 const char * const proto = POPpbytex;
4905 unsigned short port = (unsigned short)POPu;
4907 port = PerlSock_htons(port);
4909 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4911 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4915 #ifdef HAS_GETSERVENT
4916 sent = PerlSock_getservent();
4918 DIE(aTHX_ PL_no_sock_func, "getservent");
4922 if (GIMME != G_ARRAY) {
4923 PUSHs(sv = sv_newmortal());
4925 if (which == OP_GSBYNAME) {
4927 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4929 sv_setiv(sv, (IV)(sent->s_port));
4933 sv_setpv(sv, sent->s_name);
4939 mPUSHs(newSVpv(sent->s_name, 0));
4940 PUSHs(space_join_names_mortal(sent->s_aliases));
4942 mPUSHi(PerlSock_ntohs(sent->s_port));
4944 mPUSHi(sent->s_port);
4946 mPUSHs(newSVpv(sent->s_proto, 0));
4951 DIE(aTHX_ PL_no_sock_func, "getservent");
4957 #ifdef HAS_SETHOSTENT
4959 PerlSock_sethostent(TOPi);
4962 DIE(aTHX_ PL_no_sock_func, "sethostent");
4968 #ifdef HAS_SETNETENT
4970 (void)PerlSock_setnetent(TOPi);
4973 DIE(aTHX_ PL_no_sock_func, "setnetent");
4979 #ifdef HAS_SETPROTOENT
4981 (void)PerlSock_setprotoent(TOPi);
4984 DIE(aTHX_ PL_no_sock_func, "setprotoent");
4990 #ifdef HAS_SETSERVENT
4992 (void)PerlSock_setservent(TOPi);
4995 DIE(aTHX_ PL_no_sock_func, "setservent");
5001 #ifdef HAS_ENDHOSTENT
5003 PerlSock_endhostent();
5007 DIE(aTHX_ PL_no_sock_func, "endhostent");
5013 #ifdef HAS_ENDNETENT
5015 PerlSock_endnetent();
5019 DIE(aTHX_ PL_no_sock_func, "endnetent");
5025 #ifdef HAS_ENDPROTOENT
5027 PerlSock_endprotoent();
5031 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5037 #ifdef HAS_ENDSERVENT
5039 PerlSock_endservent();
5043 DIE(aTHX_ PL_no_sock_func, "endservent");
5051 I32 which = PL_op->op_type;
5053 struct passwd *pwent = NULL;
5055 * We currently support only the SysV getsp* shadow password interface.
5056 * The interface is declared in <shadow.h> and often one needs to link
5057 * with -lsecurity or some such.
5058 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5061 * AIX getpwnam() is clever enough to return the encrypted password
5062 * only if the caller (euid?) is root.
5064 * There are at least three other shadow password APIs. Many platforms
5065 * seem to contain more than one interface for accessing the shadow
5066 * password databases, possibly for compatibility reasons.
5067 * The getsp*() is by far he simplest one, the other two interfaces
5068 * are much more complicated, but also very similar to each other.
5073 * struct pr_passwd *getprpw*();
5074 * The password is in
5075 * char getprpw*(...).ufld.fd_encrypt[]
5076 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5081 * struct es_passwd *getespw*();
5082 * The password is in
5083 * char *(getespw*(...).ufld.fd_encrypt)
5084 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5087 * struct userpw *getuserpw();
5088 * The password is in
5089 * char *(getuserpw(...)).spw_upw_passwd
5090 * (but the de facto standard getpwnam() should work okay)
5092 * Mention I_PROT here so that Configure probes for it.
5094 * In HP-UX for getprpw*() the manual page claims that one should include
5095 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5096 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5097 * and pp_sys.c already includes <shadow.h> if there is such.
5099 * Note that <sys/security.h> is already probed for, but currently
5100 * it is only included in special cases.
5102 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5103 * be preferred interface, even though also the getprpw*() interface
5104 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5105 * One also needs to call set_auth_parameters() in main() before
5106 * doing anything else, whether one is using getespw*() or getprpw*().
5108 * Note that accessing the shadow databases can be magnitudes
5109 * slower than accessing the standard databases.
5114 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5115 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5116 * the pw_comment is left uninitialized. */
5117 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5123 const char* const name = POPpbytex;
5124 pwent = getpwnam(name);
5130 pwent = getpwuid(uid);
5134 # ifdef HAS_GETPWENT
5136 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5137 if (pwent) pwent = getpwnam(pwent->pw_name);
5140 DIE(aTHX_ PL_no_func, "getpwent");
5146 if (GIMME != G_ARRAY) {
5147 PUSHs(sv = sv_newmortal());
5149 if (which == OP_GPWNAM)
5150 # if Uid_t_sign <= 0
5151 sv_setiv(sv, (IV)pwent->pw_uid);
5153 sv_setuv(sv, (UV)pwent->pw_uid);
5156 sv_setpv(sv, pwent->pw_name);
5162 mPUSHs(newSVpv(pwent->pw_name, 0));
5166 /* If we have getspnam(), we try to dig up the shadow
5167 * password. If we are underprivileged, the shadow
5168 * interface will set the errno to EACCES or similar,
5169 * and return a null pointer. If this happens, we will
5170 * use the dummy password (usually "*" or "x") from the
5171 * standard password database.
5173 * In theory we could skip the shadow call completely
5174 * if euid != 0 but in practice we cannot know which
5175 * security measures are guarding the shadow databases
5176 * on a random platform.
5178 * Resist the urge to use additional shadow interfaces.
5179 * Divert the urge to writing an extension instead.
5182 /* Some AIX setups falsely(?) detect some getspnam(), which
5183 * has a different API than the Solaris/IRIX one. */
5184 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5187 const struct spwd * const spwent = getspnam(pwent->pw_name);
5188 /* Save and restore errno so that
5189 * underprivileged attempts seem
5190 * to have never made the unsccessful
5191 * attempt to retrieve the shadow password. */
5193 if (spwent && spwent->sp_pwdp)
5194 sv_setpv(sv, spwent->sp_pwdp);
5198 if (!SvPOK(sv)) /* Use the standard password, then. */
5199 sv_setpv(sv, pwent->pw_passwd);
5202 # ifndef INCOMPLETE_TAINTS
5203 /* passwd is tainted because user himself can diddle with it.
5204 * admittedly not much and in a very limited way, but nevertheless. */
5208 # if Uid_t_sign <= 0
5209 mPUSHi(pwent->pw_uid);
5211 mPUSHu(pwent->pw_uid);
5214 # if Uid_t_sign <= 0
5215 mPUSHi(pwent->pw_gid);
5217 mPUSHu(pwent->pw_gid);
5219 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5220 * because of the poor interface of the Perl getpw*(),
5221 * not because there's some standard/convention saying so.
5222 * A better interface would have been to return a hash,
5223 * but we are accursed by our history, alas. --jhi. */
5225 mPUSHi(pwent->pw_change);
5228 mPUSHi(pwent->pw_quota);
5231 mPUSHs(newSVpv(pwent->pw_age, 0));
5233 /* I think that you can never get this compiled, but just in case. */
5234 PUSHs(sv_mortalcopy(&PL_sv_no));
5239 /* pw_class and pw_comment are mutually exclusive--.
5240 * see the above note for pw_change, pw_quota, and pw_age. */
5242 mPUSHs(newSVpv(pwent->pw_class, 0));
5245 mPUSHs(newSVpv(pwent->pw_comment, 0));
5247 /* I think that you can never get this compiled, but just in case. */
5248 PUSHs(sv_mortalcopy(&PL_sv_no));
5253 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5255 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5257 # ifndef INCOMPLETE_TAINTS
5258 /* pw_gecos is tainted because user himself can diddle with it. */
5262 mPUSHs(newSVpv(pwent->pw_dir, 0));
5264 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5265 # ifndef INCOMPLETE_TAINTS
5266 /* pw_shell is tainted because user himself can diddle with it. */
5271 mPUSHi(pwent->pw_expire);
5276 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5282 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5287 DIE(aTHX_ PL_no_func, "setpwent");
5293 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5298 DIE(aTHX_ PL_no_func, "endpwent");
5306 const I32 which = PL_op->op_type;
5307 const struct group *grent;
5309 if (which == OP_GGRNAM) {
5310 const char* const name = POPpbytex;
5311 grent = (const struct group *)getgrnam(name);
5313 else if (which == OP_GGRGID) {
5314 const Gid_t gid = POPi;
5315 grent = (const struct group *)getgrgid(gid);
5319 grent = (struct group *)getgrent();
5321 DIE(aTHX_ PL_no_func, "getgrent");
5325 if (GIMME != G_ARRAY) {
5326 SV * const sv = sv_newmortal();
5330 if (which == OP_GGRNAM)
5331 sv_setiv(sv, (IV)grent->gr_gid);
5333 sv_setpv(sv, grent->gr_name);
5339 mPUSHs(newSVpv(grent->gr_name, 0));
5342 mPUSHs(newSVpv(grent->gr_passwd, 0));
5344 PUSHs(sv_mortalcopy(&PL_sv_no));
5347 mPUSHi(grent->gr_gid);
5349 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5350 /* In UNICOS/mk (_CRAYMPP) the multithreading
5351 * versions (getgrnam_r, getgrgid_r)
5352 * seem to return an illegal pointer
5353 * as the group members list, gr_mem.
5354 * getgrent() doesn't even have a _r version
5355 * but the gr_mem is poisonous anyway.
5356 * So yes, you cannot get the list of group
5357 * members if building multithreaded in UNICOS/mk. */
5358 PUSHs(space_join_names_mortal(grent->gr_mem));
5364 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5370 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5375 DIE(aTHX_ PL_no_func, "setgrent");
5381 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5386 DIE(aTHX_ PL_no_func, "endgrent");
5396 if (!(tmps = PerlProc_getlogin()))
5398 PUSHp(tmps, strlen(tmps));
5401 DIE(aTHX_ PL_no_func, "getlogin");
5405 /* Miscellaneous. */
5410 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5411 register I32 items = SP - MARK;
5412 unsigned long a[20];
5417 while (++MARK <= SP) {
5418 if (SvTAINTED(*MARK)) {
5424 TAINT_PROPER("syscall");
5427 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5428 * or where sizeof(long) != sizeof(char*). But such machines will
5429 * not likely have syscall implemented either, so who cares?
5431 while (++MARK <= SP) {
5432 if (SvNIOK(*MARK) || !i)
5433 a[i++] = SvIV(*MARK);
5434 else if (*MARK == &PL_sv_undef)
5437 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5443 DIE(aTHX_ "Too many args to syscall");
5445 DIE(aTHX_ "Too few args to syscall");
5447 retval = syscall(a[0]);
5450 retval = syscall(a[0],a[1]);
5453 retval = syscall(a[0],a[1],a[2]);
5456 retval = syscall(a[0],a[1],a[2],a[3]);
5459 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5462 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5465 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5468 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5472 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5475 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5478 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5482 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5486 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5490 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5491 a[10],a[11],a[12],a[13]);
5493 #endif /* atarist */
5499 DIE(aTHX_ PL_no_func, "syscall");
5503 #ifdef FCNTL_EMULATE_FLOCK
5505 /* XXX Emulate flock() with fcntl().
5506 What's really needed is a good file locking module.
5510 fcntl_emulate_flock(int fd, int operation)
5514 switch (operation & ~LOCK_NB) {
5516 flock.l_type = F_RDLCK;
5519 flock.l_type = F_WRLCK;
5522 flock.l_type = F_UNLCK;
5528 flock.l_whence = SEEK_SET;
5529 flock.l_start = flock.l_len = (Off_t)0;
5531 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5534 #endif /* FCNTL_EMULATE_FLOCK */
5536 #ifdef LOCKF_EMULATE_FLOCK
5538 /* XXX Emulate flock() with lockf(). This is just to increase
5539 portability of scripts. The calls are not completely
5540 interchangeable. What's really needed is a good file
5544 /* The lockf() constants might have been defined in <unistd.h>.
5545 Unfortunately, <unistd.h> causes troubles on some mixed
5546 (BSD/POSIX) systems, such as SunOS 4.1.3.
5548 Further, the lockf() constants aren't POSIX, so they might not be
5549 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5550 just stick in the SVID values and be done with it. Sigh.
5554 # define F_ULOCK 0 /* Unlock a previously locked region */
5557 # define F_LOCK 1 /* Lock a region for exclusive use */
5560 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5563 # define F_TEST 3 /* Test a region for other processes locks */
5567 lockf_emulate_flock(int fd, int operation)
5573 /* flock locks entire file so for lockf we need to do the same */
5574 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5575 if (pos > 0) /* is seekable and needs to be repositioned */
5576 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5577 pos = -1; /* seek failed, so don't seek back afterwards */
5580 switch (operation) {
5582 /* LOCK_SH - get a shared lock */
5584 /* LOCK_EX - get an exclusive lock */
5586 i = lockf (fd, F_LOCK, 0);
5589 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5590 case LOCK_SH|LOCK_NB:
5591 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5592 case LOCK_EX|LOCK_NB:
5593 i = lockf (fd, F_TLOCK, 0);
5595 if ((errno == EAGAIN) || (errno == EACCES))
5596 errno = EWOULDBLOCK;
5599 /* LOCK_UN - unlock (non-blocking is a no-op) */
5601 case LOCK_UN|LOCK_NB:
5602 i = lockf (fd, F_ULOCK, 0);
5605 /* Default - can't decipher operation */
5612 if (pos > 0) /* need to restore position of the handle */
5613 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5618 #endif /* LOCKF_EMULATE_FLOCK */
5622 * c-indentation-style: bsd
5624 * indent-tabs-mode: t
5627 * ex: set ts=8 sts=4 sw=4 noet: