3 * Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 * 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * But only a short way ahead its floor and the walls on either side were
13 * cloven by a great fissure, out of which the red glare came, now leaping
14 * up, now dying down into darkness; and all the while far below there was
15 * a rumour and a trouble as of great engines throbbing and labouring.
17 * [p.945 of _The Lord of the Rings_, VI/iii: "Mount Doom"]
20 /* This file contains system pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
26 * By 'system', we mean ops which interact with the OS, such as pp_open().
30 #define PERL_IN_PP_SYS_C
36 /* Shadow password support for solaris - pdo@cs.umd.edu
37 * Not just Solaris: at least HP-UX, IRIX, Linux.
38 * The API is from SysV.
40 * There are at least two more shadow interfaces,
41 * see the comments in pp_gpwent().
45 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
46 * and another MAXINT from "perl.h" <- <sys/param.h>. */
53 # include <sys/wait.h>
57 # include <sys/resource.h>
66 # include <sys/select.h>
70 /* XXX Configure test needed.
71 h_errno might not be a simple 'int', especially for multi-threaded
72 applications, see "extern int errno in perl.h". Creating such
73 a test requires taking into account the differences between
74 compiling multithreaded and singlethreaded ($ccflags et al).
75 HOST_NOT_FOUND is typically defined in <netdb.h>.
77 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
86 struct passwd *getpwnam (char *);
87 struct passwd *getpwuid (Uid_t);
92 struct passwd *getpwent (void);
93 #elif defined (VMS) && defined (my_getpwent)
94 struct passwd *Perl_my_getpwent (pTHX);
103 struct group *getgrnam (char *);
104 struct group *getgrgid (Gid_t);
108 struct group *getgrent (void);
114 # if defined(_MSC_VER) || defined(__MINGW32__)
115 # include <sys/utime.h>
122 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
125 # define my_chsize PerlLIO_chsize
128 # define my_chsize PerlLIO_chsize
130 I32 my_chsize(int fd, Off_t length);
136 #else /* no flock() */
138 /* fcntl.h might not have been included, even if it exists, because
139 the current Configure only sets I_FCNTL if it's needed to pick up
140 the *_OK constants. Make sure it has been included before testing
141 the fcntl() locking constants. */
142 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
146 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
147 # define FLOCK fcntl_emulate_flock
148 # define FCNTL_EMULATE_FLOCK
149 # else /* no flock() or fcntl(F_SETLK,...) */
151 # define FLOCK lockf_emulate_flock
152 # define LOCKF_EMULATE_FLOCK
154 # endif /* no flock() or fcntl(F_SETLK,...) */
157 static int FLOCK (int, int);
160 * These are the flock() constants. Since this sytems doesn't have
161 * flock(), the values of the constants are probably not available.
175 # endif /* emulating flock() */
177 #endif /* no flock() */
180 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
182 #if defined(I_SYS_ACCESS) && !defined(R_OK)
183 # include <sys/access.h>
186 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
187 # define FD_CLOEXEC 1 /* NeXT needs this */
193 /* Missing protos on LynxOS */
194 void sethostent(int);
195 void endhostent(void);
197 void endnetent(void);
198 void setprotoent(int);
199 void endprotoent(void);
200 void setservent(int);
201 void endservent(void);
204 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
206 /* F_OK unused: if stat() cannot find it... */
208 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
209 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
210 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
213 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
214 # ifdef I_SYS_SECURITY
215 # include <sys/security.h>
219 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
222 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
226 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
228 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
232 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
233 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
234 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
237 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
239 const Uid_t ruid = getuid();
240 const Uid_t euid = geteuid();
241 const Gid_t rgid = getgid();
242 const Gid_t egid = getegid();
245 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
246 Perl_croak(aTHX_ "switching effective uid is not implemented");
249 if (setreuid(euid, ruid))
252 if (setresuid(euid, ruid, (Uid_t)-1))
255 Perl_croak(aTHX_ "entering effective uid failed");
258 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
259 Perl_croak(aTHX_ "switching effective gid is not implemented");
262 if (setregid(egid, rgid))
265 if (setresgid(egid, rgid, (Gid_t)-1))
268 Perl_croak(aTHX_ "entering effective gid failed");
271 res = access(path, mode);
274 if (setreuid(ruid, euid))
277 if (setresuid(ruid, euid, (Uid_t)-1))
280 Perl_croak(aTHX_ "leaving effective uid failed");
283 if (setregid(rgid, egid))
286 if (setresgid(rgid, egid, (Gid_t)-1))
289 Perl_croak(aTHX_ "leaving effective gid failed");
293 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
300 const char * const tmps = POPpconstx;
301 const I32 gimme = GIMME_V;
302 const char *mode = "r";
305 if (PL_op->op_private & OPpOPEN_IN_RAW)
307 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
309 fp = PerlProc_popen(tmps, mode);
311 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
313 PerlIO_apply_layers(aTHX_ fp,mode,type);
315 if (gimme == G_VOID) {
317 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
320 else if (gimme == G_SCALAR) {
321 ENTER_with_name("backtick");
323 PL_rs = &PL_sv_undef;
324 sv_setpvs(TARG, ""); /* note that this preserves previous buffer */
325 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
327 LEAVE_with_name("backtick");
333 SV * const sv = newSV(79);
334 if (sv_gets(sv, fp, 0) == NULL) {
339 if (SvLEN(sv) - SvCUR(sv) > 20) {
340 SvPV_shrink_to_cur(sv);
345 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
346 TAINT; /* "I believe that this is not gratuitous!" */
349 STATUS_NATIVE_CHILD_SET(-1);
350 if (gimme == G_SCALAR)
361 tryAMAGICunTARGET(iter, -1);
363 /* Note that we only ever get here if File::Glob fails to load
364 * without at the same time croaking, for some reason, or if
365 * perl was built with PERL_EXTERNAL_GLOB */
367 ENTER_with_name("glob");
372 * The external globbing program may use things we can't control,
373 * so for security reasons we must assume the worst.
376 taint_proper(PL_no_security, "glob");
380 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
381 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
383 SAVESPTR(PL_rs); /* This is not permanent, either. */
384 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
387 *SvPVX(PL_rs) = '\n';
391 result = do_readline();
392 LEAVE_with_name("glob");
399 PL_last_in_gv = cGVOP_gv;
400 return do_readline();
411 do_join(TARG, &PL_sv_no, MARK, SP);
415 else if (SP == MARK) {
424 if (SvROK(exsv) || (pv = SvPV_const(exsv, len), len)) {
425 /* well-formed exception supplied */
427 else if (SvROK(ERRSV)) {
430 else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
431 exsv = sv_mortalcopy(ERRSV);
432 sv_catpvs(exsv, "\t...caught");
435 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
448 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
450 if (SP - MARK != 1) {
452 do_join(TARG, &PL_sv_no, MARK, SP);
460 if (SvROK(exsv) || (pv = SvPV_const(exsv, len), len)) {
461 /* well-formed exception supplied */
463 else if (SvROK(ERRSV)) {
465 if (sv_isobject(exsv)) {
466 HV * const stash = SvSTASH(SvRV(exsv));
467 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
469 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
470 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
477 call_sv(MUTABLE_SV(GvCV(gv)),
478 G_SCALAR|G_EVAL|G_KEEPERR);
479 exsv = sv_mortalcopy(*PL_stack_sp--);
483 else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
484 exsv = sv_mortalcopy(ERRSV);
485 sv_catpvs(exsv, "\t...propagated");
488 exsv = newSVpvs_flags("Died", SVs_TEMP);
507 GV * const gv = MUTABLE_GV(*++MARK);
510 DIE(aTHX_ PL_no_usym, "filehandle");
512 if ((io = GvIOp(gv))) {
514 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
517 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
518 "Opening dirhandle %s also as a file",
521 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
523 /* Method's args are same as ours ... */
524 /* ... except handle is replaced by the object */
525 *MARK-- = SvTIED_obj(MUTABLE_SV(io), mg);
528 ENTER_with_name("call_OPEN");
529 call_method("OPEN", G_SCALAR);
530 LEAVE_with_name("call_OPEN");
543 tmps = SvPV_const(sv, len);
544 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
547 PUSHi( (I32)PL_forkprocess );
548 else if (PL_forkprocess == 0) /* we are a new child */
558 GV * const gv = (MAXARG == 0) ? PL_defoutgv : MUTABLE_GV(POPs);
561 IO * const io = GvIO(gv);
563 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
566 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
568 ENTER_with_name("call_CLOSE");
569 call_method("CLOSE", G_SCALAR);
570 LEAVE_with_name("call_CLOSE");
577 PUSHs(boolSV(do_close(gv, TRUE)));
590 GV * const wgv = MUTABLE_GV(POPs);
591 GV * const rgv = MUTABLE_GV(POPs);
596 if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
597 DIE(aTHX_ PL_no_usym, "filehandle");
602 do_close(rgv, FALSE);
604 do_close(wgv, FALSE);
606 if (PerlProc_pipe(fd) < 0)
609 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
610 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
611 IoOFP(rstio) = IoIFP(rstio);
612 IoIFP(wstio) = IoOFP(wstio);
613 IoTYPE(rstio) = IoTYPE_RDONLY;
614 IoTYPE(wstio) = IoTYPE_WRONLY;
616 if (!IoIFP(rstio) || !IoOFP(wstio)) {
618 PerlIO_close(IoIFP(rstio));
620 PerlLIO_close(fd[0]);
622 PerlIO_close(IoOFP(wstio));
624 PerlLIO_close(fd[1]);
627 #if defined(HAS_FCNTL) && defined(F_SETFD)
628 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
629 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
636 DIE(aTHX_ PL_no_func, "pipe");
651 gv = MUTABLE_GV(POPs);
653 if (gv && (io = GvIO(gv))
654 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
657 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
659 ENTER_with_name("call_FILENO");
660 call_method("FILENO", G_SCALAR);
661 LEAVE_with_name("call_FILENO");
666 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
667 /* Can't do this because people seem to do things like
668 defined(fileno($foo)) to check whether $foo is a valid fh.
669 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
670 report_evil_fh(gv, io, PL_op->op_type);
675 PUSHi(PerlIO_fileno(fp));
688 anum = PerlLIO_umask(022);
689 /* setting it to 022 between the two calls to umask avoids
690 * to have a window where the umask is set to 0 -- meaning
691 * that another thread could create world-writeable files. */
693 (void)PerlLIO_umask(anum);
696 anum = PerlLIO_umask(POPi);
697 TAINT_PROPER("umask");
700 /* Only DIE if trying to restrict permissions on "user" (self).
701 * Otherwise it's harmless and more useful to just return undef
702 * since 'group' and 'other' concepts probably don't exist here. */
703 if (MAXARG >= 1 && (POPi & 0700))
704 DIE(aTHX_ "umask not implemented");
705 XPUSHs(&PL_sv_undef);
724 gv = MUTABLE_GV(POPs);
726 if (gv && (io = GvIO(gv))) {
727 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
730 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
734 ENTER_with_name("call_BINMODE");
735 call_method("BINMODE", G_SCALAR);
736 LEAVE_with_name("call_BINMODE");
743 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
744 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
745 report_evil_fh(gv, io, PL_op->op_type);
746 SETERRNO(EBADF,RMS_IFI);
753 const char *d = NULL;
756 d = SvPV_const(discp, len);
757 mode = mode_from_discipline(d, len);
758 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
759 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
760 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
781 const I32 markoff = MARK - PL_stack_base;
782 const char *methname;
783 int how = PERL_MAGIC_tied;
787 switch(SvTYPE(varsv)) {
789 methname = "TIEHASH";
790 HvEITER_set(MUTABLE_HV(varsv), 0);
793 methname = "TIEARRAY";
796 if (isGV_with_GP(varsv)) {
797 methname = "TIEHANDLE";
798 how = PERL_MAGIC_tiedscalar;
799 /* For tied filehandles, we apply tiedscalar magic to the IO
800 slot of the GP rather than the GV itself. AMS 20010812 */
802 GvIOp(varsv) = newIO();
803 varsv = MUTABLE_SV(GvIOp(varsv));
808 methname = "TIESCALAR";
809 how = PERL_MAGIC_tiedscalar;
813 if (sv_isobject(*MARK)) { /* Calls GET magic. */
814 ENTER_with_name("call_TIE");
815 PUSHSTACKi(PERLSI_MAGIC);
817 EXTEND(SP,(I32)items);
821 call_method(methname, G_SCALAR);
824 /* Not clear why we don't call call_method here too.
825 * perhaps to get different error message ?
828 const char *name = SvPV_nomg_const(*MARK, len);
829 stash = gv_stashpvn(name, len, 0);
830 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
831 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
832 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
834 ENTER_with_name("call_TIE");
835 PUSHSTACKi(PERLSI_MAGIC);
837 EXTEND(SP,(I32)items);
841 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
847 if (sv_isobject(sv)) {
848 sv_unmagic(varsv, how);
849 /* Croak if a self-tie on an aggregate is attempted. */
850 if (varsv == SvRV(sv) &&
851 (SvTYPE(varsv) == SVt_PVAV ||
852 SvTYPE(varsv) == SVt_PVHV))
854 "Self-ties of arrays and hashes are not supported");
855 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
857 LEAVE_with_name("call_TIE");
858 SP = PL_stack_base + markoff;
868 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
869 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
871 if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
874 if ((mg = SvTIED_mg(sv, how))) {
875 SV * const obj = SvRV(SvTIED_obj(sv, mg));
877 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
879 if (gv && isGV(gv) && (cv = GvCV(gv))) {
881 XPUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
882 mXPUSHi(SvREFCNT(obj) - 1);
884 ENTER_with_name("call_UNTIE");
885 call_sv(MUTABLE_SV(cv), G_VOID);
886 LEAVE_with_name("call_UNTIE");
889 else if (mg && SvREFCNT(obj) > 1) {
890 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
891 "untie attempted while %"UVuf" inner references still exist",
892 (UV)SvREFCNT(obj) - 1 ) ;
896 sv_unmagic(sv, how) ;
906 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
907 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
909 if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
912 if ((mg = SvTIED_mg(sv, how))) {
913 SV *osv = SvTIED_obj(sv, mg);
914 if (osv == mg->mg_obj)
915 osv = sv_mortalcopy(osv);
929 HV * const hv = MUTABLE_HV(POPs);
930 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
931 stash = gv_stashsv(sv, 0);
932 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
934 require_pv("AnyDBM_File.pm");
936 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
937 DIE(aTHX_ "No dbm on this machine");
947 mPUSHu(O_RDWR|O_CREAT);
952 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
955 if (!sv_isobject(TOPs)) {
963 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
967 if (sv_isobject(TOPs)) {
968 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
969 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
986 struct timeval timebuf;
987 struct timeval *tbuf = &timebuf;
990 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
995 # if BYTEORDER & 0xf0000
996 # define ORDERBYTE (0x88888888 - BYTEORDER)
998 # define ORDERBYTE (0x4444 - BYTEORDER)
1004 for (i = 1; i <= 3; i++) {
1005 SV * const sv = SP[i];
1008 if (SvREADONLY(sv)) {
1010 sv_force_normal_flags(sv, 0);
1011 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1012 DIE(aTHX_ "%s", PL_no_modify);
1015 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1016 SvPV_force_nolen(sv); /* force string conversion */
1023 /* little endians can use vecs directly */
1024 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1031 masksize = NFDBITS / NBBY;
1033 masksize = sizeof(long); /* documented int, everyone seems to use long */
1035 Zero(&fd_sets[0], 4, char*);
1038 # if SELECT_MIN_BITS == 1
1039 growsize = sizeof(fd_set);
1041 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1042 # undef SELECT_MIN_BITS
1043 # define SELECT_MIN_BITS __FD_SETSIZE
1045 /* If SELECT_MIN_BITS is greater than one we most probably will want
1046 * to align the sizes with SELECT_MIN_BITS/8 because for example
1047 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1048 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1049 * on (sets/tests/clears bits) is 32 bits. */
1050 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1058 timebuf.tv_sec = (long)value;
1059 value -= (NV)timebuf.tv_sec;
1060 timebuf.tv_usec = (long)(value * 1000000.0);
1065 for (i = 1; i <= 3; i++) {
1067 if (!SvOK(sv) || SvCUR(sv) == 0) {
1074 Sv_Grow(sv, growsize);
1078 while (++j <= growsize) {
1082 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1084 Newx(fd_sets[i], growsize, char);
1085 for (offset = 0; offset < growsize; offset += masksize) {
1086 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1087 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1090 fd_sets[i] = SvPVX(sv);
1094 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1095 /* Can't make just the (void*) conditional because that would be
1096 * cpp #if within cpp macro, and not all compilers like that. */
1097 nfound = PerlSock_select(
1099 (Select_fd_set_t) fd_sets[1],
1100 (Select_fd_set_t) fd_sets[2],
1101 (Select_fd_set_t) fd_sets[3],
1102 (void*) tbuf); /* Workaround for compiler bug. */
1104 nfound = PerlSock_select(
1106 (Select_fd_set_t) fd_sets[1],
1107 (Select_fd_set_t) fd_sets[2],
1108 (Select_fd_set_t) fd_sets[3],
1111 for (i = 1; i <= 3; i++) {
1114 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1116 for (offset = 0; offset < growsize; offset += masksize) {
1117 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1118 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1120 Safefree(fd_sets[i]);
1127 if (GIMME == G_ARRAY && tbuf) {
1128 value = (NV)(timebuf.tv_sec) +
1129 (NV)(timebuf.tv_usec) / 1000000.0;
1134 DIE(aTHX_ "select not implemented");
1140 =for apidoc setdefout
1142 Sets PL_defoutgv, the default file handle for output, to the passed in
1143 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1144 count of the passed in typeglob is increased by one, and the reference count
1145 of the typeglob that PL_defoutgv points to is decreased by one.
1151 Perl_setdefout(pTHX_ GV *gv)
1154 SvREFCNT_inc_simple_void(gv);
1155 SvREFCNT_dec(PL_defoutgv);
1163 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1164 GV * egv = GvEGVx(PL_defoutgv);
1168 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1170 XPUSHs(&PL_sv_undef);
1172 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1173 if (gvp && *gvp == egv) {
1174 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1178 mXPUSHs(newRV(MUTABLE_SV(egv)));
1183 if (!GvIO(newdefout))
1184 gv_IOadd(newdefout);
1185 setdefout(newdefout);
1195 GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs);
1197 if (gv && (io = GvIO(gv))) {
1198 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1200 const I32 gimme = GIMME_V;
1202 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
1205 call_method("GETC", gimme);
1208 if (gimme == G_SCALAR)
1209 SvSetMagicSV_nosteal(TARG, TOPs);
1213 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1214 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1215 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1216 report_evil_fh(gv, io, PL_op->op_type);
1217 SETERRNO(EBADF,RMS_IFI);
1221 sv_setpvs(TARG, " ");
1222 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1223 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1224 /* Find out how many bytes the char needs */
1225 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1228 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1229 SvCUR_set(TARG,1+len);
1238 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1241 register PERL_CONTEXT *cx;
1242 const I32 gimme = GIMME_V;
1244 PERL_ARGS_ASSERT_DOFORM;
1249 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1250 PUSHFORMAT(cx, retop);
1252 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1254 setdefout(gv); /* locally select filehandle so $% et al work */
1271 gv = MUTABLE_GV(POPs);
1286 goto not_a_format_reference;
1291 tmpsv = sv_newmortal();
1292 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1293 name = SvPV_nolen_const(tmpsv);
1295 DIE(aTHX_ "Undefined format \"%s\" called", name);
1297 not_a_format_reference:
1298 DIE(aTHX_ "Not a format reference");
1301 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1303 IoFLAGS(io) &= ~IOf_DIDTOP;
1304 return doform(cv,gv,PL_op->op_next);
1310 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1311 register IO * const io = GvIOp(gv);
1316 register PERL_CONTEXT *cx;
1318 if (!io || !(ofp = IoOFP(io)))
1321 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1322 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1324 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1325 PL_formtarget != PL_toptarget)
1329 if (!IoTOP_GV(io)) {
1332 if (!IoTOP_NAME(io)) {
1334 if (!IoFMT_NAME(io))
1335 IoFMT_NAME(io) = savepv(GvNAME(gv));
1336 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1337 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1338 if ((topgv && GvFORM(topgv)) ||
1339 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1340 IoTOP_NAME(io) = savesvpv(topname);
1342 IoTOP_NAME(io) = savepvs("top");
1344 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1345 if (!topgv || !GvFORM(topgv)) {
1346 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1349 IoTOP_GV(io) = topgv;
1351 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1352 I32 lines = IoLINES_LEFT(io);
1353 const char *s = SvPVX_const(PL_formtarget);
1354 if (lines <= 0) /* Yow, header didn't even fit!!! */
1356 while (lines-- > 0) {
1357 s = strchr(s, '\n');
1363 const STRLEN save = SvCUR(PL_formtarget);
1364 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1365 do_print(PL_formtarget, ofp);
1366 SvCUR_set(PL_formtarget, save);
1367 sv_chop(PL_formtarget, s);
1368 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1371 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1372 do_print(PL_formfeed, ofp);
1373 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1375 PL_formtarget = PL_toptarget;
1376 IoFLAGS(io) |= IOf_DIDTOP;
1379 DIE(aTHX_ "bad top format reference");
1382 SV * const sv = sv_newmortal();
1384 gv_efullname4(sv, fgv, NULL, FALSE);
1385 name = SvPV_nolen_const(sv);
1387 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1389 DIE(aTHX_ "Undefined top format called");
1391 if (cv && CvCLONE(cv))
1392 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1393 return doform(cv, gv, PL_op);
1397 POPBLOCK(cx,PL_curpm);
1403 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1405 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1406 else if (ckWARN(WARN_CLOSED))
1407 report_evil_fh(gv, io, PL_op->op_type);
1412 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1413 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1415 if (!do_print(PL_formtarget, fp))
1418 FmLINES(PL_formtarget) = 0;
1419 SvCUR_set(PL_formtarget, 0);
1420 *SvEND(PL_formtarget) = '\0';
1421 if (IoFLAGS(io) & IOf_FLUSH)
1422 (void)PerlIO_flush(fp);
1427 PL_formtarget = PL_bodytarget;
1429 PERL_UNUSED_VAR(newsp);
1430 PERL_UNUSED_VAR(gimme);
1431 return cx->blk_sub.retop;
1436 dVAR; dSP; dMARK; dORIGMARK;
1442 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1444 if (gv && (io = GvIO(gv))) {
1445 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1447 if (MARK == ORIGMARK) {
1450 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1454 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1457 call_method("PRINTF", G_SCALAR);
1460 MARK = ORIGMARK + 1;
1468 if (!(io = GvIO(gv))) {
1469 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1470 report_evil_fh(gv, io, PL_op->op_type);
1471 SETERRNO(EBADF,RMS_IFI);
1474 else if (!(fp = IoOFP(io))) {
1475 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1477 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1478 else if (ckWARN(WARN_CLOSED))
1479 report_evil_fh(gv, io, PL_op->op_type);
1481 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1485 if (SvTAINTED(MARK[1]))
1486 TAINT_PROPER("printf");
1487 do_sprintf(sv, SP - MARK, MARK + 1);
1488 if (!do_print(sv, fp))
1491 if (IoFLAGS(io) & IOf_FLUSH)
1492 if (PerlIO_flush(fp) == EOF)
1503 PUSHs(&PL_sv_undef);
1511 const int perm = (MAXARG > 3) ? POPi : 0666;
1512 const int mode = POPi;
1513 SV * const sv = POPs;
1514 GV * const gv = MUTABLE_GV(POPs);
1517 /* Need TIEHANDLE method ? */
1518 const char * const tmps = SvPV_const(sv, len);
1519 /* FIXME? do_open should do const */
1520 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1521 IoLINES(GvIOp(gv)) = 0;
1525 PUSHs(&PL_sv_undef);
1532 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1538 Sock_size_t bufsize;
1546 bool charstart = FALSE;
1547 STRLEN charskip = 0;
1550 GV * const gv = MUTABLE_GV(*++MARK);
1551 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1552 && gv && (io = GvIO(gv)) )
1554 const MAGIC * mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1558 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1560 call_method("READ", G_SCALAR);
1574 sv_setpvs(bufsv, "");
1575 length = SvIVx(*++MARK);
1578 offset = SvIVx(*++MARK);
1582 if (!io || !IoIFP(io)) {
1583 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1584 report_evil_fh(gv, io, PL_op->op_type);
1585 SETERRNO(EBADF,RMS_IFI);
1588 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1589 buffer = SvPVutf8_force(bufsv, blen);
1590 /* UTF-8 may not have been set if they are all low bytes */
1595 buffer = SvPV_force(bufsv, blen);
1596 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1599 DIE(aTHX_ "Negative length");
1607 if (PL_op->op_type == OP_RECV) {
1608 char namebuf[MAXPATHLEN];
1609 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1610 bufsize = sizeof (struct sockaddr_in);
1612 bufsize = sizeof namebuf;
1614 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1618 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1619 /* 'offset' means 'flags' here */
1620 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1621 (struct sockaddr *)namebuf, &bufsize);
1625 /* Bogus return without padding */
1626 bufsize = sizeof (struct sockaddr_in);
1628 SvCUR_set(bufsv, count);
1629 *SvEND(bufsv) = '\0';
1630 (void)SvPOK_only(bufsv);
1634 /* This should not be marked tainted if the fp is marked clean */
1635 if (!(IoFLAGS(io) & IOf_UNTAINT))
1636 SvTAINTED_on(bufsv);
1638 sv_setpvn(TARG, namebuf, bufsize);
1643 if (PL_op->op_type == OP_RECV)
1644 DIE(aTHX_ PL_no_sock_func, "recv");
1646 if (DO_UTF8(bufsv)) {
1647 /* offset adjust in characters not bytes */
1648 blen = sv_len_utf8(bufsv);
1651 if (-offset > (int)blen)
1652 DIE(aTHX_ "Offset outside string");
1655 if (DO_UTF8(bufsv)) {
1656 /* convert offset-as-chars to offset-as-bytes */
1657 if (offset >= (int)blen)
1658 offset += SvCUR(bufsv) - blen;
1660 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1663 bufsize = SvCUR(bufsv);
1664 /* Allocating length + offset + 1 isn't perfect in the case of reading
1665 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1667 (should be 2 * length + offset + 1, or possibly something longer if
1668 PL_encoding is true) */
1669 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1670 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1671 Zero(buffer+bufsize, offset-bufsize, char);
1673 buffer = buffer + offset;
1675 read_target = bufsv;
1677 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1678 concatenate it to the current buffer. */
1680 /* Truncate the existing buffer to the start of where we will be
1682 SvCUR_set(bufsv, offset);
1684 read_target = sv_newmortal();
1685 SvUPGRADE(read_target, SVt_PV);
1686 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1689 if (PL_op->op_type == OP_SYSREAD) {
1690 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1691 if (IoTYPE(io) == IoTYPE_SOCKET) {
1692 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1698 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1703 #ifdef HAS_SOCKET__bad_code_maybe
1704 if (IoTYPE(io) == IoTYPE_SOCKET) {
1705 char namebuf[MAXPATHLEN];
1706 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1707 bufsize = sizeof (struct sockaddr_in);
1709 bufsize = sizeof namebuf;
1711 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1712 (struct sockaddr *)namebuf, &bufsize);
1717 count = PerlIO_read(IoIFP(io), buffer, length);
1718 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1719 if (count == 0 && PerlIO_error(IoIFP(io)))
1723 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1724 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1727 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1728 *SvEND(read_target) = '\0';
1729 (void)SvPOK_only(read_target);
1730 if (fp_utf8 && !IN_BYTES) {
1731 /* Look at utf8 we got back and count the characters */
1732 const char *bend = buffer + count;
1733 while (buffer < bend) {
1735 skip = UTF8SKIP(buffer);
1738 if (buffer - charskip + skip > bend) {
1739 /* partial character - try for rest of it */
1740 length = skip - (bend-buffer);
1741 offset = bend - SvPVX_const(bufsv);
1753 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1754 provided amount read (count) was what was requested (length)
1756 if (got < wanted && count == length) {
1757 length = wanted - got;
1758 offset = bend - SvPVX_const(bufsv);
1761 /* return value is character count */
1765 else if (buffer_utf8) {
1766 /* Let svcatsv upgrade the bytes we read in to utf8.
1767 The buffer is a mortal so will be freed soon. */
1768 sv_catsv_nomg(bufsv, read_target);
1771 /* This should not be marked tainted if the fp is marked clean */
1772 if (!(IoFLAGS(io) & IOf_UNTAINT))
1773 SvTAINTED_on(bufsv);
1785 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1791 STRLEN orig_blen_bytes;
1792 const int op_type = PL_op->op_type;
1796 GV *const gv = MUTABLE_GV(*++MARK);
1797 if (PL_op->op_type == OP_SYSWRITE
1798 && gv && (io = GvIO(gv))) {
1799 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1803 if (MARK == SP - 1) {
1805 mXPUSHi(sv_len(sv));
1810 *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg);
1812 call_method("WRITE", G_SCALAR);
1828 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1830 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1831 if (io && IoIFP(io))
1832 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1834 report_evil_fh(gv, io, PL_op->op_type);
1836 SETERRNO(EBADF,RMS_IFI);
1840 /* Do this first to trigger any overloading. */
1841 buffer = SvPV_const(bufsv, blen);
1842 orig_blen_bytes = blen;
1843 doing_utf8 = DO_UTF8(bufsv);
1845 if (PerlIO_isutf8(IoIFP(io))) {
1846 if (!SvUTF8(bufsv)) {
1847 /* We don't modify the original scalar. */
1848 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1849 buffer = (char *) tmpbuf;
1853 else if (doing_utf8) {
1854 STRLEN tmplen = blen;
1855 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1858 buffer = (char *) tmpbuf;
1862 assert((char *)result == buffer);
1863 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1867 if (op_type == OP_SYSWRITE) {
1868 Size_t length = 0; /* This length is in characters. */
1874 /* The SV is bytes, and we've had to upgrade it. */
1875 blen_chars = orig_blen_bytes;
1877 /* The SV really is UTF-8. */
1878 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1879 /* Don't call sv_len_utf8 again because it will call magic
1880 or overloading a second time, and we might get back a
1881 different result. */
1882 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1884 /* It's safe, and it may well be cached. */
1885 blen_chars = sv_len_utf8(bufsv);
1893 length = blen_chars;
1895 #if Size_t_size > IVSIZE
1896 length = (Size_t)SvNVx(*++MARK);
1898 length = (Size_t)SvIVx(*++MARK);
1900 if ((SSize_t)length < 0) {
1902 DIE(aTHX_ "Negative length");
1907 offset = SvIVx(*++MARK);
1909 if (-offset > (IV)blen_chars) {
1911 DIE(aTHX_ "Offset outside string");
1913 offset += blen_chars;
1914 } else if (offset > (IV)blen_chars) {
1916 DIE(aTHX_ "Offset outside string");
1920 if (length > blen_chars - offset)
1921 length = blen_chars - offset;
1923 /* Here we convert length from characters to bytes. */
1924 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1925 /* Either we had to convert the SV, or the SV is magical, or
1926 the SV has overloading, in which case we can't or mustn't
1927 or mustn't call it again. */
1929 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1930 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1932 /* It's a real UTF-8 SV, and it's not going to change under
1933 us. Take advantage of any cache. */
1935 I32 len_I32 = length;
1937 /* Convert the start and end character positions to bytes.
1938 Remember that the second argument to sv_pos_u2b is relative
1940 sv_pos_u2b(bufsv, &start, &len_I32);
1947 buffer = buffer+offset;
1949 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1950 if (IoTYPE(io) == IoTYPE_SOCKET) {
1951 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1957 /* See the note at doio.c:do_print about filesize limits. --jhi */
1958 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1964 const int flags = SvIVx(*++MARK);
1967 char * const sockbuf = SvPVx(*++MARK, mlen);
1968 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1969 flags, (struct sockaddr *)sockbuf, mlen);
1973 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1978 DIE(aTHX_ PL_no_sock_func, "send");
1985 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
1988 #if Size_t_size > IVSIZE
2009 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2010 else if (PL_op->op_flags & OPf_SPECIAL)
2011 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2013 gv = PL_last_in_gv; /* eof */
2018 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2020 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2022 * in Perl 5.12 and later, the additional paramter is a bitmask:
2025 * 2 = eof() <- ARGV magic
2028 mPUSHi(1); /* 1 = eof(FH) - simple, explicit FH */
2029 else if (PL_op->op_flags & OPf_SPECIAL)
2030 mPUSHi(2); /* 2 = eof() - ARGV magic */
2032 mPUSHi(0); /* 0 = eof - simple, implicit FH */
2035 call_method("EOF", G_SCALAR);
2041 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2042 if (io && !IoIFP(io)) {
2043 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2045 IoFLAGS(io) &= ~IOf_START;
2046 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2048 sv_setpvs(GvSV(gv), "-");
2050 GvSV(gv) = newSVpvs("-");
2051 SvSETMAGIC(GvSV(gv));
2053 else if (!nextargv(gv))
2058 PUSHs(boolSV(do_eof(gv)));
2069 PL_last_in_gv = MUTABLE_GV(POPs);
2072 if (gv && (io = GvIO(gv))) {
2073 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2076 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2079 call_method("TELL", G_SCALAR);
2087 SETERRNO(EBADF,RMS_IFI);
2092 #if LSEEKSIZE > IVSIZE
2093 PUSHn( do_tell(gv) );
2095 PUSHi( do_tell(gv) );
2103 const int whence = POPi;
2104 #if LSEEKSIZE > IVSIZE
2105 const Off_t offset = (Off_t)SvNVx(POPs);
2107 const Off_t offset = (Off_t)SvIVx(POPs);
2110 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2113 if (gv && (io = GvIO(gv))) {
2114 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2117 XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2118 #if LSEEKSIZE > IVSIZE
2119 mXPUSHn((NV) offset);
2126 call_method("SEEK", G_SCALAR);
2133 if (PL_op->op_type == OP_SEEK)
2134 PUSHs(boolSV(do_seek(gv, offset, whence)));
2136 const Off_t sought = do_sysseek(gv, offset, whence);
2138 PUSHs(&PL_sv_undef);
2140 SV* const sv = sought ?
2141 #if LSEEKSIZE > IVSIZE
2146 : newSVpvn(zero_but_true, ZBTLEN);
2157 /* There seems to be no consensus on the length type of truncate()
2158 * and ftruncate(), both off_t and size_t have supporters. In
2159 * general one would think that when using large files, off_t is
2160 * at least as wide as size_t, so using an off_t should be okay. */
2161 /* XXX Configure probe for the length type of *truncate() needed XXX */
2164 #if Off_t_size > IVSIZE
2169 /* Checking for length < 0 is problematic as the type might or
2170 * might not be signed: if it is not, clever compilers will moan. */
2171 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2178 if (PL_op->op_flags & OPf_SPECIAL) {
2179 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2188 TAINT_PROPER("truncate");
2189 if (!(fp = IoIFP(io))) {
2195 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2197 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2204 SV * const sv = POPs;
2207 if (isGV_with_GP(sv)) {
2208 tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */
2209 goto do_ftruncate_gv;
2211 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2212 tmpgv = MUTABLE_GV(SvRV(sv)); /* \*main::FRED for example */
2213 goto do_ftruncate_gv;
2215 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2216 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2217 goto do_ftruncate_io;
2220 name = SvPV_nolen_const(sv);
2221 TAINT_PROPER("truncate");
2223 if (truncate(name, len) < 0)
2227 const int tmpfd = PerlLIO_open(name, O_RDWR);
2232 if (my_chsize(tmpfd, len) < 0)
2234 PerlLIO_close(tmpfd);
2243 SETERRNO(EBADF,RMS_IFI);
2251 SV * const argsv = POPs;
2252 const unsigned int func = POPu;
2253 const int optype = PL_op->op_type;
2254 GV * const gv = MUTABLE_GV(POPs);
2255 IO * const io = gv ? GvIOn(gv) : NULL;
2259 if (!io || !argsv || !IoIFP(io)) {
2260 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2261 report_evil_fh(gv, io, PL_op->op_type);
2262 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2266 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2269 s = SvPV_force(argsv, len);
2270 need = IOCPARM_LEN(func);
2272 s = Sv_Grow(argsv, need + 1);
2273 SvCUR_set(argsv, need);
2276 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2279 retval = SvIV(argsv);
2280 s = INT2PTR(char*,retval); /* ouch */
2283 TAINT_PROPER(PL_op_desc[optype]);
2285 if (optype == OP_IOCTL)
2287 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2289 DIE(aTHX_ "ioctl is not implemented");
2293 DIE(aTHX_ "fcntl is not implemented");
2295 #if defined(OS2) && defined(__EMX__)
2296 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2298 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2302 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2304 if (s[SvCUR(argsv)] != 17)
2305 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2307 s[SvCUR(argsv)] = 0; /* put our null back */
2308 SvSETMAGIC(argsv); /* Assume it has changed */
2317 PUSHp(zero_but_true, ZBTLEN);
2330 const int argtype = POPi;
2331 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
2333 if (gv && (io = GvIO(gv)))
2339 /* XXX Looks to me like io is always NULL at this point */
2341 (void)PerlIO_flush(fp);
2342 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2345 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2346 report_evil_fh(gv, io, PL_op->op_type);
2348 SETERRNO(EBADF,RMS_IFI);
2353 DIE(aTHX_ PL_no_func, "flock()");
2364 const int protocol = POPi;
2365 const int type = POPi;
2366 const int domain = POPi;
2367 GV * const gv = MUTABLE_GV(POPs);
2368 register IO * const io = gv ? GvIOn(gv) : NULL;
2372 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2373 report_evil_fh(gv, io, PL_op->op_type);
2374 if (io && IoIFP(io))
2375 do_close(gv, FALSE);
2376 SETERRNO(EBADF,LIB_INVARG);
2381 do_close(gv, FALSE);
2383 TAINT_PROPER("socket");
2384 fd = PerlSock_socket(domain, type, protocol);
2387 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2388 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2389 IoTYPE(io) = IoTYPE_SOCKET;
2390 if (!IoIFP(io) || !IoOFP(io)) {
2391 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2392 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2393 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2396 #if defined(HAS_FCNTL) && defined(F_SETFD)
2397 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2401 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2406 DIE(aTHX_ PL_no_sock_func, "socket");
2413 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2415 const int protocol = POPi;
2416 const int type = POPi;
2417 const int domain = POPi;
2418 GV * const gv2 = MUTABLE_GV(POPs);
2419 GV * const gv1 = MUTABLE_GV(POPs);
2420 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2421 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2424 if (!gv1 || !gv2 || !io1 || !io2) {
2425 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2427 report_evil_fh(gv1, io1, PL_op->op_type);
2429 report_evil_fh(gv1, io2, PL_op->op_type);
2431 if (io1 && IoIFP(io1))
2432 do_close(gv1, FALSE);
2433 if (io2 && IoIFP(io2))
2434 do_close(gv2, FALSE);
2439 do_close(gv1, FALSE);
2441 do_close(gv2, FALSE);
2443 TAINT_PROPER("socketpair");
2444 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2446 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2447 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2448 IoTYPE(io1) = IoTYPE_SOCKET;
2449 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2450 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2451 IoTYPE(io2) = IoTYPE_SOCKET;
2452 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2453 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2454 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2455 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2456 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2457 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2458 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2461 #if defined(HAS_FCNTL) && defined(F_SETFD)
2462 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2463 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2468 DIE(aTHX_ PL_no_sock_func, "socketpair");
2477 SV * const addrsv = POPs;
2478 /* OK, so on what platform does bind modify addr? */
2480 GV * const gv = MUTABLE_GV(POPs);
2481 register IO * const io = GvIOn(gv);
2484 if (!io || !IoIFP(io))
2487 addr = SvPV_const(addrsv, len);
2488 TAINT_PROPER("bind");
2489 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2495 if (ckWARN(WARN_CLOSED))
2496 report_evil_fh(gv, io, PL_op->op_type);
2497 SETERRNO(EBADF,SS_IVCHAN);
2500 DIE(aTHX_ PL_no_sock_func, "bind");
2509 SV * const addrsv = POPs;
2510 GV * const gv = MUTABLE_GV(POPs);
2511 register IO * const io = GvIOn(gv);
2515 if (!io || !IoIFP(io))
2518 addr = SvPV_const(addrsv, len);
2519 TAINT_PROPER("connect");
2520 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2526 if (ckWARN(WARN_CLOSED))
2527 report_evil_fh(gv, io, PL_op->op_type);
2528 SETERRNO(EBADF,SS_IVCHAN);
2531 DIE(aTHX_ PL_no_sock_func, "connect");
2540 const int backlog = POPi;
2541 GV * const gv = MUTABLE_GV(POPs);
2542 register IO * const io = gv ? GvIOn(gv) : NULL;
2544 if (!gv || !io || !IoIFP(io))
2547 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2553 if (ckWARN(WARN_CLOSED))
2554 report_evil_fh(gv, io, PL_op->op_type);
2555 SETERRNO(EBADF,SS_IVCHAN);
2558 DIE(aTHX_ PL_no_sock_func, "listen");
2569 char namebuf[MAXPATHLEN];
2570 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2571 Sock_size_t len = sizeof (struct sockaddr_in);
2573 Sock_size_t len = sizeof namebuf;
2575 GV * const ggv = MUTABLE_GV(POPs);
2576 GV * const ngv = MUTABLE_GV(POPs);
2585 if (!gstio || !IoIFP(gstio))
2589 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2592 /* Some platforms indicate zero length when an AF_UNIX client is
2593 * not bound. Simulate a non-zero-length sockaddr structure in
2595 namebuf[0] = 0; /* sun_len */
2596 namebuf[1] = AF_UNIX; /* sun_family */
2604 do_close(ngv, FALSE);
2605 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2606 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2607 IoTYPE(nstio) = IoTYPE_SOCKET;
2608 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2609 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2610 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2611 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2614 #if defined(HAS_FCNTL) && defined(F_SETFD)
2615 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2619 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2620 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2622 #ifdef __SCO_VERSION__
2623 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2626 PUSHp(namebuf, len);
2630 if (ckWARN(WARN_CLOSED))
2631 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2632 SETERRNO(EBADF,SS_IVCHAN);
2638 DIE(aTHX_ PL_no_sock_func, "accept");
2647 const int how = POPi;
2648 GV * const gv = MUTABLE_GV(POPs);
2649 register IO * const io = GvIOn(gv);
2651 if (!io || !IoIFP(io))
2654 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2658 if (ckWARN(WARN_CLOSED))
2659 report_evil_fh(gv, io, PL_op->op_type);
2660 SETERRNO(EBADF,SS_IVCHAN);
2663 DIE(aTHX_ PL_no_sock_func, "shutdown");
2672 const int optype = PL_op->op_type;
2673 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2674 const unsigned int optname = (unsigned int) POPi;
2675 const unsigned int lvl = (unsigned int) POPi;
2676 GV * const gv = MUTABLE_GV(POPs);
2677 register IO * const io = GvIOn(gv);
2681 if (!io || !IoIFP(io))
2684 fd = PerlIO_fileno(IoIFP(io));
2688 (void)SvPOK_only(sv);
2692 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2699 #if defined(__SYMBIAN32__)
2700 # define SETSOCKOPT_OPTION_VALUE_T void *
2702 # define SETSOCKOPT_OPTION_VALUE_T const char *
2704 /* XXX TODO: We need to have a proper type (a Configure probe,
2705 * etc.) for what the C headers think of the third argument of
2706 * setsockopt(), the option_value read-only buffer: is it
2707 * a "char *", or a "void *", const or not. Some compilers
2708 * don't take kindly to e.g. assuming that "char *" implicitly
2709 * promotes to a "void *", or to explicitly promoting/demoting
2710 * consts to non/vice versa. The "const void *" is the SUS
2711 * definition, but that does not fly everywhere for the above
2713 SETSOCKOPT_OPTION_VALUE_T buf;
2717 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2721 aint = (int)SvIV(sv);
2722 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2725 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2734 if (ckWARN(WARN_CLOSED))
2735 report_evil_fh(gv, io, optype);
2736 SETERRNO(EBADF,SS_IVCHAN);
2741 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2750 const int optype = PL_op->op_type;
2751 GV * const gv = MUTABLE_GV(POPs);
2752 register IO * const io = GvIOn(gv);
2757 if (!io || !IoIFP(io))
2760 sv = sv_2mortal(newSV(257));
2761 (void)SvPOK_only(sv);
2765 fd = PerlIO_fileno(IoIFP(io));
2767 case OP_GETSOCKNAME:
2768 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2771 case OP_GETPEERNAME:
2772 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2774 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2776 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";
2777 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2778 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2779 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2780 sizeof(u_short) + sizeof(struct in_addr))) {
2787 #ifdef BOGUS_GETNAME_RETURN
2788 /* Interactive Unix, getpeername() and getsockname()
2789 does not return valid namelen */
2790 if (len == BOGUS_GETNAME_RETURN)
2791 len = sizeof(struct sockaddr);
2799 if (ckWARN(WARN_CLOSED))
2800 report_evil_fh(gv, io, optype);
2801 SETERRNO(EBADF,SS_IVCHAN);
2806 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2822 if (PL_op->op_flags & OPf_REF) {
2824 if (PL_op->op_type == OP_LSTAT) {
2825 if (gv != PL_defgv) {
2826 do_fstat_warning_check:
2827 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2828 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2829 } else if (PL_laststype != OP_LSTAT)
2830 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2834 if (gv != PL_defgv) {
2835 PL_laststype = OP_STAT;
2837 sv_setpvs(PL_statname, "");
2844 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2845 } else if (IoDIRP(io)) {
2847 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2849 PL_laststatval = -1;
2855 if (PL_laststatval < 0) {
2856 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2857 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2862 SV* const sv = POPs;
2863 if (isGV_with_GP(sv)) {
2864 gv = MUTABLE_GV(sv);
2866 } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2867 gv = MUTABLE_GV(SvRV(sv));
2868 if (PL_op->op_type == OP_LSTAT)
2869 goto do_fstat_warning_check;
2871 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2872 io = MUTABLE_IO(SvRV(sv));
2873 if (PL_op->op_type == OP_LSTAT)
2874 goto do_fstat_warning_check;
2875 goto do_fstat_have_io;
2878 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2880 PL_laststype = PL_op->op_type;
2881 if (PL_op->op_type == OP_LSTAT)
2882 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2884 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2885 if (PL_laststatval < 0) {
2886 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2887 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2893 if (gimme != G_ARRAY) {
2894 if (gimme != G_VOID)
2895 XPUSHs(boolSV(max));
2901 mPUSHi(PL_statcache.st_dev);
2902 mPUSHi(PL_statcache.st_ino);
2903 mPUSHu(PL_statcache.st_mode);
2904 mPUSHu(PL_statcache.st_nlink);
2905 #if Uid_t_size > IVSIZE
2906 mPUSHn(PL_statcache.st_uid);
2908 # if Uid_t_sign <= 0
2909 mPUSHi(PL_statcache.st_uid);
2911 mPUSHu(PL_statcache.st_uid);
2914 #if Gid_t_size > IVSIZE
2915 mPUSHn(PL_statcache.st_gid);
2917 # if Gid_t_sign <= 0
2918 mPUSHi(PL_statcache.st_gid);
2920 mPUSHu(PL_statcache.st_gid);
2923 #ifdef USE_STAT_RDEV
2924 mPUSHi(PL_statcache.st_rdev);
2926 PUSHs(newSVpvs_flags("", SVs_TEMP));
2928 #if Off_t_size > IVSIZE
2929 mPUSHn(PL_statcache.st_size);
2931 mPUSHi(PL_statcache.st_size);
2934 mPUSHn(PL_statcache.st_atime);
2935 mPUSHn(PL_statcache.st_mtime);
2936 mPUSHn(PL_statcache.st_ctime);
2938 mPUSHi(PL_statcache.st_atime);
2939 mPUSHi(PL_statcache.st_mtime);
2940 mPUSHi(PL_statcache.st_ctime);
2942 #ifdef USE_STAT_BLOCKS
2943 mPUSHu(PL_statcache.st_blksize);
2944 mPUSHu(PL_statcache.st_blocks);
2946 PUSHs(newSVpvs_flags("", SVs_TEMP));
2947 PUSHs(newSVpvs_flags("", SVs_TEMP));
2953 #define tryAMAGICftest_MG(chr) STMT_START { \
2954 if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
2955 && S_try_amagic_ftest(aTHX_ chr)) \
2960 S_try_amagic_ftest(pTHX_ char chr) {
2963 SV* const arg = TOPs;
2968 if ((PL_op->op_flags & OPf_KIDS)
2971 const char tmpchr = chr;
2973 SV * const tmpsv = amagic_call(arg,
2974 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2975 ftest_amg, AMGf_unary);
2982 next = PL_op->op_next;
2983 if (next->op_type >= OP_FTRREAD &&
2984 next->op_type <= OP_FTBINARY &&
2985 next->op_private & OPpFT_STACKED
2988 /* leave the object alone */
3000 /* This macro is used by the stacked filetest operators :
3001 * if the previous filetest failed, short-circuit and pass its value.
3002 * Else, discard it from the stack and continue. --rgs
3004 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
3005 if (!SvTRUE(TOPs)) { RETURN; } \
3006 else { (void)POPs; PUTBACK; } \
3013 /* Not const, because things tweak this below. Not bool, because there's
3014 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
3015 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3016 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3017 /* Giving some sort of initial value silences compilers. */
3019 int access_mode = R_OK;
3021 int access_mode = 0;
3024 /* access_mode is never used, but leaving use_access in makes the
3025 conditional compiling below much clearer. */
3028 int stat_mode = S_IRUSR;
3030 bool effective = FALSE;
3034 switch (PL_op->op_type) {
3035 case OP_FTRREAD: opchar = 'R'; break;
3036 case OP_FTRWRITE: opchar = 'W'; break;
3037 case OP_FTREXEC: opchar = 'X'; break;
3038 case OP_FTEREAD: opchar = 'r'; break;
3039 case OP_FTEWRITE: opchar = 'w'; break;
3040 case OP_FTEEXEC: opchar = 'x'; break;
3042 tryAMAGICftest_MG(opchar);
3044 STACKED_FTEST_CHECK;
3046 switch (PL_op->op_type) {
3048 #if !(defined(HAS_ACCESS) && defined(R_OK))
3054 #if defined(HAS_ACCESS) && defined(W_OK)
3059 stat_mode = S_IWUSR;
3063 #if defined(HAS_ACCESS) && defined(X_OK)
3068 stat_mode = S_IXUSR;
3072 #ifdef PERL_EFF_ACCESS
3075 stat_mode = S_IWUSR;
3079 #ifndef PERL_EFF_ACCESS
3086 #ifdef PERL_EFF_ACCESS
3091 stat_mode = S_IXUSR;
3097 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3098 const char *name = POPpx;
3100 # ifdef PERL_EFF_ACCESS
3101 result = PERL_EFF_ACCESS(name, access_mode);
3103 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3109 result = access(name, access_mode);
3111 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3126 if (cando(stat_mode, effective, &PL_statcache))
3135 const int op_type = PL_op->op_type;
3140 case OP_FTIS: opchar = 'e'; break;
3141 case OP_FTSIZE: opchar = 's'; break;
3142 case OP_FTMTIME: opchar = 'M'; break;
3143 case OP_FTCTIME: opchar = 'C'; break;
3144 case OP_FTATIME: opchar = 'A'; break;
3146 tryAMAGICftest_MG(opchar);
3148 STACKED_FTEST_CHECK;
3154 if (op_type == OP_FTIS)
3157 /* You can't dTARGET inside OP_FTIS, because you'll get
3158 "panic: pad_sv po" - the op is not flagged to have a target. */
3162 #if Off_t_size > IVSIZE
3163 PUSHn(PL_statcache.st_size);
3165 PUSHi(PL_statcache.st_size);
3169 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3172 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3175 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3189 switch (PL_op->op_type) {
3190 case OP_FTROWNED: opchar = 'O'; break;
3191 case OP_FTEOWNED: opchar = 'o'; break;
3192 case OP_FTZERO: opchar = 'z'; break;
3193 case OP_FTSOCK: opchar = 'S'; break;
3194 case OP_FTCHR: opchar = 'c'; break;
3195 case OP_FTBLK: opchar = 'b'; break;
3196 case OP_FTFILE: opchar = 'f'; break;
3197 case OP_FTDIR: opchar = 'd'; break;
3198 case OP_FTPIPE: opchar = 'p'; break;
3199 case OP_FTSUID: opchar = 'u'; break;
3200 case OP_FTSGID: opchar = 'g'; break;
3201 case OP_FTSVTX: opchar = 'k'; break;
3203 tryAMAGICftest_MG(opchar);
3205 /* I believe that all these three are likely to be defined on most every
3206 system these days. */
3208 if(PL_op->op_type == OP_FTSUID)
3212 if(PL_op->op_type == OP_FTSGID)
3216 if(PL_op->op_type == OP_FTSVTX)
3220 STACKED_FTEST_CHECK;
3226 switch (PL_op->op_type) {
3228 if (PL_statcache.st_uid == PL_uid)
3232 if (PL_statcache.st_uid == PL_euid)
3236 if (PL_statcache.st_size == 0)
3240 if (S_ISSOCK(PL_statcache.st_mode))
3244 if (S_ISCHR(PL_statcache.st_mode))
3248 if (S_ISBLK(PL_statcache.st_mode))
3252 if (S_ISREG(PL_statcache.st_mode))
3256 if (S_ISDIR(PL_statcache.st_mode))
3260 if (S_ISFIFO(PL_statcache.st_mode))
3265 if (PL_statcache.st_mode & S_ISUID)
3271 if (PL_statcache.st_mode & S_ISGID)
3277 if (PL_statcache.st_mode & S_ISVTX)
3291 tryAMAGICftest_MG('l');
3292 result = my_lstat();
3297 if (S_ISLNK(PL_statcache.st_mode))
3310 tryAMAGICftest_MG('t');
3312 STACKED_FTEST_CHECK;
3314 if (PL_op->op_flags & OPf_REF)
3316 else if (isGV(TOPs))
3317 gv = MUTABLE_GV(POPs);
3318 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3319 gv = MUTABLE_GV(SvRV(POPs));
3321 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3323 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3324 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3325 else if (tmpsv && SvOK(tmpsv)) {
3326 const char *tmps = SvPV_nolen_const(tmpsv);
3334 if (PerlLIO_isatty(fd))
3339 #if defined(atarist) /* this will work with atariST. Configure will
3340 make guesses for other systems. */
3341 # define FILE_base(f) ((f)->_base)
3342 # define FILE_ptr(f) ((f)->_ptr)
3343 # define FILE_cnt(f) ((f)->_cnt)
3344 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3355 register STDCHAR *s;
3361 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3363 STACKED_FTEST_CHECK;
3365 if (PL_op->op_flags & OPf_REF)
3367 else if (isGV(TOPs))
3368 gv = MUTABLE_GV(POPs);
3369 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3370 gv = MUTABLE_GV(SvRV(POPs));
3376 if (gv == PL_defgv) {
3378 io = GvIO(PL_statgv);
3381 goto really_filename;
3386 PL_laststatval = -1;
3387 sv_setpvs(PL_statname, "");
3388 io = GvIO(PL_statgv);
3390 if (io && IoIFP(io)) {
3391 if (! PerlIO_has_base(IoIFP(io)))
3392 DIE(aTHX_ "-T and -B not implemented on filehandles");
3393 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3394 if (PL_laststatval < 0)
3396 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3397 if (PL_op->op_type == OP_FTTEXT)
3402 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3403 i = PerlIO_getc(IoIFP(io));
3405 (void)PerlIO_ungetc(IoIFP(io),i);
3407 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3409 len = PerlIO_get_bufsiz(IoIFP(io));
3410 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3411 /* sfio can have large buffers - limit to 512 */
3416 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3418 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3420 SETERRNO(EBADF,RMS_IFI);
3428 PL_laststype = OP_STAT;
3429 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3430 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3431 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3433 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3436 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3437 if (PL_laststatval < 0) {
3438 (void)PerlIO_close(fp);
3441 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3442 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3443 (void)PerlIO_close(fp);
3445 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3446 RETPUSHNO; /* special case NFS directories */
3447 RETPUSHYES; /* null file is anything */
3452 /* now scan s to look for textiness */
3453 /* XXX ASCII dependent code */
3455 #if defined(DOSISH) || defined(USEMYBINMODE)
3456 /* ignore trailing ^Z on short files */
3457 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3461 for (i = 0; i < len; i++, s++) {
3462 if (!*s) { /* null never allowed in text */
3467 else if (!(isPRINT(*s) || isSPACE(*s)))
3470 else if (*s & 128) {
3472 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3475 /* utf8 characters don't count as odd */
3476 if (UTF8_IS_START(*s)) {
3477 int ulen = UTF8SKIP(s);
3478 if (ulen < len - i) {
3480 for (j = 1; j < ulen; j++) {
3481 if (!UTF8_IS_CONTINUATION(s[j]))
3484 --ulen; /* loop does extra increment */
3494 *s != '\n' && *s != '\r' && *s != '\b' &&
3495 *s != '\t' && *s != '\f' && *s != 27)
3500 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3511 const char *tmps = NULL;
3515 SV * const sv = POPs;
3516 if (PL_op->op_flags & OPf_SPECIAL) {
3517 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3519 else if (isGV_with_GP(sv)) {
3520 gv = MUTABLE_GV(sv);
3522 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
3523 gv = MUTABLE_GV(SvRV(sv));
3526 tmps = SvPV_nolen_const(sv);
3530 if( !gv && (!tmps || !*tmps) ) {
3531 HV * const table = GvHVn(PL_envgv);
3534 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3535 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3537 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3542 deprecate("chdir('') or chdir(undef) as chdir()");
3543 tmps = SvPV_nolen_const(*svp);
3547 TAINT_PROPER("chdir");
3552 TAINT_PROPER("chdir");
3555 IO* const io = GvIO(gv);
3558 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3559 } else if (IoIFP(io)) {
3560 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3563 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3564 report_evil_fh(gv, io, PL_op->op_type);
3565 SETERRNO(EBADF, RMS_IFI);
3570 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3571 report_evil_fh(gv, io, PL_op->op_type);
3572 SETERRNO(EBADF,RMS_IFI);
3576 DIE(aTHX_ PL_no_func, "fchdir");
3580 PUSHi( PerlDir_chdir(tmps) >= 0 );
3582 /* Clear the DEFAULT element of ENV so we'll get the new value
3584 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3591 dVAR; dSP; dMARK; dTARGET;
3592 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3603 char * const tmps = POPpx;
3604 TAINT_PROPER("chroot");
3605 PUSHi( chroot(tmps) >= 0 );
3608 DIE(aTHX_ PL_no_func, "chroot");
3617 const char * const tmps2 = POPpconstx;
3618 const char * const tmps = SvPV_nolen_const(TOPs);
3619 TAINT_PROPER("rename");
3621 anum = PerlLIO_rename(tmps, tmps2);
3623 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3624 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3627 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3628 (void)UNLINK(tmps2);
3629 if (!(anum = link(tmps, tmps2)))
3630 anum = UNLINK(tmps);
3638 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3642 const int op_type = PL_op->op_type;
3646 if (op_type == OP_LINK)
3647 DIE(aTHX_ PL_no_func, "link");
3649 # ifndef HAS_SYMLINK
3650 if (op_type == OP_SYMLINK)
3651 DIE(aTHX_ PL_no_func, "symlink");
3655 const char * const tmps2 = POPpconstx;
3656 const char * const tmps = SvPV_nolen_const(TOPs);
3657 TAINT_PROPER(PL_op_desc[op_type]);
3659 # if defined(HAS_LINK)
3660 # if defined(HAS_SYMLINK)
3661 /* Both present - need to choose which. */
3662 (op_type == OP_LINK) ?
3663 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3665 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3666 PerlLIO_link(tmps, tmps2);
3669 # if defined(HAS_SYMLINK)
3670 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3671 symlink(tmps, tmps2);
3676 SETi( result >= 0 );
3683 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3695 char buf[MAXPATHLEN];
3698 #ifndef INCOMPLETE_TAINTS
3702 len = readlink(tmps, buf, sizeof(buf) - 1);
3710 RETSETUNDEF; /* just pretend it's a normal file */
3714 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3716 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3718 char * const save_filename = filename;
3723 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3725 PERL_ARGS_ASSERT_DOONELINER;
3727 Newx(cmdline, size, char);
3728 my_strlcpy(cmdline, cmd, size);
3729 my_strlcat(cmdline, " ", size);
3730 for (s = cmdline + strlen(cmdline); *filename; ) {
3734 if (s - cmdline < size)
3735 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3736 myfp = PerlProc_popen(cmdline, "r");
3740 SV * const tmpsv = sv_newmortal();
3741 /* Need to save/restore 'PL_rs' ?? */
3742 s = sv_gets(tmpsv, myfp, 0);
3743 (void)PerlProc_pclose(myfp);
3747 #ifdef HAS_SYS_ERRLIST
3752 /* you don't see this */
3753 const char * const errmsg =
3754 #ifdef HAS_SYS_ERRLIST
3762 if (instr(s, errmsg)) {
3769 #define EACCES EPERM
3771 if (instr(s, "cannot make"))
3772 SETERRNO(EEXIST,RMS_FEX);
3773 else if (instr(s, "existing file"))
3774 SETERRNO(EEXIST,RMS_FEX);
3775 else if (instr(s, "ile exists"))
3776 SETERRNO(EEXIST,RMS_FEX);
3777 else if (instr(s, "non-exist"))
3778 SETERRNO(ENOENT,RMS_FNF);
3779 else if (instr(s, "does not exist"))
3780 SETERRNO(ENOENT,RMS_FNF);
3781 else if (instr(s, "not empty"))
3782 SETERRNO(EBUSY,SS_DEVOFFLINE);
3783 else if (instr(s, "cannot access"))
3784 SETERRNO(EACCES,RMS_PRV);
3786 SETERRNO(EPERM,RMS_PRV);
3789 else { /* some mkdirs return no failure indication */
3790 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3791 if (PL_op->op_type == OP_RMDIR)
3796 SETERRNO(EACCES,RMS_PRV); /* a guess */
3805 /* This macro removes trailing slashes from a directory name.
3806 * Different operating and file systems take differently to
3807 * trailing slashes. According to POSIX 1003.1 1996 Edition
3808 * any number of trailing slashes should be allowed.
3809 * Thusly we snip them away so that even non-conforming
3810 * systems are happy.
3811 * We should probably do this "filtering" for all
3812 * the functions that expect (potentially) directory names:
3813 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3814 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3816 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3817 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3820 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3821 (tmps) = savepvn((tmps), (len)); \
3831 const int mode = (MAXARG > 1) ? POPi : 0777;
3833 TRIMSLASHES(tmps,len,copy);
3835 TAINT_PROPER("mkdir");
3837 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3841 SETi( dooneliner("mkdir", tmps) );
3842 oldumask = PerlLIO_umask(0);
3843 PerlLIO_umask(oldumask);
3844 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3859 TRIMSLASHES(tmps,len,copy);
3860 TAINT_PROPER("rmdir");
3862 SETi( PerlDir_rmdir(tmps) >= 0 );
3864 SETi( dooneliner("rmdir", tmps) );
3871 /* Directory calls. */
3875 #if defined(Direntry_t) && defined(HAS_READDIR)
3877 const char * const dirname = POPpconstx;
3878 GV * const gv = MUTABLE_GV(POPs);
3879 register IO * const io = GvIOn(gv);
3884 if ((IoIFP(io) || IoOFP(io)))
3885 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3886 "Opening filehandle %s also as a directory",
3889 PerlDir_close(IoDIRP(io));
3890 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3896 SETERRNO(EBADF,RMS_DIR);
3899 DIE(aTHX_ PL_no_dir_func, "opendir");
3906 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3907 DIE(aTHX_ PL_no_dir_func, "readdir");
3910 #if !defined(I_DIRENT) && !defined(VMS)
3911 Direntry_t *readdir (DIR *);
3917 const I32 gimme = GIMME;
3918 GV * const gv = MUTABLE_GV(POPs);
3919 register const Direntry_t *dp;
3920 register IO * const io = GvIOn(gv);
3922 if (!io || !IoDIRP(io)) {
3923 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3924 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3929 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3933 sv = newSVpvn(dp->d_name, dp->d_namlen);
3935 sv = newSVpv(dp->d_name, 0);
3937 #ifndef INCOMPLETE_TAINTS
3938 if (!(IoFLAGS(io) & IOf_UNTAINT))
3942 } while (gimme == G_ARRAY);
3944 if (!dp && gimme != G_ARRAY)
3951 SETERRNO(EBADF,RMS_ISI);
3952 if (GIMME == G_ARRAY)
3961 #if defined(HAS_TELLDIR) || defined(telldir)
3963 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3964 /* XXX netbsd still seemed to.
3965 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3966 --JHI 1999-Feb-02 */
3967 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3968 long telldir (DIR *);
3970 GV * const gv = MUTABLE_GV(POPs);
3971 register IO * const io = GvIOn(gv);
3973 if (!io || !IoDIRP(io)) {
3974 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3975 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3979 PUSHi( PerlDir_tell(IoDIRP(io)) );
3983 SETERRNO(EBADF,RMS_ISI);
3986 DIE(aTHX_ PL_no_dir_func, "telldir");
3993 #if defined(HAS_SEEKDIR) || defined(seekdir)
3995 const long along = POPl;
3996 GV * const gv = MUTABLE_GV(POPs);
3997 register IO * const io = GvIOn(gv);
3999 if (!io || !IoDIRP(io)) {
4000 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4001 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
4004 (void)PerlDir_seek(IoDIRP(io), along);
4009 SETERRNO(EBADF,RMS_ISI);
4012 DIE(aTHX_ PL_no_dir_func, "seekdir");
4019 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4021 GV * const gv = MUTABLE_GV(POPs);
4022 register IO * const io = GvIOn(gv);
4024 if (!io || !IoDIRP(io)) {
4025 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4026 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
4029 (void)PerlDir_rewind(IoDIRP(io));
4033 SETERRNO(EBADF,RMS_ISI);
4036 DIE(aTHX_ PL_no_dir_func, "rewinddir");
4043 #if defined(Direntry_t) && defined(HAS_READDIR)
4045 GV * const gv = MUTABLE_GV(POPs);
4046 register IO * const io = GvIOn(gv);
4048 if (!io || !IoDIRP(io)) {
4049 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4050 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
4053 #ifdef VOID_CLOSEDIR
4054 PerlDir_close(IoDIRP(io));
4056 if (PerlDir_close(IoDIRP(io)) < 0) {
4057 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4066 SETERRNO(EBADF,RMS_IFI);
4069 DIE(aTHX_ PL_no_dir_func, "closedir");
4074 /* Process control. */
4083 PERL_FLUSHALL_FOR_CHILD;
4084 childpid = PerlProc_fork();
4088 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
4090 SvREADONLY_off(GvSV(tmpgv));
4091 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4092 SvREADONLY_on(GvSV(tmpgv));
4094 #ifdef THREADS_HAVE_PIDS
4095 PL_ppid = (IV)getppid();
4097 #ifdef PERL_USES_PL_PIDSTATUS
4098 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4104 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4109 PERL_FLUSHALL_FOR_CHILD;
4110 childpid = PerlProc_fork();
4116 DIE(aTHX_ PL_no_func, "fork");
4124 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4129 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4130 childpid = wait4pid(-1, &argflags, 0);
4132 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4137 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4138 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4139 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4141 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4146 DIE(aTHX_ PL_no_func, "wait");
4153 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4155 const int optype = POPi;
4156 const Pid_t pid = TOPi;
4160 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4161 result = wait4pid(pid, &argflags, optype);
4163 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4168 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4169 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4170 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4172 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4177 DIE(aTHX_ PL_no_func, "waitpid");
4184 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4185 #if defined(__LIBCATAMOUNT__)
4186 PL_statusvalue = -1;
4195 while (++MARK <= SP) {
4196 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4201 TAINT_PROPER("system");
4203 PERL_FLUSHALL_FOR_CHILD;
4204 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4210 if (PerlProc_pipe(pp) >= 0)
4212 while ((childpid = PerlProc_fork()) == -1) {
4213 if (errno != EAGAIN) {
4218 PerlLIO_close(pp[0]);
4219 PerlLIO_close(pp[1]);
4226 Sigsave_t ihand,qhand; /* place to save signals during system() */
4230 PerlLIO_close(pp[1]);
4232 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4233 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4236 result = wait4pid(childpid, &status, 0);
4237 } while (result == -1 && errno == EINTR);
4239 (void)rsignal_restore(SIGINT, &ihand);
4240 (void)rsignal_restore(SIGQUIT, &qhand);
4242 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4243 do_execfree(); /* free any memory child malloced on fork */
4250 while (n < sizeof(int)) {
4251 n1 = PerlLIO_read(pp[0],
4252 (void*)(((char*)&errkid)+n),
4258 PerlLIO_close(pp[0]);
4259 if (n) { /* Error */
4260 if (n != sizeof(int))
4261 DIE(aTHX_ "panic: kid popen errno read");
4262 errno = errkid; /* Propagate errno from kid */
4263 STATUS_NATIVE_CHILD_SET(-1);
4266 XPUSHi(STATUS_CURRENT);
4270 PerlLIO_close(pp[0]);
4271 #if defined(HAS_FCNTL) && defined(F_SETFD)
4272 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4275 if (PL_op->op_flags & OPf_STACKED) {
4276 SV * const really = *++MARK;
4277 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4279 else if (SP - MARK != 1)
4280 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4282 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4286 #else /* ! FORK or VMS or OS/2 */
4289 if (PL_op->op_flags & OPf_STACKED) {
4290 SV * const really = *++MARK;
4291 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4292 value = (I32)do_aspawn(really, MARK, SP);
4294 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4297 else if (SP - MARK != 1) {
4298 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4299 value = (I32)do_aspawn(NULL, MARK, SP);
4301 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4305 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4307 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4309 STATUS_NATIVE_CHILD_SET(value);
4312 XPUSHi(result ? value : STATUS_CURRENT);
4313 #endif /* !FORK or VMS or OS/2 */
4320 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4325 while (++MARK <= SP) {
4326 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4331 TAINT_PROPER("exec");
4333 PERL_FLUSHALL_FOR_CHILD;
4334 if (PL_op->op_flags & OPf_STACKED) {
4335 SV * const really = *++MARK;
4336 value = (I32)do_aexec(really, MARK, SP);
4338 else if (SP - MARK != 1)
4340 value = (I32)vms_do_aexec(NULL, MARK, SP);
4344 (void ) do_aspawn(NULL, MARK, SP);
4348 value = (I32)do_aexec(NULL, MARK, SP);
4353 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4356 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4359 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4373 # ifdef THREADS_HAVE_PIDS
4374 if (PL_ppid != 1 && getppid() == 1)
4375 /* maybe the parent process has died. Refresh ppid cache */
4379 XPUSHi( getppid() );
4383 DIE(aTHX_ PL_no_func, "getppid");
4393 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4396 pgrp = (I32)BSD_GETPGRP(pid);
4398 if (pid != 0 && pid != PerlProc_getpid())
4399 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4405 DIE(aTHX_ PL_no_func, "getpgrp()");
4426 TAINT_PROPER("setpgrp");
4428 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4430 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4431 || (pid != 0 && pid != PerlProc_getpid()))
4433 DIE(aTHX_ "setpgrp can't take arguments");
4435 SETi( setpgrp() >= 0 );
4436 #endif /* USE_BSDPGRP */
4439 DIE(aTHX_ PL_no_func, "setpgrp()");
4446 #ifdef HAS_GETPRIORITY
4448 const int who = POPi;
4449 const int which = TOPi;
4450 SETi( getpriority(which, who) );
4453 DIE(aTHX_ PL_no_func, "getpriority()");
4460 #ifdef HAS_SETPRIORITY
4462 const int niceval = POPi;
4463 const int who = POPi;
4464 const int which = TOPi;
4465 TAINT_PROPER("setpriority");
4466 SETi( setpriority(which, who, niceval) >= 0 );
4469 DIE(aTHX_ PL_no_func, "setpriority()");
4480 XPUSHn( time(NULL) );
4482 XPUSHi( time(NULL) );
4494 (void)PerlProc_times(&PL_timesbuf);
4496 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4497 /* struct tms, though same data */
4501 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4502 if (GIMME == G_ARRAY) {
4503 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4504 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4505 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4513 if (GIMME == G_ARRAY) {
4520 DIE(aTHX_ "times not implemented");
4523 #endif /* HAS_TIMES */
4526 /* The 32 bit int year limits the times we can represent to these
4527 boundaries with a few days wiggle room to account for time zone
4530 /* Sat Jan 3 00:00:00 -2147481748 */
4531 #define TIME_LOWER_BOUND -67768100567755200.0
4532 /* Sun Dec 29 12:00:00 2147483647 */
4533 #define TIME_UPPER_BOUND 67767976233316800.0
4542 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4543 static const char * const dayname[] =
4544 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4545 static const char * const monname[] =
4546 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4547 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4552 when = (Time64_T)now;
4555 NV input = Perl_floor(POPn);
4556 when = (Time64_T)input;
4557 if (when != input) {
4558 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4559 "%s(%.0" NVff ") too large", opname, input);
4563 if ( TIME_LOWER_BOUND > when ) {
4564 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4565 "%s(%.0" NVff ") too small", opname, when);
4568 else if( when > TIME_UPPER_BOUND ) {
4569 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4570 "%s(%.0" NVff ") too large", opname, when);
4574 if (PL_op->op_type == OP_LOCALTIME)
4575 err = S_localtime64_r(&when, &tmbuf);
4577 err = S_gmtime64_r(&when, &tmbuf);
4581 /* XXX %lld broken for quads */
4582 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4583 "%s(%.0" NVff ") failed", opname, when);
4586 if (GIMME != G_ARRAY) { /* scalar context */
4588 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4589 double year = (double)tmbuf.tm_year + 1900;
4596 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4597 dayname[tmbuf.tm_wday],
4598 monname[tmbuf.tm_mon],
4606 else { /* list context */
4612 mPUSHi(tmbuf.tm_sec);
4613 mPUSHi(tmbuf.tm_min);
4614 mPUSHi(tmbuf.tm_hour);
4615 mPUSHi(tmbuf.tm_mday);
4616 mPUSHi(tmbuf.tm_mon);
4617 mPUSHn(tmbuf.tm_year);
4618 mPUSHi(tmbuf.tm_wday);
4619 mPUSHi(tmbuf.tm_yday);
4620 mPUSHi(tmbuf.tm_isdst);
4631 anum = alarm((unsigned int)anum);
4638 DIE(aTHX_ PL_no_func, "alarm");
4650 (void)time(&lasttime);
4655 PerlProc_sleep((unsigned int)duration);
4658 XPUSHi(when - lasttime);
4662 /* Shared memory. */
4663 /* Merged with some message passing. */
4667 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4668 dVAR; dSP; dMARK; dTARGET;
4669 const int op_type = PL_op->op_type;
4674 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4677 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4680 value = (I32)(do_semop(MARK, SP) >= 0);
4683 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4699 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4700 dVAR; dSP; dMARK; dTARGET;
4701 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4708 DIE(aTHX_ "System V IPC is not implemented on this machine");
4715 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4716 dVAR; dSP; dMARK; dTARGET;
4717 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4725 PUSHp(zero_but_true, ZBTLEN);
4733 /* I can't const this further without getting warnings about the types of
4734 various arrays passed in from structures. */
4736 S_space_join_names_mortal(pTHX_ char *const *array)
4740 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4742 if (array && *array) {
4743 target = newSVpvs_flags("", SVs_TEMP);
4745 sv_catpv(target, *array);
4748 sv_catpvs(target, " ");
4751 target = sv_mortalcopy(&PL_sv_no);
4756 /* Get system info. */
4760 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4762 I32 which = PL_op->op_type;
4763 register char **elem;
4765 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4766 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4767 struct hostent *gethostbyname(Netdb_name_t);
4768 struct hostent *gethostent(void);
4770 struct hostent *hent = NULL;
4774 if (which == OP_GHBYNAME) {
4775 #ifdef HAS_GETHOSTBYNAME
4776 const char* const name = POPpbytex;
4777 hent = PerlSock_gethostbyname(name);
4779 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4782 else if (which == OP_GHBYADDR) {
4783 #ifdef HAS_GETHOSTBYADDR
4784 const int addrtype = POPi;
4785 SV * const addrsv = POPs;
4787 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4789 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4791 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4795 #ifdef HAS_GETHOSTENT
4796 hent = PerlSock_gethostent();
4798 DIE(aTHX_ PL_no_sock_func, "gethostent");
4801 #ifdef HOST_NOT_FOUND
4803 #ifdef USE_REENTRANT_API
4804 # ifdef USE_GETHOSTENT_ERRNO
4805 h_errno = PL_reentrant_buffer->_gethostent_errno;
4808 STATUS_UNIX_SET(h_errno);
4812 if (GIMME != G_ARRAY) {
4813 PUSHs(sv = sv_newmortal());
4815 if (which == OP_GHBYNAME) {
4817 sv_setpvn(sv, hent->h_addr, hent->h_length);
4820 sv_setpv(sv, (char*)hent->h_name);
4826 mPUSHs(newSVpv((char*)hent->h_name, 0));
4827 PUSHs(space_join_names_mortal(hent->h_aliases));
4828 mPUSHi(hent->h_addrtype);
4829 len = hent->h_length;
4832 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4833 mXPUSHp(*elem, len);
4837 mPUSHp(hent->h_addr, len);
4839 PUSHs(sv_mortalcopy(&PL_sv_no));
4844 DIE(aTHX_ PL_no_sock_func, "gethostent");
4851 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4853 I32 which = PL_op->op_type;
4855 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4856 struct netent *getnetbyaddr(Netdb_net_t, int);
4857 struct netent *getnetbyname(Netdb_name_t);
4858 struct netent *getnetent(void);
4860 struct netent *nent;
4862 if (which == OP_GNBYNAME){
4863 #ifdef HAS_GETNETBYNAME
4864 const char * const name = POPpbytex;
4865 nent = PerlSock_getnetbyname(name);
4867 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4870 else if (which == OP_GNBYADDR) {
4871 #ifdef HAS_GETNETBYADDR
4872 const int addrtype = POPi;
4873 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4874 nent = PerlSock_getnetbyaddr(addr, addrtype);
4876 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4880 #ifdef HAS_GETNETENT
4881 nent = PerlSock_getnetent();
4883 DIE(aTHX_ PL_no_sock_func, "getnetent");
4886 #ifdef HOST_NOT_FOUND
4888 #ifdef USE_REENTRANT_API
4889 # ifdef USE_GETNETENT_ERRNO
4890 h_errno = PL_reentrant_buffer->_getnetent_errno;
4893 STATUS_UNIX_SET(h_errno);
4898 if (GIMME != G_ARRAY) {
4899 PUSHs(sv = sv_newmortal());
4901 if (which == OP_GNBYNAME)
4902 sv_setiv(sv, (IV)nent->n_net);
4904 sv_setpv(sv, nent->n_name);
4910 mPUSHs(newSVpv(nent->n_name, 0));
4911 PUSHs(space_join_names_mortal(nent->n_aliases));
4912 mPUSHi(nent->n_addrtype);
4913 mPUSHi(nent->n_net);
4918 DIE(aTHX_ PL_no_sock_func, "getnetent");
4925 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4927 I32 which = PL_op->op_type;
4929 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4930 struct protoent *getprotobyname(Netdb_name_t);
4931 struct protoent *getprotobynumber(int);
4932 struct protoent *getprotoent(void);
4934 struct protoent *pent;
4936 if (which == OP_GPBYNAME) {
4937 #ifdef HAS_GETPROTOBYNAME
4938 const char* const name = POPpbytex;
4939 pent = PerlSock_getprotobyname(name);
4941 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4944 else if (which == OP_GPBYNUMBER) {
4945 #ifdef HAS_GETPROTOBYNUMBER
4946 const int number = POPi;
4947 pent = PerlSock_getprotobynumber(number);
4949 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4953 #ifdef HAS_GETPROTOENT
4954 pent = PerlSock_getprotoent();
4956 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4960 if (GIMME != G_ARRAY) {
4961 PUSHs(sv = sv_newmortal());
4963 if (which == OP_GPBYNAME)
4964 sv_setiv(sv, (IV)pent->p_proto);
4966 sv_setpv(sv, pent->p_name);
4972 mPUSHs(newSVpv(pent->p_name, 0));
4973 PUSHs(space_join_names_mortal(pent->p_aliases));
4974 mPUSHi(pent->p_proto);
4979 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4986 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4988 I32 which = PL_op->op_type;
4990 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4991 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4992 struct servent *getservbyport(int, Netdb_name_t);
4993 struct servent *getservent(void);
4995 struct servent *sent;
4997 if (which == OP_GSBYNAME) {
4998 #ifdef HAS_GETSERVBYNAME
4999 const char * const proto = POPpbytex;
5000 const char * const name = POPpbytex;
5001 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5003 DIE(aTHX_ PL_no_sock_func, "getservbyname");
5006 else if (which == OP_GSBYPORT) {
5007 #ifdef HAS_GETSERVBYPORT
5008 const char * const proto = POPpbytex;
5009 unsigned short port = (unsigned short)POPu;
5011 port = PerlSock_htons(port);
5013 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5015 DIE(aTHX_ PL_no_sock_func, "getservbyport");
5019 #ifdef HAS_GETSERVENT
5020 sent = PerlSock_getservent();
5022 DIE(aTHX_ PL_no_sock_func, "getservent");
5026 if (GIMME != G_ARRAY) {
5027 PUSHs(sv = sv_newmortal());
5029 if (which == OP_GSBYNAME) {
5031 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5033 sv_setiv(sv, (IV)(sent->s_port));
5037 sv_setpv(sv, sent->s_name);
5043 mPUSHs(newSVpv(sent->s_name, 0));
5044 PUSHs(space_join_names_mortal(sent->s_aliases));
5046 mPUSHi(PerlSock_ntohs(sent->s_port));
5048 mPUSHi(sent->s_port);
5050 mPUSHs(newSVpv(sent->s_proto, 0));
5055 DIE(aTHX_ PL_no_sock_func, "getservent");
5062 #ifdef HAS_SETHOSTENT
5064 PerlSock_sethostent(TOPi);
5067 DIE(aTHX_ PL_no_sock_func, "sethostent");
5074 #ifdef HAS_SETNETENT
5076 (void)PerlSock_setnetent(TOPi);
5079 DIE(aTHX_ PL_no_sock_func, "setnetent");
5086 #ifdef HAS_SETPROTOENT
5088 (void)PerlSock_setprotoent(TOPi);
5091 DIE(aTHX_ PL_no_sock_func, "setprotoent");
5098 #ifdef HAS_SETSERVENT
5100 (void)PerlSock_setservent(TOPi);
5103 DIE(aTHX_ PL_no_sock_func, "setservent");
5110 #ifdef HAS_ENDHOSTENT
5112 PerlSock_endhostent();
5116 DIE(aTHX_ PL_no_sock_func, "endhostent");
5123 #ifdef HAS_ENDNETENT
5125 PerlSock_endnetent();
5129 DIE(aTHX_ PL_no_sock_func, "endnetent");
5136 #ifdef HAS_ENDPROTOENT
5138 PerlSock_endprotoent();
5142 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5149 #ifdef HAS_ENDSERVENT
5151 PerlSock_endservent();
5155 DIE(aTHX_ PL_no_sock_func, "endservent");
5164 I32 which = PL_op->op_type;
5166 struct passwd *pwent = NULL;
5168 * We currently support only the SysV getsp* shadow password interface.
5169 * The interface is declared in <shadow.h> and often one needs to link
5170 * with -lsecurity or some such.
5171 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5174 * AIX getpwnam() is clever enough to return the encrypted password
5175 * only if the caller (euid?) is root.
5177 * There are at least three other shadow password APIs. Many platforms
5178 * seem to contain more than one interface for accessing the shadow
5179 * password databases, possibly for compatibility reasons.
5180 * The getsp*() is by far he simplest one, the other two interfaces
5181 * are much more complicated, but also very similar to each other.
5186 * struct pr_passwd *getprpw*();
5187 * The password is in
5188 * char getprpw*(...).ufld.fd_encrypt[]
5189 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5194 * struct es_passwd *getespw*();
5195 * The password is in
5196 * char *(getespw*(...).ufld.fd_encrypt)
5197 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5200 * struct userpw *getuserpw();
5201 * The password is in
5202 * char *(getuserpw(...)).spw_upw_passwd
5203 * (but the de facto standard getpwnam() should work okay)
5205 * Mention I_PROT here so that Configure probes for it.
5207 * In HP-UX for getprpw*() the manual page claims that one should include
5208 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5209 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5210 * and pp_sys.c already includes <shadow.h> if there is such.
5212 * Note that <sys/security.h> is already probed for, but currently
5213 * it is only included in special cases.
5215 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5216 * be preferred interface, even though also the getprpw*() interface
5217 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5218 * One also needs to call set_auth_parameters() in main() before
5219 * doing anything else, whether one is using getespw*() or getprpw*().
5221 * Note that accessing the shadow databases can be magnitudes
5222 * slower than accessing the standard databases.
5227 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5228 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5229 * the pw_comment is left uninitialized. */
5230 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5236 const char* const name = POPpbytex;
5237 pwent = getpwnam(name);
5243 pwent = getpwuid(uid);
5247 # ifdef HAS_GETPWENT
5249 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5250 if (pwent) pwent = getpwnam(pwent->pw_name);
5253 DIE(aTHX_ PL_no_func, "getpwent");
5259 if (GIMME != G_ARRAY) {
5260 PUSHs(sv = sv_newmortal());
5262 if (which == OP_GPWNAM)
5263 # if Uid_t_sign <= 0
5264 sv_setiv(sv, (IV)pwent->pw_uid);
5266 sv_setuv(sv, (UV)pwent->pw_uid);
5269 sv_setpv(sv, pwent->pw_name);
5275 mPUSHs(newSVpv(pwent->pw_name, 0));
5279 /* If we have getspnam(), we try to dig up the shadow
5280 * password. If we are underprivileged, the shadow
5281 * interface will set the errno to EACCES or similar,
5282 * and return a null pointer. If this happens, we will
5283 * use the dummy password (usually "*" or "x") from the
5284 * standard password database.
5286 * In theory we could skip the shadow call completely
5287 * if euid != 0 but in practice we cannot know which
5288 * security measures are guarding the shadow databases
5289 * on a random platform.
5291 * Resist the urge to use additional shadow interfaces.
5292 * Divert the urge to writing an extension instead.
5295 /* Some AIX setups falsely(?) detect some getspnam(), which
5296 * has a different API than the Solaris/IRIX one. */
5297 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5300 const struct spwd * const spwent = getspnam(pwent->pw_name);
5301 /* Save and restore errno so that
5302 * underprivileged attempts seem
5303 * to have never made the unsccessful
5304 * attempt to retrieve the shadow password. */
5306 if (spwent && spwent->sp_pwdp)
5307 sv_setpv(sv, spwent->sp_pwdp);
5311 if (!SvPOK(sv)) /* Use the standard password, then. */
5312 sv_setpv(sv, pwent->pw_passwd);
5315 # ifndef INCOMPLETE_TAINTS
5316 /* passwd is tainted because user himself can diddle with it.
5317 * admittedly not much and in a very limited way, but nevertheless. */
5321 # if Uid_t_sign <= 0
5322 mPUSHi(pwent->pw_uid);
5324 mPUSHu(pwent->pw_uid);
5327 # if Uid_t_sign <= 0
5328 mPUSHi(pwent->pw_gid);
5330 mPUSHu(pwent->pw_gid);
5332 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5333 * because of the poor interface of the Perl getpw*(),
5334 * not because there's some standard/convention saying so.
5335 * A better interface would have been to return a hash,
5336 * but we are accursed by our history, alas. --jhi. */
5338 mPUSHi(pwent->pw_change);
5341 mPUSHi(pwent->pw_quota);
5344 mPUSHs(newSVpv(pwent->pw_age, 0));
5346 /* I think that you can never get this compiled, but just in case. */
5347 PUSHs(sv_mortalcopy(&PL_sv_no));
5352 /* pw_class and pw_comment are mutually exclusive--.
5353 * see the above note for pw_change, pw_quota, and pw_age. */
5355 mPUSHs(newSVpv(pwent->pw_class, 0));
5358 mPUSHs(newSVpv(pwent->pw_comment, 0));
5360 /* I think that you can never get this compiled, but just in case. */
5361 PUSHs(sv_mortalcopy(&PL_sv_no));
5366 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5368 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5370 # ifndef INCOMPLETE_TAINTS
5371 /* pw_gecos is tainted because user himself can diddle with it. */
5375 mPUSHs(newSVpv(pwent->pw_dir, 0));
5377 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5378 # ifndef INCOMPLETE_TAINTS
5379 /* pw_shell is tainted because user himself can diddle with it. */
5384 mPUSHi(pwent->pw_expire);
5389 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5396 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5401 DIE(aTHX_ PL_no_func, "setpwent");
5408 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5413 DIE(aTHX_ PL_no_func, "endpwent");
5422 const I32 which = PL_op->op_type;
5423 const struct group *grent;
5425 if (which == OP_GGRNAM) {
5426 const char* const name = POPpbytex;
5427 grent = (const struct group *)getgrnam(name);
5429 else if (which == OP_GGRGID) {
5430 const Gid_t gid = POPi;
5431 grent = (const struct group *)getgrgid(gid);
5435 grent = (struct group *)getgrent();
5437 DIE(aTHX_ PL_no_func, "getgrent");
5441 if (GIMME != G_ARRAY) {
5442 SV * const sv = sv_newmortal();
5446 if (which == OP_GGRNAM)
5448 sv_setiv(sv, (IV)grent->gr_gid);
5450 sv_setuv(sv, (UV)grent->gr_gid);
5453 sv_setpv(sv, grent->gr_name);
5459 mPUSHs(newSVpv(grent->gr_name, 0));
5462 mPUSHs(newSVpv(grent->gr_passwd, 0));
5464 PUSHs(sv_mortalcopy(&PL_sv_no));
5468 mPUSHi(grent->gr_gid);
5470 mPUSHu(grent->gr_gid);
5473 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5474 /* In UNICOS/mk (_CRAYMPP) the multithreading
5475 * versions (getgrnam_r, getgrgid_r)
5476 * seem to return an illegal pointer
5477 * as the group members list, gr_mem.
5478 * getgrent() doesn't even have a _r version
5479 * but the gr_mem is poisonous anyway.
5480 * So yes, you cannot get the list of group
5481 * members if building multithreaded in UNICOS/mk. */
5482 PUSHs(space_join_names_mortal(grent->gr_mem));
5488 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5495 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5500 DIE(aTHX_ PL_no_func, "setgrent");
5507 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5512 DIE(aTHX_ PL_no_func, "endgrent");
5523 if (!(tmps = PerlProc_getlogin()))
5525 PUSHp(tmps, strlen(tmps));
5528 DIE(aTHX_ PL_no_func, "getlogin");
5533 /* Miscellaneous. */
5538 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5539 register I32 items = SP - MARK;
5540 unsigned long a[20];
5545 while (++MARK <= SP) {
5546 if (SvTAINTED(*MARK)) {
5552 TAINT_PROPER("syscall");
5555 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5556 * or where sizeof(long) != sizeof(char*). But such machines will
5557 * not likely have syscall implemented either, so who cares?
5559 while (++MARK <= SP) {
5560 if (SvNIOK(*MARK) || !i)
5561 a[i++] = SvIV(*MARK);
5562 else if (*MARK == &PL_sv_undef)
5565 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5571 DIE(aTHX_ "Too many args to syscall");
5573 DIE(aTHX_ "Too few args to syscall");
5575 retval = syscall(a[0]);
5578 retval = syscall(a[0],a[1]);
5581 retval = syscall(a[0],a[1],a[2]);
5584 retval = syscall(a[0],a[1],a[2],a[3]);
5587 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5590 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5593 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5596 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5600 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5603 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5606 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5610 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5614 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5618 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5619 a[10],a[11],a[12],a[13]);
5621 #endif /* atarist */
5627 DIE(aTHX_ PL_no_func, "syscall");
5632 #ifdef FCNTL_EMULATE_FLOCK
5634 /* XXX Emulate flock() with fcntl().
5635 What's really needed is a good file locking module.
5639 fcntl_emulate_flock(int fd, int operation)
5644 switch (operation & ~LOCK_NB) {
5646 flock.l_type = F_RDLCK;
5649 flock.l_type = F_WRLCK;
5652 flock.l_type = F_UNLCK;
5658 flock.l_whence = SEEK_SET;
5659 flock.l_start = flock.l_len = (Off_t)0;
5661 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5662 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5663 errno = EWOULDBLOCK;
5667 #endif /* FCNTL_EMULATE_FLOCK */
5669 #ifdef LOCKF_EMULATE_FLOCK
5671 /* XXX Emulate flock() with lockf(). This is just to increase
5672 portability of scripts. The calls are not completely
5673 interchangeable. What's really needed is a good file
5677 /* The lockf() constants might have been defined in <unistd.h>.
5678 Unfortunately, <unistd.h> causes troubles on some mixed
5679 (BSD/POSIX) systems, such as SunOS 4.1.3.
5681 Further, the lockf() constants aren't POSIX, so they might not be
5682 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5683 just stick in the SVID values and be done with it. Sigh.
5687 # define F_ULOCK 0 /* Unlock a previously locked region */
5690 # define F_LOCK 1 /* Lock a region for exclusive use */
5693 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5696 # define F_TEST 3 /* Test a region for other processes locks */
5700 lockf_emulate_flock(int fd, int operation)
5706 /* flock locks entire file so for lockf we need to do the same */
5707 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5708 if (pos > 0) /* is seekable and needs to be repositioned */
5709 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5710 pos = -1; /* seek failed, so don't seek back afterwards */
5713 switch (operation) {
5715 /* LOCK_SH - get a shared lock */
5717 /* LOCK_EX - get an exclusive lock */
5719 i = lockf (fd, F_LOCK, 0);
5722 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5723 case LOCK_SH|LOCK_NB:
5724 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5725 case LOCK_EX|LOCK_NB:
5726 i = lockf (fd, F_TLOCK, 0);
5728 if ((errno == EAGAIN) || (errno == EACCES))
5729 errno = EWOULDBLOCK;
5732 /* LOCK_UN - unlock (non-blocking is a no-op) */
5734 case LOCK_UN|LOCK_NB:
5735 i = lockf (fd, F_ULOCK, 0);
5738 /* Default - can't decipher operation */
5745 if (pos > 0) /* need to restore position of the handle */
5746 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5751 #endif /* LOCKF_EMULATE_FLOCK */
5755 * c-indentation-style: bsd
5757 * indent-tabs-mode: t
5760 * ex: set ts=8 sts=4 sw=4 noet: