3 * Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 * 2004, 2005, 2006, 2007 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.
18 /* This file contains system pp ("push/pop") functions that
19 * execute the opcodes that make up a perl program. A typical pp function
20 * expects to find its arguments on the stack, and usually pushes its
21 * results onto the stack, hence the 'pp' terminology. Each OP structure
22 * contains a pointer to the relevant pp_foo() function.
24 * By 'system', we mean ops which interact with the OS, such as pp_open().
28 #define PERL_IN_PP_SYS_C
32 /* Shadow password support for solaris - pdo@cs.umd.edu
33 * Not just Solaris: at least HP-UX, IRIX, Linux.
34 * The API is from SysV.
36 * There are at least two more shadow interfaces,
37 * see the comments in pp_gpwent().
41 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
42 * and another MAXINT from "perl.h" <- <sys/param.h>. */
49 # include <sys/wait.h>
53 # include <sys/resource.h>
62 # include <sys/select.h>
66 /* XXX Configure test needed.
67 h_errno might not be a simple 'int', especially for multi-threaded
68 applications, see "extern int errno in perl.h". Creating such
69 a test requires taking into account the differences between
70 compiling multithreaded and singlethreaded ($ccflags et al).
71 HOST_NOT_FOUND is typically defined in <netdb.h>.
73 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
82 struct passwd *getpwnam (char *);
83 struct passwd *getpwuid (Uid_t);
88 struct passwd *getpwent (void);
89 #elif defined (VMS) && defined (my_getpwent)
90 struct passwd *Perl_my_getpwent (pTHX);
99 struct group *getgrnam (char *);
100 struct group *getgrgid (Gid_t);
104 struct group *getgrent (void);
110 # if defined(_MSC_VER) || defined(__MINGW32__)
111 # include <sys/utime.h>
118 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
121 # define my_chsize PerlLIO_chsize
124 # define my_chsize PerlLIO_chsize
126 I32 my_chsize(int fd, Off_t length);
132 #else /* no flock() */
134 /* fcntl.h might not have been included, even if it exists, because
135 the current Configure only sets I_FCNTL if it's needed to pick up
136 the *_OK constants. Make sure it has been included before testing
137 the fcntl() locking constants. */
138 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
142 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
143 # define FLOCK fcntl_emulate_flock
144 # define FCNTL_EMULATE_FLOCK
145 # else /* no flock() or fcntl(F_SETLK,...) */
147 # define FLOCK lockf_emulate_flock
148 # define LOCKF_EMULATE_FLOCK
150 # endif /* no flock() or fcntl(F_SETLK,...) */
153 static int FLOCK (int, int);
156 * These are the flock() constants. Since this sytems doesn't have
157 * flock(), the values of the constants are probably not available.
171 # endif /* emulating flock() */
173 #endif /* no flock() */
176 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
178 #if defined(I_SYS_ACCESS) && !defined(R_OK)
179 # include <sys/access.h>
182 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
183 # define FD_CLOEXEC 1 /* NeXT needs this */
189 /* Missing protos on LynxOS */
190 void sethostent(int);
191 void endhostent(void);
193 void endnetent(void);
194 void setprotoent(int);
195 void endprotoent(void);
196 void setservent(int);
197 void endservent(void);
200 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
202 /* AIX 5.2 and below use mktime for localtime, and defines the edge case
203 * for time 0x7fffffff to be valid only in UTC. AIX 5.3 provides localtime64
204 * available in the 32bit environment, which could warrant Configure
205 * checks in the future.
208 #define LOCALTIME_EDGECASE_BROKEN
211 /* F_OK unused: if stat() cannot find it... */
213 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
214 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
215 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
218 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
219 # ifdef I_SYS_SECURITY
220 # include <sys/security.h>
224 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
227 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
231 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
233 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
237 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
238 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
239 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
242 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
244 const Uid_t ruid = getuid();
245 const Uid_t euid = geteuid();
246 const Gid_t rgid = getgid();
247 const Gid_t egid = getegid();
251 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
252 Perl_croak(aTHX_ "switching effective uid is not implemented");
255 if (setreuid(euid, ruid))
258 if (setresuid(euid, ruid, (Uid_t)-1))
261 Perl_croak(aTHX_ "entering effective uid failed");
264 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
265 Perl_croak(aTHX_ "switching effective gid is not implemented");
268 if (setregid(egid, rgid))
271 if (setresgid(egid, rgid, (Gid_t)-1))
274 Perl_croak(aTHX_ "entering effective gid failed");
277 res = access(path, mode);
280 if (setreuid(ruid, euid))
283 if (setresuid(ruid, euid, (Uid_t)-1))
286 Perl_croak(aTHX_ "leaving effective uid failed");
289 if (setregid(rgid, egid))
292 if (setresgid(rgid, egid, (Gid_t)-1))
295 Perl_croak(aTHX_ "leaving effective gid failed");
300 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
307 const char * const tmps = POPpconstx;
308 const I32 gimme = GIMME_V;
309 const char *mode = "r";
312 if (PL_op->op_private & OPpOPEN_IN_RAW)
314 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
316 fp = PerlProc_popen(tmps, mode);
318 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
320 PerlIO_apply_layers(aTHX_ fp,mode,type);
322 if (gimme == G_VOID) {
324 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
327 else if (gimme == G_SCALAR) {
330 PL_rs = &PL_sv_undef;
331 sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */
332 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
340 SV * const sv = newSV(79);
341 if (sv_gets(sv, fp, 0) == NULL) {
346 if (SvLEN(sv) - SvCUR(sv) > 20) {
347 SvPV_shrink_to_cur(sv);
352 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
353 TAINT; /* "I believe that this is not gratuitous!" */
356 STATUS_NATIVE_CHILD_SET(-1);
357 if (gimme == G_SCALAR)
368 tryAMAGICunTARGET(iter, -1);
370 /* Note that we only ever get here if File::Glob fails to load
371 * without at the same time croaking, for some reason, or if
372 * perl was built with PERL_EXTERNAL_GLOB */
379 * The external globbing program may use things we can't control,
380 * so for security reasons we must assume the worst.
383 taint_proper(PL_no_security, "glob");
387 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
388 PL_last_in_gv = (GV*)*PL_stack_sp--;
390 SAVESPTR(PL_rs); /* This is not permanent, either. */
391 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
394 *SvPVX(PL_rs) = '\n';
398 result = do_readline();
406 PL_last_in_gv = cGVOP_gv;
407 return do_readline();
418 do_join(TARG, &PL_sv_no, MARK, SP);
422 else if (SP == MARK) {
430 tmps = SvPV_const(tmpsv, len);
431 if ((!tmps || !len) && PL_errgv) {
432 SV * const error = ERRSV;
433 SvUPGRADE(error, SVt_PV);
434 if (SvPOK(error) && SvCUR(error))
435 sv_catpvs(error, "\t...caught");
437 tmps = SvPV_const(tmpsv, len);
440 tmpsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
442 Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv));
454 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
456 if (SP - MARK != 1) {
458 do_join(TARG, &PL_sv_no, MARK, SP);
460 tmps = SvPV_const(tmpsv, len);
466 tmps = SvROK(tmpsv) ? (const char *)NULL : SvPV_const(tmpsv, len);
469 SV * const error = ERRSV;
470 SvUPGRADE(error, SVt_PV);
471 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
473 SvSetSV(error,tmpsv);
474 else if (sv_isobject(error)) {
475 HV * const stash = SvSTASH(SvRV(error));
476 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
478 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
479 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
486 call_sv((SV*)GvCV(gv),
487 G_SCALAR|G_EVAL|G_KEEPERR);
488 sv_setsv(error,*PL_stack_sp--);
494 if (SvPOK(error) && SvCUR(error))
495 sv_catpvs(error, "\t...propagated");
498 tmps = SvPV_const(tmpsv, len);
504 tmpsv = newSVpvs_flags("Died", SVs_TEMP);
506 DIE(aTHX_ "%"SVf, SVfARG(tmpsv));
522 GV * const gv = (GV *)*++MARK;
525 DIE(aTHX_ PL_no_usym, "filehandle");
527 if ((io = GvIOp(gv))) {
529 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
531 if (IoDIRP(io) && ckWARN2(WARN_IO, WARN_DEPRECATED))
532 Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
533 "Opening dirhandle %s also as a file", GvENAME(gv));
535 mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
537 /* Method's args are same as ours ... */
538 /* ... except handle is replaced by the object */
539 *MARK-- = SvTIED_obj((SV*)io, mg);
543 call_method("OPEN", G_SCALAR);
557 tmps = SvPV_const(sv, len);
558 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
561 PUSHi( (I32)PL_forkprocess );
562 else if (PL_forkprocess == 0) /* we are a new child */
572 GV * const gv = (MAXARG == 0) ? PL_defoutgv : (GV*)POPs;
575 IO * const io = GvIO(gv);
577 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
580 XPUSHs(SvTIED_obj((SV*)io, mg));
583 call_method("CLOSE", G_SCALAR);
591 PUSHs(boolSV(do_close(gv, TRUE)));
604 GV * const wgv = (GV*)POPs;
605 GV * const rgv = (GV*)POPs;
610 if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
611 DIE(aTHX_ PL_no_usym, "filehandle");
616 do_close(rgv, FALSE);
618 do_close(wgv, FALSE);
620 if (PerlProc_pipe(fd) < 0)
623 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
624 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
625 IoOFP(rstio) = IoIFP(rstio);
626 IoIFP(wstio) = IoOFP(wstio);
627 IoTYPE(rstio) = IoTYPE_RDONLY;
628 IoTYPE(wstio) = IoTYPE_WRONLY;
630 if (!IoIFP(rstio) || !IoOFP(wstio)) {
632 PerlIO_close(IoIFP(rstio));
634 PerlLIO_close(fd[0]);
636 PerlIO_close(IoOFP(wstio));
638 PerlLIO_close(fd[1]);
641 #if defined(HAS_FCNTL) && defined(F_SETFD)
642 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
643 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
650 DIE(aTHX_ PL_no_func, "pipe");
666 if (gv && (io = GvIO(gv))
667 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
670 XPUSHs(SvTIED_obj((SV*)io, mg));
673 call_method("FILENO", G_SCALAR);
679 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
680 /* Can't do this because people seem to do things like
681 defined(fileno($foo)) to check whether $foo is a valid fh.
682 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
683 report_evil_fh(gv, io, PL_op->op_type);
688 PUSHi(PerlIO_fileno(fp));
701 anum = PerlLIO_umask(022);
702 /* setting it to 022 between the two calls to umask avoids
703 * to have a window where the umask is set to 0 -- meaning
704 * that another thread could create world-writeable files. */
706 (void)PerlLIO_umask(anum);
709 anum = PerlLIO_umask(POPi);
710 TAINT_PROPER("umask");
713 /* Only DIE if trying to restrict permissions on "user" (self).
714 * Otherwise it's harmless and more useful to just return undef
715 * since 'group' and 'other' concepts probably don't exist here. */
716 if (MAXARG >= 1 && (POPi & 0700))
717 DIE(aTHX_ "umask not implemented");
718 XPUSHs(&PL_sv_undef);
739 if (gv && (io = GvIO(gv))) {
740 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
743 XPUSHs(SvTIED_obj((SV*)io, mg));
748 call_method("BINMODE", G_SCALAR);
756 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
757 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
758 report_evil_fh(gv, io, PL_op->op_type);
759 SETERRNO(EBADF,RMS_IFI);
766 const char *d = NULL;
769 d = SvPV_const(discp, len);
770 mode = mode_from_discipline(d, len);
771 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
772 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
773 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
794 const I32 markoff = MARK - PL_stack_base;
795 const char *methname;
796 int how = PERL_MAGIC_tied;
800 switch(SvTYPE(varsv)) {
802 methname = "TIEHASH";
803 HvEITER_set((HV *)varsv, 0);
806 methname = "TIEARRAY";
809 if (isGV_with_GP(varsv)) {
810 #ifdef GV_UNIQUE_CHECK
811 if (GvUNIQUE((GV*)varsv)) {
812 Perl_croak(aTHX_ "Attempt to tie unique GV");
815 methname = "TIEHANDLE";
816 how = PERL_MAGIC_tiedscalar;
817 /* For tied filehandles, we apply tiedscalar magic to the IO
818 slot of the GP rather than the GV itself. AMS 20010812 */
820 GvIOp(varsv) = newIO();
821 varsv = (SV *)GvIOp(varsv);
826 methname = "TIESCALAR";
827 how = PERL_MAGIC_tiedscalar;
831 if (sv_isobject(*MARK)) { /* Calls GET magic. */
833 PUSHSTACKi(PERLSI_MAGIC);
835 EXTEND(SP,(I32)items);
839 call_method(methname, G_SCALAR);
842 /* Not clear why we don't call call_method here too.
843 * perhaps to get different error message ?
846 const char *name = SvPV_nomg_const(*MARK, len);
847 stash = gv_stashpvn(name, len, 0);
848 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
849 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
850 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
853 PUSHSTACKi(PERLSI_MAGIC);
855 EXTEND(SP,(I32)items);
859 call_sv((SV*)GvCV(gv), G_SCALAR);
865 if (sv_isobject(sv)) {
866 sv_unmagic(varsv, how);
867 /* Croak if a self-tie on an aggregate is attempted. */
868 if (varsv == SvRV(sv) &&
869 (SvTYPE(varsv) == SVt_PVAV ||
870 SvTYPE(varsv) == SVt_PVHV))
872 "Self-ties of arrays and hashes are not supported");
873 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
876 SP = PL_stack_base + markoff;
886 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
887 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
889 if (isGV_with_GP(sv) && !(sv = (SV *)GvIOp(sv)))
892 if ((mg = SvTIED_mg(sv, how))) {
893 SV * const obj = SvRV(SvTIED_obj(sv, mg));
895 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
897 if (gv && isGV(gv) && (cv = GvCV(gv))) {
899 XPUSHs(SvTIED_obj((SV*)gv, mg));
900 mXPUSHi(SvREFCNT(obj) - 1);
903 call_sv((SV *)cv, G_VOID);
907 else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
908 Perl_warner(aTHX_ packWARN(WARN_UNTIE),
909 "untie attempted while %"UVuf" inner references still exist",
910 (UV)SvREFCNT(obj) - 1 ) ;
914 sv_unmagic(sv, how) ;
924 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
925 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
927 if (isGV_with_GP(sv) && !(sv = (SV *)GvIOp(sv)))
930 if ((mg = SvTIED_mg(sv, how))) {
931 SV *osv = SvTIED_obj(sv, mg);
932 if (osv == mg->mg_obj)
933 osv = sv_mortalcopy(osv);
947 HV * const hv = (HV*)POPs;
948 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
949 stash = gv_stashsv(sv, 0);
950 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
952 require_pv("AnyDBM_File.pm");
954 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
955 DIE(aTHX_ "No dbm on this machine");
965 mPUSHu(O_RDWR|O_CREAT);
970 call_sv((SV*)GvCV(gv), G_SCALAR);
973 if (!sv_isobject(TOPs)) {
981 call_sv((SV*)GvCV(gv), G_SCALAR);
985 if (sv_isobject(TOPs)) {
986 sv_unmagic((SV *) hv, PERL_MAGIC_tied);
987 sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, NULL, 0);
1004 struct timeval timebuf;
1005 struct timeval *tbuf = &timebuf;
1008 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1013 # if BYTEORDER & 0xf0000
1014 # define ORDERBYTE (0x88888888 - BYTEORDER)
1016 # define ORDERBYTE (0x4444 - BYTEORDER)
1022 for (i = 1; i <= 3; i++) {
1023 SV * const sv = SP[i];
1026 if (SvREADONLY(sv)) {
1028 sv_force_normal_flags(sv, 0);
1029 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1030 DIE(aTHX_ PL_no_modify);
1033 if (ckWARN(WARN_MISC))
1034 Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1035 SvPV_force_nolen(sv); /* force string conversion */
1042 /* little endians can use vecs directly */
1043 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1050 masksize = NFDBITS / NBBY;
1052 masksize = sizeof(long); /* documented int, everyone seems to use long */
1054 Zero(&fd_sets[0], 4, char*);
1057 # if SELECT_MIN_BITS == 1
1058 growsize = sizeof(fd_set);
1060 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1061 # undef SELECT_MIN_BITS
1062 # define SELECT_MIN_BITS __FD_SETSIZE
1064 /* If SELECT_MIN_BITS is greater than one we most probably will want
1065 * to align the sizes with SELECT_MIN_BITS/8 because for example
1066 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1067 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1068 * on (sets/tests/clears bits) is 32 bits. */
1069 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1077 timebuf.tv_sec = (long)value;
1078 value -= (NV)timebuf.tv_sec;
1079 timebuf.tv_usec = (long)(value * 1000000.0);
1084 for (i = 1; i <= 3; i++) {
1086 if (!SvOK(sv) || SvCUR(sv) == 0) {
1093 Sv_Grow(sv, growsize);
1097 while (++j <= growsize) {
1101 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1103 Newx(fd_sets[i], growsize, char);
1104 for (offset = 0; offset < growsize; offset += masksize) {
1105 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1106 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1109 fd_sets[i] = SvPVX(sv);
1113 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1114 /* Can't make just the (void*) conditional because that would be
1115 * cpp #if within cpp macro, and not all compilers like that. */
1116 nfound = PerlSock_select(
1118 (Select_fd_set_t) fd_sets[1],
1119 (Select_fd_set_t) fd_sets[2],
1120 (Select_fd_set_t) fd_sets[3],
1121 (void*) tbuf); /* Workaround for compiler bug. */
1123 nfound = PerlSock_select(
1125 (Select_fd_set_t) fd_sets[1],
1126 (Select_fd_set_t) fd_sets[2],
1127 (Select_fd_set_t) fd_sets[3],
1130 for (i = 1; i <= 3; i++) {
1133 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1135 for (offset = 0; offset < growsize; offset += masksize) {
1136 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1137 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1139 Safefree(fd_sets[i]);
1146 if (GIMME == G_ARRAY && tbuf) {
1147 value = (NV)(timebuf.tv_sec) +
1148 (NV)(timebuf.tv_usec) / 1000000.0;
1153 DIE(aTHX_ "select not implemented");
1158 Perl_setdefout(pTHX_ GV *gv)
1161 SvREFCNT_inc_simple_void(gv);
1163 SvREFCNT_dec(PL_defoutgv);
1171 GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : NULL;
1172 GV * egv = GvEGV(PL_defoutgv);
1178 XPUSHs(&PL_sv_undef);
1180 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1181 if (gvp && *gvp == egv) {
1182 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1186 mXPUSHs(newRV((SV*)egv));
1191 if (!GvIO(newdefout))
1192 gv_IOadd(newdefout);
1193 setdefout(newdefout);
1203 GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs;
1205 if (gv && (io = GvIO(gv))) {
1206 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1208 const I32 gimme = GIMME_V;
1210 XPUSHs(SvTIED_obj((SV*)io, mg));
1213 call_method("GETC", gimme);
1216 if (gimme == G_SCALAR)
1217 SvSetMagicSV_nosteal(TARG, TOPs);
1221 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1222 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1223 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1224 report_evil_fh(gv, io, PL_op->op_type);
1225 SETERRNO(EBADF,RMS_IFI);
1229 sv_setpvn(TARG, " ", 1);
1230 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1231 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1232 /* Find out how many bytes the char needs */
1233 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1236 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1237 SvCUR_set(TARG,1+len);
1246 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1249 register PERL_CONTEXT *cx;
1250 const I32 gimme = GIMME_V;
1252 PERL_ARGS_ASSERT_DOFORM;
1257 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1258 PUSHFORMAT(cx, retop);
1260 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1262 setdefout(gv); /* locally select filehandle so $% et al work */
1294 goto not_a_format_reference;
1299 tmpsv = sv_newmortal();
1300 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1301 name = SvPV_nolen_const(tmpsv);
1303 DIE(aTHX_ "Undefined format \"%s\" called", name);
1305 not_a_format_reference:
1306 DIE(aTHX_ "Not a format reference");
1309 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1311 IoFLAGS(io) &= ~IOf_DIDTOP;
1312 return doform(cv,gv,PL_op->op_next);
1318 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1319 register IO * const io = GvIOp(gv);
1324 register PERL_CONTEXT *cx;
1326 if (!io || !(ofp = IoOFP(io)))
1329 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1330 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1332 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1333 PL_formtarget != PL_toptarget)
1337 if (!IoTOP_GV(io)) {
1340 if (!IoTOP_NAME(io)) {
1342 if (!IoFMT_NAME(io))
1343 IoFMT_NAME(io) = savepv(GvNAME(gv));
1344 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1345 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1346 if ((topgv && GvFORM(topgv)) ||
1347 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1348 IoTOP_NAME(io) = savesvpv(topname);
1350 IoTOP_NAME(io) = savepvs("top");
1352 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1353 if (!topgv || !GvFORM(topgv)) {
1354 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1357 IoTOP_GV(io) = topgv;
1359 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1360 I32 lines = IoLINES_LEFT(io);
1361 const char *s = SvPVX_const(PL_formtarget);
1362 if (lines <= 0) /* Yow, header didn't even fit!!! */
1364 while (lines-- > 0) {
1365 s = strchr(s, '\n');
1371 const STRLEN save = SvCUR(PL_formtarget);
1372 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1373 do_print(PL_formtarget, ofp);
1374 SvCUR_set(PL_formtarget, save);
1375 sv_chop(PL_formtarget, s);
1376 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1379 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1380 do_print(PL_formfeed, ofp);
1381 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1383 PL_formtarget = PL_toptarget;
1384 IoFLAGS(io) |= IOf_DIDTOP;
1387 DIE(aTHX_ "bad top format reference");
1390 SV * const sv = sv_newmortal();
1392 gv_efullname4(sv, fgv, NULL, FALSE);
1393 name = SvPV_nolen_const(sv);
1395 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1397 DIE(aTHX_ "Undefined top format called");
1399 if (cv && CvCLONE(cv))
1400 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1401 return doform(cv, gv, PL_op);
1405 POPBLOCK(cx,PL_curpm);
1411 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1413 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1414 else if (ckWARN(WARN_CLOSED))
1415 report_evil_fh(gv, io, PL_op->op_type);
1420 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1421 if (ckWARN(WARN_IO))
1422 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1424 if (!do_print(PL_formtarget, fp))
1427 FmLINES(PL_formtarget) = 0;
1428 SvCUR_set(PL_formtarget, 0);
1429 *SvEND(PL_formtarget) = '\0';
1430 if (IoFLAGS(io) & IOf_FLUSH)
1431 (void)PerlIO_flush(fp);
1436 PL_formtarget = PL_bodytarget;
1438 PERL_UNUSED_VAR(newsp);
1439 PERL_UNUSED_VAR(gimme);
1440 return cx->blk_sub.retop;
1445 dVAR; dSP; dMARK; dORIGMARK;
1450 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
1452 if (gv && (io = GvIO(gv))) {
1453 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1455 if (MARK == ORIGMARK) {
1458 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1462 *MARK = SvTIED_obj((SV*)io, mg);
1465 call_method("PRINTF", G_SCALAR);
1468 MARK = ORIGMARK + 1;
1476 if (!(io = GvIO(gv))) {
1477 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1478 report_evil_fh(gv, io, PL_op->op_type);
1479 SETERRNO(EBADF,RMS_IFI);
1482 else if (!(fp = IoOFP(io))) {
1483 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1485 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1486 else if (ckWARN(WARN_CLOSED))
1487 report_evil_fh(gv, io, PL_op->op_type);
1489 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1493 if (SvTAINTED(MARK[1]))
1494 TAINT_PROPER("printf");
1495 do_sprintf(sv, SP - MARK, MARK + 1);
1496 if (!do_print(sv, fp))
1499 if (IoFLAGS(io) & IOf_FLUSH)
1500 if (PerlIO_flush(fp) == EOF)
1511 PUSHs(&PL_sv_undef);
1519 const int perm = (MAXARG > 3) ? POPi : 0666;
1520 const int mode = POPi;
1521 SV * const sv = POPs;
1522 GV * const gv = (GV *)POPs;
1525 /* Need TIEHANDLE method ? */
1526 const char * const tmps = SvPV_const(sv, len);
1527 /* FIXME? do_open should do const */
1528 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1529 IoLINES(GvIOp(gv)) = 0;
1533 PUSHs(&PL_sv_undef);
1540 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1546 Sock_size_t bufsize;
1554 bool charstart = FALSE;
1555 STRLEN charskip = 0;
1558 GV * const gv = (GV*)*++MARK;
1559 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1560 && gv && (io = GvIO(gv)) )
1562 const MAGIC * mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1566 *MARK = SvTIED_obj((SV*)io, mg);
1568 call_method("READ", G_SCALAR);
1582 sv_setpvn(bufsv, "", 0);
1583 length = SvIVx(*++MARK);
1586 offset = SvIVx(*++MARK);
1590 if (!io || !IoIFP(io)) {
1591 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1592 report_evil_fh(gv, io, PL_op->op_type);
1593 SETERRNO(EBADF,RMS_IFI);
1596 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1597 buffer = SvPVutf8_force(bufsv, blen);
1598 /* UTF-8 may not have been set if they are all low bytes */
1603 buffer = SvPV_force(bufsv, blen);
1604 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1607 DIE(aTHX_ "Negative length");
1615 if (PL_op->op_type == OP_RECV) {
1616 char namebuf[MAXPATHLEN];
1617 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1618 bufsize = sizeof (struct sockaddr_in);
1620 bufsize = sizeof namebuf;
1622 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1626 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1627 /* 'offset' means 'flags' here */
1628 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1629 (struct sockaddr *)namebuf, &bufsize);
1633 /* Bogus return without padding */
1634 bufsize = sizeof (struct sockaddr_in);
1636 SvCUR_set(bufsv, count);
1637 *SvEND(bufsv) = '\0';
1638 (void)SvPOK_only(bufsv);
1642 /* This should not be marked tainted if the fp is marked clean */
1643 if (!(IoFLAGS(io) & IOf_UNTAINT))
1644 SvTAINTED_on(bufsv);
1646 sv_setpvn(TARG, namebuf, bufsize);
1651 if (PL_op->op_type == OP_RECV)
1652 DIE(aTHX_ PL_no_sock_func, "recv");
1654 if (DO_UTF8(bufsv)) {
1655 /* offset adjust in characters not bytes */
1656 blen = sv_len_utf8(bufsv);
1659 if (-offset > (int)blen)
1660 DIE(aTHX_ "Offset outside string");
1663 if (DO_UTF8(bufsv)) {
1664 /* convert offset-as-chars to offset-as-bytes */
1665 if (offset >= (int)blen)
1666 offset += SvCUR(bufsv) - blen;
1668 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1671 bufsize = SvCUR(bufsv);
1672 /* Allocating length + offset + 1 isn't perfect in the case of reading
1673 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1675 (should be 2 * length + offset + 1, or possibly something longer if
1676 PL_encoding is true) */
1677 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1678 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1679 Zero(buffer+bufsize, offset-bufsize, char);
1681 buffer = buffer + offset;
1683 read_target = bufsv;
1685 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1686 concatenate it to the current buffer. */
1688 /* Truncate the existing buffer to the start of where we will be
1690 SvCUR_set(bufsv, offset);
1692 read_target = sv_newmortal();
1693 SvUPGRADE(read_target, SVt_PV);
1694 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1697 if (PL_op->op_type == OP_SYSREAD) {
1698 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1699 if (IoTYPE(io) == IoTYPE_SOCKET) {
1700 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1706 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1711 #ifdef HAS_SOCKET__bad_code_maybe
1712 if (IoTYPE(io) == IoTYPE_SOCKET) {
1713 char namebuf[MAXPATHLEN];
1714 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1715 bufsize = sizeof (struct sockaddr_in);
1717 bufsize = sizeof namebuf;
1719 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1720 (struct sockaddr *)namebuf, &bufsize);
1725 count = PerlIO_read(IoIFP(io), buffer, length);
1726 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1727 if (count == 0 && PerlIO_error(IoIFP(io)))
1731 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1732 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1735 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1736 *SvEND(read_target) = '\0';
1737 (void)SvPOK_only(read_target);
1738 if (fp_utf8 && !IN_BYTES) {
1739 /* Look at utf8 we got back and count the characters */
1740 const char *bend = buffer + count;
1741 while (buffer < bend) {
1743 skip = UTF8SKIP(buffer);
1746 if (buffer - charskip + skip > bend) {
1747 /* partial character - try for rest of it */
1748 length = skip - (bend-buffer);
1749 offset = bend - SvPVX_const(bufsv);
1761 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1762 provided amount read (count) was what was requested (length)
1764 if (got < wanted && count == length) {
1765 length = wanted - got;
1766 offset = bend - SvPVX_const(bufsv);
1769 /* return value is character count */
1773 else if (buffer_utf8) {
1774 /* Let svcatsv upgrade the bytes we read in to utf8.
1775 The buffer is a mortal so will be freed soon. */
1776 sv_catsv_nomg(bufsv, read_target);
1779 /* This should not be marked tainted if the fp is marked clean */
1780 if (!(IoFLAGS(io) & IOf_UNTAINT))
1781 SvTAINTED_on(bufsv);
1793 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1799 STRLEN orig_blen_bytes;
1800 const int op_type = PL_op->op_type;
1804 GV *const gv = (GV*)*++MARK;
1805 if (PL_op->op_type == OP_SYSWRITE
1806 && gv && (io = GvIO(gv))) {
1807 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1811 if (MARK == SP - 1) {
1813 sv = sv_2mortal(newSViv(sv_len(*SP)));
1819 *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg);
1821 call_method("WRITE", G_SCALAR);
1837 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1839 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1840 if (io && IoIFP(io))
1841 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1843 report_evil_fh(gv, io, PL_op->op_type);
1845 SETERRNO(EBADF,RMS_IFI);
1849 /* Do this first to trigger any overloading. */
1850 buffer = SvPV_const(bufsv, blen);
1851 orig_blen_bytes = blen;
1852 doing_utf8 = DO_UTF8(bufsv);
1854 if (PerlIO_isutf8(IoIFP(io))) {
1855 if (!SvUTF8(bufsv)) {
1856 /* We don't modify the original scalar. */
1857 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1858 buffer = (char *) tmpbuf;
1862 else if (doing_utf8) {
1863 STRLEN tmplen = blen;
1864 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1867 buffer = (char *) tmpbuf;
1871 assert((char *)result == buffer);
1872 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1876 if (op_type == OP_SYSWRITE) {
1877 Size_t length = 0; /* This length is in characters. */
1883 /* The SV is bytes, and we've had to upgrade it. */
1884 blen_chars = orig_blen_bytes;
1886 /* The SV really is UTF-8. */
1887 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1888 /* Don't call sv_len_utf8 again because it will call magic
1889 or overloading a second time, and we might get back a
1890 different result. */
1891 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1893 /* It's safe, and it may well be cached. */
1894 blen_chars = sv_len_utf8(bufsv);
1902 length = blen_chars;
1904 #if Size_t_size > IVSIZE
1905 length = (Size_t)SvNVx(*++MARK);
1907 length = (Size_t)SvIVx(*++MARK);
1909 if ((SSize_t)length < 0) {
1911 DIE(aTHX_ "Negative length");
1916 offset = SvIVx(*++MARK);
1918 if (-offset > (IV)blen_chars) {
1920 DIE(aTHX_ "Offset outside string");
1922 offset += blen_chars;
1923 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1925 DIE(aTHX_ "Offset outside string");
1929 if (length > blen_chars - offset)
1930 length = blen_chars - offset;
1932 /* Here we convert length from characters to bytes. */
1933 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1934 /* Either we had to convert the SV, or the SV is magical, or
1935 the SV has overloading, in which case we can't or mustn't
1936 or mustn't call it again. */
1938 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1939 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1941 /* It's a real UTF-8 SV, and it's not going to change under
1942 us. Take advantage of any cache. */
1944 I32 len_I32 = length;
1946 /* Convert the start and end character positions to bytes.
1947 Remember that the second argument to sv_pos_u2b is relative
1949 sv_pos_u2b(bufsv, &start, &len_I32);
1956 buffer = buffer+offset;
1958 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1959 if (IoTYPE(io) == IoTYPE_SOCKET) {
1960 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1966 /* See the note at doio.c:do_print about filesize limits. --jhi */
1967 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1973 const int flags = SvIVx(*++MARK);
1976 char * const sockbuf = SvPVx(*++MARK, mlen);
1977 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1978 flags, (struct sockaddr *)sockbuf, mlen);
1982 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1987 DIE(aTHX_ PL_no_sock_func, "send");
1994 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
1997 #if Size_t_size > IVSIZE
2016 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
2018 gv = PL_last_in_gv = GvEGV(PL_argvgv);
2020 if (io && !IoIFP(io)) {
2021 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2023 IoFLAGS(io) &= ~IOf_START;
2024 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2026 sv_setpvn(GvSV(gv), "-", 1);
2029 GvSV(gv) = newSVpvn("-", 1);
2031 SvSETMAGIC(GvSV(gv));
2033 else if (!nextargv(gv))
2038 gv = PL_last_in_gv; /* eof */
2041 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
2044 IO * const io = GvIO(gv);
2046 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
2048 XPUSHs(SvTIED_obj((SV*)io, mg));
2051 call_method("EOF", G_SCALAR);
2058 PUSHs(boolSV(!gv || do_eof(gv)));
2069 PL_last_in_gv = (GV*)POPs;
2072 if (gv && (io = GvIO(gv))) {
2073 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2076 XPUSHs(SvTIED_obj((SV*)io, mg));
2079 call_method("TELL", G_SCALAR);
2086 #if LSEEKSIZE > IVSIZE
2087 PUSHn( do_tell(gv) );
2089 PUSHi( do_tell(gv) );
2097 const int whence = POPi;
2098 #if LSEEKSIZE > IVSIZE
2099 const Off_t offset = (Off_t)SvNVx(POPs);
2101 const Off_t offset = (Off_t)SvIVx(POPs);
2104 GV * const gv = PL_last_in_gv = (GV*)POPs;
2107 if (gv && (io = GvIO(gv))) {
2108 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2111 XPUSHs(SvTIED_obj((SV*)io, mg));
2112 #if LSEEKSIZE > IVSIZE
2113 mXPUSHn((NV) offset);
2120 call_method("SEEK", G_SCALAR);
2127 if (PL_op->op_type == OP_SEEK)
2128 PUSHs(boolSV(do_seek(gv, offset, whence)));
2130 const Off_t sought = do_sysseek(gv, offset, whence);
2132 PUSHs(&PL_sv_undef);
2134 SV* const sv = sought ?
2135 #if LSEEKSIZE > IVSIZE
2140 : newSVpvn(zero_but_true, ZBTLEN);
2151 /* There seems to be no consensus on the length type of truncate()
2152 * and ftruncate(), both off_t and size_t have supporters. In
2153 * general one would think that when using large files, off_t is
2154 * at least as wide as size_t, so using an off_t should be okay. */
2155 /* XXX Configure probe for the length type of *truncate() needed XXX */
2158 #if Off_t_size > IVSIZE
2163 /* Checking for length < 0 is problematic as the type might or
2164 * might not be signed: if it is not, clever compilers will moan. */
2165 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2172 if (PL_op->op_flags & OPf_SPECIAL) {
2173 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2182 TAINT_PROPER("truncate");
2183 if (!(fp = IoIFP(io))) {
2189 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2191 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2198 SV * const sv = POPs;
2201 if (isGV_with_GP(sv)) {
2202 tmpgv = (GV*)sv; /* *main::FRED for example */
2203 goto do_ftruncate_gv;
2205 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2206 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
2207 goto do_ftruncate_gv;
2209 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2210 io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
2211 goto do_ftruncate_io;
2214 name = SvPV_nolen_const(sv);
2215 TAINT_PROPER("truncate");
2217 if (truncate(name, len) < 0)
2221 const int tmpfd = PerlLIO_open(name, O_RDWR);
2226 if (my_chsize(tmpfd, len) < 0)
2228 PerlLIO_close(tmpfd);
2237 SETERRNO(EBADF,RMS_IFI);
2245 SV * const argsv = POPs;
2246 const unsigned int func = POPu;
2247 const int optype = PL_op->op_type;
2248 GV * const gv = (GV*)POPs;
2249 IO * const io = gv ? GvIOn(gv) : NULL;
2253 if (!io || !argsv || !IoIFP(io)) {
2254 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2255 report_evil_fh(gv, io, PL_op->op_type);
2256 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2260 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2263 s = SvPV_force(argsv, len);
2264 need = IOCPARM_LEN(func);
2266 s = Sv_Grow(argsv, need + 1);
2267 SvCUR_set(argsv, need);
2270 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2273 retval = SvIV(argsv);
2274 s = INT2PTR(char*,retval); /* ouch */
2277 TAINT_PROPER(PL_op_desc[optype]);
2279 if (optype == OP_IOCTL)
2281 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2283 DIE(aTHX_ "ioctl is not implemented");
2287 DIE(aTHX_ "fcntl is not implemented");
2289 #if defined(OS2) && defined(__EMX__)
2290 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2292 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2296 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2298 if (s[SvCUR(argsv)] != 17)
2299 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2301 s[SvCUR(argsv)] = 0; /* put our null back */
2302 SvSETMAGIC(argsv); /* Assume it has changed */
2311 PUSHp(zero_but_true, ZBTLEN);
2324 const int argtype = POPi;
2325 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
2327 if (gv && (io = GvIO(gv)))
2333 /* XXX Looks to me like io is always NULL at this point */
2335 (void)PerlIO_flush(fp);
2336 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2339 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2340 report_evil_fh(gv, io, PL_op->op_type);
2342 SETERRNO(EBADF,RMS_IFI);
2347 DIE(aTHX_ PL_no_func, "flock()");
2357 const int protocol = POPi;
2358 const int type = POPi;
2359 const int domain = POPi;
2360 GV * const gv = (GV*)POPs;
2361 register IO * const io = gv ? GvIOn(gv) : NULL;
2365 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2366 report_evil_fh(gv, io, PL_op->op_type);
2367 if (io && IoIFP(io))
2368 do_close(gv, FALSE);
2369 SETERRNO(EBADF,LIB_INVARG);
2374 do_close(gv, FALSE);
2376 TAINT_PROPER("socket");
2377 fd = PerlSock_socket(domain, type, protocol);
2380 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2381 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2382 IoTYPE(io) = IoTYPE_SOCKET;
2383 if (!IoIFP(io) || !IoOFP(io)) {
2384 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2385 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2386 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2389 #if defined(HAS_FCNTL) && defined(F_SETFD)
2390 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2394 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2399 DIE(aTHX_ PL_no_sock_func, "socket");
2405 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2407 const int protocol = POPi;
2408 const int type = POPi;
2409 const int domain = POPi;
2410 GV * const gv2 = (GV*)POPs;
2411 GV * const gv1 = (GV*)POPs;
2412 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2413 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2416 if (!gv1 || !gv2 || !io1 || !io2) {
2417 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2419 report_evil_fh(gv1, io1, PL_op->op_type);
2421 report_evil_fh(gv1, io2, PL_op->op_type);
2423 if (io1 && IoIFP(io1))
2424 do_close(gv1, FALSE);
2425 if (io2 && IoIFP(io2))
2426 do_close(gv2, FALSE);
2431 do_close(gv1, FALSE);
2433 do_close(gv2, FALSE);
2435 TAINT_PROPER("socketpair");
2436 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2438 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2439 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2440 IoTYPE(io1) = IoTYPE_SOCKET;
2441 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2442 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2443 IoTYPE(io2) = IoTYPE_SOCKET;
2444 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2445 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2446 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2447 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2448 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2449 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2450 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2453 #if defined(HAS_FCNTL) && defined(F_SETFD)
2454 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2455 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2460 DIE(aTHX_ PL_no_sock_func, "socketpair");
2468 SV * const addrsv = POPs;
2469 /* OK, so on what platform does bind modify addr? */
2471 GV * const gv = (GV*)POPs;
2472 register IO * const io = GvIOn(gv);
2475 if (!io || !IoIFP(io))
2478 addr = SvPV_const(addrsv, len);
2479 TAINT_PROPER("bind");
2480 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2486 if (ckWARN(WARN_CLOSED))
2487 report_evil_fh(gv, io, PL_op->op_type);
2488 SETERRNO(EBADF,SS_IVCHAN);
2491 DIE(aTHX_ PL_no_sock_func, "bind");
2499 SV * const addrsv = POPs;
2500 GV * const gv = (GV*)POPs;
2501 register IO * const io = GvIOn(gv);
2505 if (!io || !IoIFP(io))
2508 addr = SvPV_const(addrsv, len);
2509 TAINT_PROPER("connect");
2510 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2516 if (ckWARN(WARN_CLOSED))
2517 report_evil_fh(gv, io, PL_op->op_type);
2518 SETERRNO(EBADF,SS_IVCHAN);
2521 DIE(aTHX_ PL_no_sock_func, "connect");
2529 const int backlog = POPi;
2530 GV * const gv = (GV*)POPs;
2531 register IO * const io = gv ? GvIOn(gv) : NULL;
2533 if (!gv || !io || !IoIFP(io))
2536 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2542 if (ckWARN(WARN_CLOSED))
2543 report_evil_fh(gv, io, PL_op->op_type);
2544 SETERRNO(EBADF,SS_IVCHAN);
2547 DIE(aTHX_ PL_no_sock_func, "listen");
2557 char namebuf[MAXPATHLEN];
2558 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2559 Sock_size_t len = sizeof (struct sockaddr_in);
2561 Sock_size_t len = sizeof namebuf;
2563 GV * const ggv = (GV*)POPs;
2564 GV * const ngv = (GV*)POPs;
2573 if (!gstio || !IoIFP(gstio))
2577 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2580 /* Some platforms indicate zero length when an AF_UNIX client is
2581 * not bound. Simulate a non-zero-length sockaddr structure in
2583 namebuf[0] = 0; /* sun_len */
2584 namebuf[1] = AF_UNIX; /* sun_family */
2592 do_close(ngv, FALSE);
2593 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2594 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2595 IoTYPE(nstio) = IoTYPE_SOCKET;
2596 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2597 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2598 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2599 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2602 #if defined(HAS_FCNTL) && defined(F_SETFD)
2603 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2607 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2608 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2610 #ifdef __SCO_VERSION__
2611 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2614 PUSHp(namebuf, len);
2618 if (ckWARN(WARN_CLOSED))
2619 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2620 SETERRNO(EBADF,SS_IVCHAN);
2626 DIE(aTHX_ PL_no_sock_func, "accept");
2634 const int how = POPi;
2635 GV * const gv = (GV*)POPs;
2636 register IO * const io = GvIOn(gv);
2638 if (!io || !IoIFP(io))
2641 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2645 if (ckWARN(WARN_CLOSED))
2646 report_evil_fh(gv, io, PL_op->op_type);
2647 SETERRNO(EBADF,SS_IVCHAN);
2650 DIE(aTHX_ PL_no_sock_func, "shutdown");
2658 const int optype = PL_op->op_type;
2659 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2660 const unsigned int optname = (unsigned int) POPi;
2661 const unsigned int lvl = (unsigned int) POPi;
2662 GV * const gv = (GV*)POPs;
2663 register IO * const io = GvIOn(gv);
2667 if (!io || !IoIFP(io))
2670 fd = PerlIO_fileno(IoIFP(io));
2674 (void)SvPOK_only(sv);
2678 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2685 #if defined(__SYMBIAN32__)
2686 # define SETSOCKOPT_OPTION_VALUE_T void *
2688 # define SETSOCKOPT_OPTION_VALUE_T const char *
2690 /* XXX TODO: We need to have a proper type (a Configure probe,
2691 * etc.) for what the C headers think of the third argument of
2692 * setsockopt(), the option_value read-only buffer: is it
2693 * a "char *", or a "void *", const or not. Some compilers
2694 * don't take kindly to e.g. assuming that "char *" implicitly
2695 * promotes to a "void *", or to explicitly promoting/demoting
2696 * consts to non/vice versa. The "const void *" is the SUS
2697 * definition, but that does not fly everywhere for the above
2699 SETSOCKOPT_OPTION_VALUE_T buf;
2703 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2707 aint = (int)SvIV(sv);
2708 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2711 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2720 if (ckWARN(WARN_CLOSED))
2721 report_evil_fh(gv, io, optype);
2722 SETERRNO(EBADF,SS_IVCHAN);
2727 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2735 const int optype = PL_op->op_type;
2736 GV * const gv = (GV*)POPs;
2737 register IO * const io = GvIOn(gv);
2742 if (!io || !IoIFP(io))
2745 sv = sv_2mortal(newSV(257));
2746 (void)SvPOK_only(sv);
2750 fd = PerlIO_fileno(IoIFP(io));
2752 case OP_GETSOCKNAME:
2753 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2756 case OP_GETPEERNAME:
2757 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2759 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2761 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";
2762 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2763 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2764 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2765 sizeof(u_short) + sizeof(struct in_addr))) {
2772 #ifdef BOGUS_GETNAME_RETURN
2773 /* Interactive Unix, getpeername() and getsockname()
2774 does not return valid namelen */
2775 if (len == BOGUS_GETNAME_RETURN)
2776 len = sizeof(struct sockaddr);
2784 if (ckWARN(WARN_CLOSED))
2785 report_evil_fh(gv, io, optype);
2786 SETERRNO(EBADF,SS_IVCHAN);
2791 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2806 if (PL_op->op_flags & OPf_REF) {
2808 if (PL_op->op_type == OP_LSTAT) {
2809 if (gv != PL_defgv) {
2810 do_fstat_warning_check:
2811 if (ckWARN(WARN_IO))
2812 Perl_warner(aTHX_ packWARN(WARN_IO),
2813 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2814 } else if (PL_laststype != OP_LSTAT)
2815 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2819 if (gv != PL_defgv) {
2820 PL_laststype = OP_STAT;
2822 sv_setpvn(PL_statname, "", 0);
2829 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2830 } else if (IoDIRP(io)) {
2832 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2834 PL_laststatval = -1;
2840 if (PL_laststatval < 0) {
2841 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2842 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2847 SV* const sv = POPs;
2848 if (isGV_with_GP(sv)) {
2851 } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2853 if (PL_op->op_type == OP_LSTAT)
2854 goto do_fstat_warning_check;
2856 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2858 if (PL_op->op_type == OP_LSTAT)
2859 goto do_fstat_warning_check;
2860 goto do_fstat_have_io;
2863 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2865 PL_laststype = PL_op->op_type;
2866 if (PL_op->op_type == OP_LSTAT)
2867 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2869 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2870 if (PL_laststatval < 0) {
2871 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2872 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2878 if (gimme != G_ARRAY) {
2879 if (gimme != G_VOID)
2880 XPUSHs(boolSV(max));
2886 mPUSHi(PL_statcache.st_dev);
2887 mPUSHi(PL_statcache.st_ino);
2888 mPUSHu(PL_statcache.st_mode);
2889 mPUSHu(PL_statcache.st_nlink);
2890 #if Uid_t_size > IVSIZE
2891 mPUSHn(PL_statcache.st_uid);
2893 # if Uid_t_sign <= 0
2894 mPUSHi(PL_statcache.st_uid);
2896 mPUSHu(PL_statcache.st_uid);
2899 #if Gid_t_size > IVSIZE
2900 mPUSHn(PL_statcache.st_gid);
2902 # if Gid_t_sign <= 0
2903 mPUSHi(PL_statcache.st_gid);
2905 mPUSHu(PL_statcache.st_gid);
2908 #ifdef USE_STAT_RDEV
2909 mPUSHi(PL_statcache.st_rdev);
2911 PUSHs(newSVpvs_flags("", SVs_TEMP));
2913 #if Off_t_size > IVSIZE
2914 mPUSHn(PL_statcache.st_size);
2916 mPUSHi(PL_statcache.st_size);
2919 mPUSHn(PL_statcache.st_atime);
2920 mPUSHn(PL_statcache.st_mtime);
2921 mPUSHn(PL_statcache.st_ctime);
2923 mPUSHi(PL_statcache.st_atime);
2924 mPUSHi(PL_statcache.st_mtime);
2925 mPUSHi(PL_statcache.st_ctime);
2927 #ifdef USE_STAT_BLOCKS
2928 mPUSHu(PL_statcache.st_blksize);
2929 mPUSHu(PL_statcache.st_blocks);
2931 PUSHs(newSVpvs_flags("", SVs_TEMP));
2932 PUSHs(newSVpvs_flags("", SVs_TEMP));
2938 /* This macro is used by the stacked filetest operators :
2939 * if the previous filetest failed, short-circuit and pass its value.
2940 * Else, discard it from the stack and continue. --rgs
2942 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2943 if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
2944 else { (void)POPs; PUTBACK; } \
2951 /* Not const, because things tweak this below. Not bool, because there's
2952 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2953 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2954 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2955 /* Giving some sort of initial value silences compilers. */
2957 int access_mode = R_OK;
2959 int access_mode = 0;
2962 /* access_mode is never used, but leaving use_access in makes the
2963 conditional compiling below much clearer. */
2966 int stat_mode = S_IRUSR;
2968 bool effective = FALSE;
2971 STACKED_FTEST_CHECK;
2973 switch (PL_op->op_type) {
2975 #if !(defined(HAS_ACCESS) && defined(R_OK))
2981 #if defined(HAS_ACCESS) && defined(W_OK)
2986 stat_mode = S_IWUSR;
2990 #if defined(HAS_ACCESS) && defined(X_OK)
2995 stat_mode = S_IXUSR;
2999 #ifdef PERL_EFF_ACCESS
3002 stat_mode = S_IWUSR;
3006 #ifndef PERL_EFF_ACCESS
3013 #ifdef PERL_EFF_ACCESS
3018 stat_mode = S_IXUSR;
3024 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3025 const char *name = POPpx;
3027 # ifdef PERL_EFF_ACCESS
3028 result = PERL_EFF_ACCESS(name, access_mode);
3030 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3036 result = access(name, access_mode);
3038 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3053 if (cando(stat_mode, effective, &PL_statcache))
3062 const int op_type = PL_op->op_type;
3064 STACKED_FTEST_CHECK;
3069 if (op_type == OP_FTIS)
3072 /* You can't dTARGET inside OP_FTIS, because you'll get
3073 "panic: pad_sv po" - the op is not flagged to have a target. */
3077 #if Off_t_size > IVSIZE
3078 PUSHn(PL_statcache.st_size);
3080 PUSHi(PL_statcache.st_size);
3084 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3087 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3090 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3103 /* I believe that all these three are likely to be defined on most every
3104 system these days. */
3106 if(PL_op->op_type == OP_FTSUID)
3110 if(PL_op->op_type == OP_FTSGID)
3114 if(PL_op->op_type == OP_FTSVTX)
3118 STACKED_FTEST_CHECK;
3123 switch (PL_op->op_type) {
3125 if (PL_statcache.st_uid == PL_uid)
3129 if (PL_statcache.st_uid == PL_euid)
3133 if (PL_statcache.st_size == 0)
3137 if (S_ISSOCK(PL_statcache.st_mode))
3141 if (S_ISCHR(PL_statcache.st_mode))
3145 if (S_ISBLK(PL_statcache.st_mode))
3149 if (S_ISREG(PL_statcache.st_mode))
3153 if (S_ISDIR(PL_statcache.st_mode))
3157 if (S_ISFIFO(PL_statcache.st_mode))
3162 if (PL_statcache.st_mode & S_ISUID)
3168 if (PL_statcache.st_mode & S_ISGID)
3174 if (PL_statcache.st_mode & S_ISVTX)
3185 I32 result = my_lstat();
3189 if (S_ISLNK(PL_statcache.st_mode))
3202 STACKED_FTEST_CHECK;
3204 if (PL_op->op_flags & OPf_REF)
3206 else if (isGV(TOPs))
3208 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3209 gv = (GV*)SvRV(POPs);
3211 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3213 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3214 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3215 else if (tmpsv && SvOK(tmpsv)) {
3216 const char *tmps = SvPV_nolen_const(tmpsv);
3224 if (PerlLIO_isatty(fd))
3229 #if defined(atarist) /* this will work with atariST. Configure will
3230 make guesses for other systems. */
3231 # define FILE_base(f) ((f)->_base)
3232 # define FILE_ptr(f) ((f)->_ptr)
3233 # define FILE_cnt(f) ((f)->_cnt)
3234 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3245 register STDCHAR *s;
3251 STACKED_FTEST_CHECK;
3253 if (PL_op->op_flags & OPf_REF)
3255 else if (isGV(TOPs))
3257 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3258 gv = (GV*)SvRV(POPs);
3264 if (gv == PL_defgv) {
3266 io = GvIO(PL_statgv);
3269 goto really_filename;
3274 PL_laststatval = -1;
3275 sv_setpvn(PL_statname, "", 0);
3276 io = GvIO(PL_statgv);
3278 if (io && IoIFP(io)) {
3279 if (! PerlIO_has_base(IoIFP(io)))
3280 DIE(aTHX_ "-T and -B not implemented on filehandles");
3281 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3282 if (PL_laststatval < 0)
3284 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3285 if (PL_op->op_type == OP_FTTEXT)
3290 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3291 i = PerlIO_getc(IoIFP(io));
3293 (void)PerlIO_ungetc(IoIFP(io),i);
3295 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3297 len = PerlIO_get_bufsiz(IoIFP(io));
3298 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3299 /* sfio can have large buffers - limit to 512 */
3304 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3306 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3308 SETERRNO(EBADF,RMS_IFI);
3316 PL_laststype = OP_STAT;
3317 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3318 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3319 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3321 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3324 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3325 if (PL_laststatval < 0) {
3326 (void)PerlIO_close(fp);
3329 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3330 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3331 (void)PerlIO_close(fp);
3333 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3334 RETPUSHNO; /* special case NFS directories */
3335 RETPUSHYES; /* null file is anything */
3340 /* now scan s to look for textiness */
3341 /* XXX ASCII dependent code */
3343 #if defined(DOSISH) || defined(USEMYBINMODE)
3344 /* ignore trailing ^Z on short files */
3345 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3349 for (i = 0; i < len; i++, s++) {
3350 if (!*s) { /* null never allowed in text */
3355 else if (!(isPRINT(*s) || isSPACE(*s)))
3358 else if (*s & 128) {
3360 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3363 /* utf8 characters don't count as odd */
3364 if (UTF8_IS_START(*s)) {
3365 int ulen = UTF8SKIP(s);
3366 if (ulen < len - i) {
3368 for (j = 1; j < ulen; j++) {
3369 if (!UTF8_IS_CONTINUATION(s[j]))
3372 --ulen; /* loop does extra increment */
3382 *s != '\n' && *s != '\r' && *s != '\b' &&
3383 *s != '\t' && *s != '\f' && *s != 27)
3388 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3399 const char *tmps = NULL;
3403 SV * const sv = POPs;
3404 if (PL_op->op_flags & OPf_SPECIAL) {
3405 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3407 else if (isGV_with_GP(sv)) {
3410 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
3414 tmps = SvPV_nolen_const(sv);
3418 if( !gv && (!tmps || !*tmps) ) {
3419 HV * const table = GvHVn(PL_envgv);
3422 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3423 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3425 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3430 deprecate("chdir('') or chdir(undef) as chdir()");
3431 tmps = SvPV_nolen_const(*svp);
3435 TAINT_PROPER("chdir");
3440 TAINT_PROPER("chdir");
3443 IO* const io = GvIO(gv);
3446 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3447 } else if (IoIFP(io)) {
3448 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3451 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3452 report_evil_fh(gv, io, PL_op->op_type);
3453 SETERRNO(EBADF, RMS_IFI);
3458 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3459 report_evil_fh(gv, io, PL_op->op_type);
3460 SETERRNO(EBADF,RMS_IFI);
3464 DIE(aTHX_ PL_no_func, "fchdir");
3468 PUSHi( PerlDir_chdir(tmps) >= 0 );
3470 /* Clear the DEFAULT element of ENV so we'll get the new value
3472 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3479 dVAR; dSP; dMARK; dTARGET;
3480 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3491 char * const tmps = POPpx;
3492 TAINT_PROPER("chroot");
3493 PUSHi( chroot(tmps) >= 0 );
3496 DIE(aTHX_ PL_no_func, "chroot");
3504 const char * const tmps2 = POPpconstx;
3505 const char * const tmps = SvPV_nolen_const(TOPs);
3506 TAINT_PROPER("rename");
3508 anum = PerlLIO_rename(tmps, tmps2);
3510 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3511 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3514 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3515 (void)UNLINK(tmps2);
3516 if (!(anum = link(tmps, tmps2)))
3517 anum = UNLINK(tmps);
3525 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3529 const int op_type = PL_op->op_type;
3533 if (op_type == OP_LINK)
3534 DIE(aTHX_ PL_no_func, "link");
3536 # ifndef HAS_SYMLINK
3537 if (op_type == OP_SYMLINK)
3538 DIE(aTHX_ PL_no_func, "symlink");
3542 const char * const tmps2 = POPpconstx;
3543 const char * const tmps = SvPV_nolen_const(TOPs);
3544 TAINT_PROPER(PL_op_desc[op_type]);
3546 # if defined(HAS_LINK)
3547 # if defined(HAS_SYMLINK)
3548 /* Both present - need to choose which. */
3549 (op_type == OP_LINK) ?
3550 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3552 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3553 PerlLIO_link(tmps, tmps2);
3556 # if defined(HAS_SYMLINK)
3557 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3558 symlink(tmps, tmps2);
3563 SETi( result >= 0 );
3570 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3581 char buf[MAXPATHLEN];
3584 #ifndef INCOMPLETE_TAINTS
3588 len = readlink(tmps, buf, sizeof(buf) - 1);
3596 RETSETUNDEF; /* just pretend it's a normal file */
3600 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3602 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3604 char * const save_filename = filename;
3609 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3611 PERL_ARGS_ASSERT_DOONELINER;
3613 Newx(cmdline, size, char);
3614 my_strlcpy(cmdline, cmd, size);
3615 my_strlcat(cmdline, " ", size);
3616 for (s = cmdline + strlen(cmdline); *filename; ) {
3620 if (s - cmdline < size)
3621 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3622 myfp = PerlProc_popen(cmdline, "r");
3626 SV * const tmpsv = sv_newmortal();
3627 /* Need to save/restore 'PL_rs' ?? */
3628 s = sv_gets(tmpsv, myfp, 0);
3629 (void)PerlProc_pclose(myfp);
3633 #ifdef HAS_SYS_ERRLIST
3638 /* you don't see this */
3639 const char * const errmsg =
3640 #ifdef HAS_SYS_ERRLIST
3648 if (instr(s, errmsg)) {
3655 #define EACCES EPERM
3657 if (instr(s, "cannot make"))
3658 SETERRNO(EEXIST,RMS_FEX);
3659 else if (instr(s, "existing file"))
3660 SETERRNO(EEXIST,RMS_FEX);
3661 else if (instr(s, "ile exists"))
3662 SETERRNO(EEXIST,RMS_FEX);
3663 else if (instr(s, "non-exist"))
3664 SETERRNO(ENOENT,RMS_FNF);
3665 else if (instr(s, "does not exist"))
3666 SETERRNO(ENOENT,RMS_FNF);
3667 else if (instr(s, "not empty"))
3668 SETERRNO(EBUSY,SS_DEVOFFLINE);
3669 else if (instr(s, "cannot access"))
3670 SETERRNO(EACCES,RMS_PRV);
3672 SETERRNO(EPERM,RMS_PRV);
3675 else { /* some mkdirs return no failure indication */
3676 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3677 if (PL_op->op_type == OP_RMDIR)
3682 SETERRNO(EACCES,RMS_PRV); /* a guess */
3691 /* This macro removes trailing slashes from a directory name.
3692 * Different operating and file systems take differently to
3693 * trailing slashes. According to POSIX 1003.1 1996 Edition
3694 * any number of trailing slashes should be allowed.
3695 * Thusly we snip them away so that even non-conforming
3696 * systems are happy.
3697 * We should probably do this "filtering" for all
3698 * the functions that expect (potentially) directory names:
3699 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3700 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3702 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3703 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3706 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3707 (tmps) = savepvn((tmps), (len)); \
3717 const int mode = (MAXARG > 1) ? POPi : 0777;
3719 TRIMSLASHES(tmps,len,copy);
3721 TAINT_PROPER("mkdir");
3723 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3727 SETi( dooneliner("mkdir", tmps) );
3728 oldumask = PerlLIO_umask(0);
3729 PerlLIO_umask(oldumask);
3730 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3745 TRIMSLASHES(tmps,len,copy);
3746 TAINT_PROPER("rmdir");
3748 SETi( PerlDir_rmdir(tmps) >= 0 );
3750 SETi( dooneliner("rmdir", tmps) );
3757 /* Directory calls. */
3761 #if defined(Direntry_t) && defined(HAS_READDIR)
3763 const char * const dirname = POPpconstx;
3764 GV * const gv = (GV*)POPs;
3765 register IO * const io = GvIOn(gv);
3770 if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED))
3771 Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3772 "Opening filehandle %s also as a directory", GvENAME(gv));
3774 PerlDir_close(IoDIRP(io));
3775 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3781 SETERRNO(EBADF,RMS_DIR);
3784 DIE(aTHX_ PL_no_dir_func, "opendir");
3790 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3791 DIE(aTHX_ PL_no_dir_func, "readdir");
3793 #if !defined(I_DIRENT) && !defined(VMS)
3794 Direntry_t *readdir (DIR *);
3800 const I32 gimme = GIMME;
3801 GV * const gv = (GV *)POPs;
3802 register const Direntry_t *dp;
3803 register IO * const io = GvIOn(gv);
3805 if (!io || !IoDIRP(io)) {
3806 if(ckWARN(WARN_IO)) {
3807 Perl_warner(aTHX_ packWARN(WARN_IO),
3808 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3814 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3818 sv = newSVpvn(dp->d_name, dp->d_namlen);
3820 sv = newSVpv(dp->d_name, 0);
3822 #ifndef INCOMPLETE_TAINTS
3823 if (!(IoFLAGS(io) & IOf_UNTAINT))
3827 } while (gimme == G_ARRAY);
3829 if (!dp && gimme != G_ARRAY)
3836 SETERRNO(EBADF,RMS_ISI);
3837 if (GIMME == G_ARRAY)
3846 #if defined(HAS_TELLDIR) || defined(telldir)
3848 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3849 /* XXX netbsd still seemed to.
3850 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3851 --JHI 1999-Feb-02 */
3852 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3853 long telldir (DIR *);
3855 GV * const gv = (GV*)POPs;
3856 register IO * const io = GvIOn(gv);
3858 if (!io || !IoDIRP(io)) {
3859 if(ckWARN(WARN_IO)) {
3860 Perl_warner(aTHX_ packWARN(WARN_IO),
3861 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3866 PUSHi( PerlDir_tell(IoDIRP(io)) );
3870 SETERRNO(EBADF,RMS_ISI);
3873 DIE(aTHX_ PL_no_dir_func, "telldir");
3879 #if defined(HAS_SEEKDIR) || defined(seekdir)
3881 const long along = POPl;
3882 GV * const gv = (GV*)POPs;
3883 register IO * const io = GvIOn(gv);
3885 if (!io || !IoDIRP(io)) {
3886 if(ckWARN(WARN_IO)) {
3887 Perl_warner(aTHX_ packWARN(WARN_IO),
3888 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3892 (void)PerlDir_seek(IoDIRP(io), along);
3897 SETERRNO(EBADF,RMS_ISI);
3900 DIE(aTHX_ PL_no_dir_func, "seekdir");
3906 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3908 GV * const gv = (GV*)POPs;
3909 register IO * const io = GvIOn(gv);
3911 if (!io || !IoDIRP(io)) {
3912 if(ckWARN(WARN_IO)) {
3913 Perl_warner(aTHX_ packWARN(WARN_IO),
3914 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3918 (void)PerlDir_rewind(IoDIRP(io));
3922 SETERRNO(EBADF,RMS_ISI);
3925 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3931 #if defined(Direntry_t) && defined(HAS_READDIR)
3933 GV * const gv = (GV*)POPs;
3934 register IO * const io = GvIOn(gv);
3936 if (!io || !IoDIRP(io)) {
3937 if(ckWARN(WARN_IO)) {
3938 Perl_warner(aTHX_ packWARN(WARN_IO),
3939 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3943 #ifdef VOID_CLOSEDIR
3944 PerlDir_close(IoDIRP(io));
3946 if (PerlDir_close(IoDIRP(io)) < 0) {
3947 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3956 SETERRNO(EBADF,RMS_IFI);
3959 DIE(aTHX_ PL_no_dir_func, "closedir");
3963 /* Process control. */
3972 PERL_FLUSHALL_FOR_CHILD;
3973 childpid = PerlProc_fork();
3977 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3979 SvREADONLY_off(GvSV(tmpgv));
3980 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3981 SvREADONLY_on(GvSV(tmpgv));
3983 #ifdef THREADS_HAVE_PIDS
3984 PL_ppid = (IV)getppid();
3986 #ifdef PERL_USES_PL_PIDSTATUS
3987 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3993 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3998 PERL_FLUSHALL_FOR_CHILD;
3999 childpid = PerlProc_fork();
4005 DIE(aTHX_ PL_no_func, "fork");
4012 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4017 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4018 childpid = wait4pid(-1, &argflags, 0);
4020 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4025 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4026 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4027 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4029 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4034 DIE(aTHX_ PL_no_func, "wait");
4040 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4042 const int optype = POPi;
4043 const Pid_t pid = TOPi;
4047 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4048 result = wait4pid(pid, &argflags, optype);
4050 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4055 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4056 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4057 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4059 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4064 DIE(aTHX_ PL_no_func, "waitpid");
4070 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4071 #if defined(__LIBCATAMOUNT__)
4072 PL_statusvalue = -1;
4081 while (++MARK <= SP) {
4082 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4087 TAINT_PROPER("system");
4089 PERL_FLUSHALL_FOR_CHILD;
4090 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4096 if (PerlProc_pipe(pp) >= 0)
4098 while ((childpid = PerlProc_fork()) == -1) {
4099 if (errno != EAGAIN) {
4104 PerlLIO_close(pp[0]);
4105 PerlLIO_close(pp[1]);
4112 Sigsave_t ihand,qhand; /* place to save signals during system() */
4116 PerlLIO_close(pp[1]);
4118 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4119 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4122 result = wait4pid(childpid, &status, 0);
4123 } while (result == -1 && errno == EINTR);
4125 (void)rsignal_restore(SIGINT, &ihand);
4126 (void)rsignal_restore(SIGQUIT, &qhand);
4128 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4129 do_execfree(); /* free any memory child malloced on fork */
4136 while (n < sizeof(int)) {
4137 n1 = PerlLIO_read(pp[0],
4138 (void*)(((char*)&errkid)+n),
4144 PerlLIO_close(pp[0]);
4145 if (n) { /* Error */
4146 if (n != sizeof(int))
4147 DIE(aTHX_ "panic: kid popen errno read");
4148 errno = errkid; /* Propagate errno from kid */
4149 STATUS_NATIVE_CHILD_SET(-1);
4152 XPUSHi(STATUS_CURRENT);
4156 PerlLIO_close(pp[0]);
4157 #if defined(HAS_FCNTL) && defined(F_SETFD)
4158 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4161 if (PL_op->op_flags & OPf_STACKED) {
4162 SV * const really = *++MARK;
4163 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4165 else if (SP - MARK != 1)
4166 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4168 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4172 #else /* ! FORK or VMS or OS/2 */
4175 if (PL_op->op_flags & OPf_STACKED) {
4176 SV * const really = *++MARK;
4177 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4178 value = (I32)do_aspawn(really, MARK, SP);
4180 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4183 else if (SP - MARK != 1) {
4184 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4185 value = (I32)do_aspawn(NULL, MARK, SP);
4187 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4191 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4193 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4195 STATUS_NATIVE_CHILD_SET(value);
4198 XPUSHi(result ? value : STATUS_CURRENT);
4199 #endif /* !FORK or VMS or OS/2 */
4206 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4211 while (++MARK <= SP) {
4212 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4217 TAINT_PROPER("exec");
4219 PERL_FLUSHALL_FOR_CHILD;
4220 if (PL_op->op_flags & OPf_STACKED) {
4221 SV * const really = *++MARK;
4222 value = (I32)do_aexec(really, MARK, SP);
4224 else if (SP - MARK != 1)
4226 value = (I32)vms_do_aexec(NULL, MARK, SP);
4230 (void ) do_aspawn(NULL, MARK, SP);
4234 value = (I32)do_aexec(NULL, MARK, SP);
4239 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4242 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4245 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4259 # ifdef THREADS_HAVE_PIDS
4260 if (PL_ppid != 1 && getppid() == 1)
4261 /* maybe the parent process has died. Refresh ppid cache */
4265 XPUSHi( getppid() );
4269 DIE(aTHX_ PL_no_func, "getppid");
4278 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4281 pgrp = (I32)BSD_GETPGRP(pid);
4283 if (pid != 0 && pid != PerlProc_getpid())
4284 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4290 DIE(aTHX_ PL_no_func, "getpgrp()");
4309 TAINT_PROPER("setpgrp");
4311 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4313 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4314 || (pid != 0 && pid != PerlProc_getpid()))
4316 DIE(aTHX_ "setpgrp can't take arguments");
4318 SETi( setpgrp() >= 0 );
4319 #endif /* USE_BSDPGRP */
4322 DIE(aTHX_ PL_no_func, "setpgrp()");
4328 #ifdef HAS_GETPRIORITY
4330 const int who = POPi;
4331 const int which = TOPi;
4332 SETi( getpriority(which, who) );
4335 DIE(aTHX_ PL_no_func, "getpriority()");
4341 #ifdef HAS_SETPRIORITY
4343 const int niceval = POPi;
4344 const int who = POPi;
4345 const int which = TOPi;
4346 TAINT_PROPER("setpriority");
4347 SETi( setpriority(which, who, niceval) >= 0 );
4350 DIE(aTHX_ PL_no_func, "setpriority()");
4360 XPUSHn( time(NULL) );
4362 XPUSHi( time(NULL) );
4374 (void)PerlProc_times(&PL_timesbuf);
4376 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4377 /* struct tms, though same data */
4381 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4382 if (GIMME == G_ARRAY) {
4383 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4384 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4385 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4393 if (GIMME == G_ARRAY) {
4400 DIE(aTHX_ "times not implemented");
4402 #endif /* HAS_TIMES */
4405 #ifdef LOCALTIME_EDGECASE_BROKEN
4406 static struct tm *S_my_localtime (pTHX_ Time_t *tp)
4411 /* No workarounds in the valid range */
4412 if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4413 return (localtime (tp));
4415 /* This edge case is to workaround the undefined behaviour, where the
4416 * TIMEZONE makes the time go beyond the defined range.
4417 * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4418 * If there is a negative offset in TZ, like MET-1METDST, some broken
4419 * implementations of localtime () (like AIX 5.2) barf with bogus
4421 * 0x7fffffff gmtime 2038-01-19 03:14:07
4422 * 0x7fffffff localtime 1901-12-13 21:45:51
4423 * 0x7fffffff mylocaltime 2038-01-19 04:14:07
4424 * 0x3c19137f gmtime 2001-12-13 20:45:51
4425 * 0x3c19137f localtime 2001-12-13 21:45:51
4426 * 0x3c19137f mylocaltime 2001-12-13 21:45:51
4427 * Given that legal timezones are typically between GMT-12 and GMT+12
4428 * we turn back the clock 23 hours before calling the localtime
4429 * function, and add those to the return value. This will never cause
4430 * day wrapping problems, since the edge case is Tue Jan *19*
4432 T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4435 if (P->tm_hour >= 24) {
4437 P->tm_mday++; /* 18 -> 19 */
4438 P->tm_wday++; /* Mon -> Tue */
4439 P->tm_yday++; /* 18 -> 19 */
4442 } /* S_my_localtime */
4450 const struct tm *tmbuf;
4451 static const char * const dayname[] =
4452 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4453 static const char * const monname[] =
4454 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4455 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4461 when = (Time_t)SvNVx(POPs);
4463 when = (Time_t)SvIVx(POPs);
4466 if (PL_op->op_type == OP_LOCALTIME)
4467 #ifdef LOCALTIME_EDGECASE_BROKEN
4468 tmbuf = S_my_localtime(aTHX_ &when);
4470 tmbuf = localtime(&when);
4473 tmbuf = gmtime(&when);
4475 if (GIMME != G_ARRAY) {
4481 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4482 dayname[tmbuf->tm_wday],
4483 monname[tmbuf->tm_mon],
4488 tmbuf->tm_year + 1900);
4494 mPUSHi(tmbuf->tm_sec);
4495 mPUSHi(tmbuf->tm_min);
4496 mPUSHi(tmbuf->tm_hour);
4497 mPUSHi(tmbuf->tm_mday);
4498 mPUSHi(tmbuf->tm_mon);
4499 mPUSHi(tmbuf->tm_year);
4500 mPUSHi(tmbuf->tm_wday);
4501 mPUSHi(tmbuf->tm_yday);
4502 mPUSHi(tmbuf->tm_isdst);
4513 anum = alarm((unsigned int)anum);
4520 DIE(aTHX_ PL_no_func, "alarm");
4531 (void)time(&lasttime);
4536 PerlProc_sleep((unsigned int)duration);
4539 XPUSHi(when - lasttime);
4543 /* Shared memory. */
4544 /* Merged with some message passing. */
4548 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4549 dVAR; dSP; dMARK; dTARGET;
4550 const int op_type = PL_op->op_type;
4555 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4558 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4561 value = (I32)(do_semop(MARK, SP) >= 0);
4564 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4580 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4581 dVAR; dSP; dMARK; dTARGET;
4582 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4589 DIE(aTHX_ "System V IPC is not implemented on this machine");
4595 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4596 dVAR; dSP; dMARK; dTARGET;
4597 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4605 PUSHp(zero_but_true, ZBTLEN);
4613 /* I can't const this further without getting warnings about the types of
4614 various arrays passed in from structures. */
4616 S_space_join_names_mortal(pTHX_ char *const *array)
4620 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4622 if (array && *array) {
4623 target = newSVpvs_flags("", SVs_TEMP);
4625 sv_catpv(target, *array);
4628 sv_catpvs(target, " ");
4631 target = sv_mortalcopy(&PL_sv_no);
4636 /* Get system info. */
4640 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4642 I32 which = PL_op->op_type;
4643 register char **elem;
4645 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4646 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4647 struct hostent *gethostbyname(Netdb_name_t);
4648 struct hostent *gethostent(void);
4650 struct hostent *hent;
4654 if (which == OP_GHBYNAME) {
4655 #ifdef HAS_GETHOSTBYNAME
4656 const char* const name = POPpbytex;
4657 hent = PerlSock_gethostbyname(name);
4659 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4662 else if (which == OP_GHBYADDR) {
4663 #ifdef HAS_GETHOSTBYADDR
4664 const int addrtype = POPi;
4665 SV * const addrsv = POPs;
4667 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4669 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4671 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4675 #ifdef HAS_GETHOSTENT
4676 hent = PerlSock_gethostent();
4678 DIE(aTHX_ PL_no_sock_func, "gethostent");
4681 #ifdef HOST_NOT_FOUND
4683 #ifdef USE_REENTRANT_API
4684 # ifdef USE_GETHOSTENT_ERRNO
4685 h_errno = PL_reentrant_buffer->_gethostent_errno;
4688 STATUS_UNIX_SET(h_errno);
4692 if (GIMME != G_ARRAY) {
4693 PUSHs(sv = sv_newmortal());
4695 if (which == OP_GHBYNAME) {
4697 sv_setpvn(sv, hent->h_addr, hent->h_length);
4700 sv_setpv(sv, (char*)hent->h_name);
4706 mPUSHs(newSVpv((char*)hent->h_name, 0));
4707 PUSHs(space_join_names_mortal(hent->h_aliases));
4708 mPUSHi(hent->h_addrtype);
4709 len = hent->h_length;
4712 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4713 mXPUSHp(*elem, len);
4717 mPUSHp(hent->h_addr, len);
4719 PUSHs(sv_mortalcopy(&PL_sv_no));
4724 DIE(aTHX_ PL_no_sock_func, "gethostent");
4730 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4732 I32 which = PL_op->op_type;
4734 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4735 struct netent *getnetbyaddr(Netdb_net_t, int);
4736 struct netent *getnetbyname(Netdb_name_t);
4737 struct netent *getnetent(void);
4739 struct netent *nent;
4741 if (which == OP_GNBYNAME){
4742 #ifdef HAS_GETNETBYNAME
4743 const char * const name = POPpbytex;
4744 nent = PerlSock_getnetbyname(name);
4746 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4749 else if (which == OP_GNBYADDR) {
4750 #ifdef HAS_GETNETBYADDR
4751 const int addrtype = POPi;
4752 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4753 nent = PerlSock_getnetbyaddr(addr, addrtype);
4755 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4759 #ifdef HAS_GETNETENT
4760 nent = PerlSock_getnetent();
4762 DIE(aTHX_ PL_no_sock_func, "getnetent");
4765 #ifdef HOST_NOT_FOUND
4767 #ifdef USE_REENTRANT_API
4768 # ifdef USE_GETNETENT_ERRNO
4769 h_errno = PL_reentrant_buffer->_getnetent_errno;
4772 STATUS_UNIX_SET(h_errno);
4777 if (GIMME != G_ARRAY) {
4778 PUSHs(sv = sv_newmortal());
4780 if (which == OP_GNBYNAME)
4781 sv_setiv(sv, (IV)nent->n_net);
4783 sv_setpv(sv, nent->n_name);
4789 mPUSHs(newSVpv(nent->n_name, 0));
4790 PUSHs(space_join_names_mortal(nent->n_aliases));
4791 mPUSHi(nent->n_addrtype);
4792 mPUSHi(nent->n_net);
4797 DIE(aTHX_ PL_no_sock_func, "getnetent");
4803 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4805 I32 which = PL_op->op_type;
4807 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4808 struct protoent *getprotobyname(Netdb_name_t);
4809 struct protoent *getprotobynumber(int);
4810 struct protoent *getprotoent(void);
4812 struct protoent *pent;
4814 if (which == OP_GPBYNAME) {
4815 #ifdef HAS_GETPROTOBYNAME
4816 const char* const name = POPpbytex;
4817 pent = PerlSock_getprotobyname(name);
4819 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4822 else if (which == OP_GPBYNUMBER) {
4823 #ifdef HAS_GETPROTOBYNUMBER
4824 const int number = POPi;
4825 pent = PerlSock_getprotobynumber(number);
4827 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4831 #ifdef HAS_GETPROTOENT
4832 pent = PerlSock_getprotoent();
4834 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4838 if (GIMME != G_ARRAY) {
4839 PUSHs(sv = sv_newmortal());
4841 if (which == OP_GPBYNAME)
4842 sv_setiv(sv, (IV)pent->p_proto);
4844 sv_setpv(sv, pent->p_name);
4850 mPUSHs(newSVpv(pent->p_name, 0));
4851 PUSHs(space_join_names_mortal(pent->p_aliases));
4852 mPUSHi(pent->p_proto);
4857 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4863 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4865 I32 which = PL_op->op_type;
4867 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4868 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4869 struct servent *getservbyport(int, Netdb_name_t);
4870 struct servent *getservent(void);
4872 struct servent *sent;
4874 if (which == OP_GSBYNAME) {
4875 #ifdef HAS_GETSERVBYNAME
4876 const char * const proto = POPpbytex;
4877 const char * const name = POPpbytex;
4878 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4880 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4883 else if (which == OP_GSBYPORT) {
4884 #ifdef HAS_GETSERVBYPORT
4885 const char * const proto = POPpbytex;
4886 unsigned short port = (unsigned short)POPu;
4888 port = PerlSock_htons(port);
4890 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4892 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4896 #ifdef HAS_GETSERVENT
4897 sent = PerlSock_getservent();
4899 DIE(aTHX_ PL_no_sock_func, "getservent");
4903 if (GIMME != G_ARRAY) {
4904 PUSHs(sv = sv_newmortal());
4906 if (which == OP_GSBYNAME) {
4908 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4910 sv_setiv(sv, (IV)(sent->s_port));
4914 sv_setpv(sv, sent->s_name);
4920 mPUSHs(newSVpv(sent->s_name, 0));
4921 PUSHs(space_join_names_mortal(sent->s_aliases));
4923 mPUSHi(PerlSock_ntohs(sent->s_port));
4925 mPUSHi(sent->s_port);
4927 mPUSHs(newSVpv(sent->s_proto, 0));
4932 DIE(aTHX_ PL_no_sock_func, "getservent");
4938 #ifdef HAS_SETHOSTENT
4940 PerlSock_sethostent(TOPi);
4943 DIE(aTHX_ PL_no_sock_func, "sethostent");
4949 #ifdef HAS_SETNETENT
4951 (void)PerlSock_setnetent(TOPi);
4954 DIE(aTHX_ PL_no_sock_func, "setnetent");
4960 #ifdef HAS_SETPROTOENT
4962 (void)PerlSock_setprotoent(TOPi);
4965 DIE(aTHX_ PL_no_sock_func, "setprotoent");
4971 #ifdef HAS_SETSERVENT
4973 (void)PerlSock_setservent(TOPi);
4976 DIE(aTHX_ PL_no_sock_func, "setservent");
4982 #ifdef HAS_ENDHOSTENT
4984 PerlSock_endhostent();
4988 DIE(aTHX_ PL_no_sock_func, "endhostent");
4994 #ifdef HAS_ENDNETENT
4996 PerlSock_endnetent();
5000 DIE(aTHX_ PL_no_sock_func, "endnetent");
5006 #ifdef HAS_ENDPROTOENT
5008 PerlSock_endprotoent();
5012 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5018 #ifdef HAS_ENDSERVENT
5020 PerlSock_endservent();
5024 DIE(aTHX_ PL_no_sock_func, "endservent");
5032 I32 which = PL_op->op_type;
5034 struct passwd *pwent = NULL;
5036 * We currently support only the SysV getsp* shadow password interface.
5037 * The interface is declared in <shadow.h> and often one needs to link
5038 * with -lsecurity or some such.
5039 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5042 * AIX getpwnam() is clever enough to return the encrypted password
5043 * only if the caller (euid?) is root.
5045 * There are at least three other shadow password APIs. Many platforms
5046 * seem to contain more than one interface for accessing the shadow
5047 * password databases, possibly for compatibility reasons.
5048 * The getsp*() is by far he simplest one, the other two interfaces
5049 * are much more complicated, but also very similar to each other.
5054 * struct pr_passwd *getprpw*();
5055 * The password is in
5056 * char getprpw*(...).ufld.fd_encrypt[]
5057 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5062 * struct es_passwd *getespw*();
5063 * The password is in
5064 * char *(getespw*(...).ufld.fd_encrypt)
5065 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5068 * struct userpw *getuserpw();
5069 * The password is in
5070 * char *(getuserpw(...)).spw_upw_passwd
5071 * (but the de facto standard getpwnam() should work okay)
5073 * Mention I_PROT here so that Configure probes for it.
5075 * In HP-UX for getprpw*() the manual page claims that one should include
5076 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5077 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5078 * and pp_sys.c already includes <shadow.h> if there is such.
5080 * Note that <sys/security.h> is already probed for, but currently
5081 * it is only included in special cases.
5083 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5084 * be preferred interface, even though also the getprpw*() interface
5085 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5086 * One also needs to call set_auth_parameters() in main() before
5087 * doing anything else, whether one is using getespw*() or getprpw*().
5089 * Note that accessing the shadow databases can be magnitudes
5090 * slower than accessing the standard databases.
5095 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5096 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5097 * the pw_comment is left uninitialized. */
5098 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5104 const char* const name = POPpbytex;
5105 pwent = getpwnam(name);
5111 pwent = getpwuid(uid);
5115 # ifdef HAS_GETPWENT
5117 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5118 if (pwent) pwent = getpwnam(pwent->pw_name);
5121 DIE(aTHX_ PL_no_func, "getpwent");
5127 if (GIMME != G_ARRAY) {
5128 PUSHs(sv = sv_newmortal());
5130 if (which == OP_GPWNAM)
5131 # if Uid_t_sign <= 0
5132 sv_setiv(sv, (IV)pwent->pw_uid);
5134 sv_setuv(sv, (UV)pwent->pw_uid);
5137 sv_setpv(sv, pwent->pw_name);
5143 mPUSHs(newSVpv(pwent->pw_name, 0));
5147 /* If we have getspnam(), we try to dig up the shadow
5148 * password. If we are underprivileged, the shadow
5149 * interface will set the errno to EACCES or similar,
5150 * and return a null pointer. If this happens, we will
5151 * use the dummy password (usually "*" or "x") from the
5152 * standard password database.
5154 * In theory we could skip the shadow call completely
5155 * if euid != 0 but in practice we cannot know which
5156 * security measures are guarding the shadow databases
5157 * on a random platform.
5159 * Resist the urge to use additional shadow interfaces.
5160 * Divert the urge to writing an extension instead.
5163 /* Some AIX setups falsely(?) detect some getspnam(), which
5164 * has a different API than the Solaris/IRIX one. */
5165 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5167 const int saverrno = errno;
5168 const struct spwd * const spwent = getspnam(pwent->pw_name);
5169 /* Save and restore errno so that
5170 * underprivileged attempts seem
5171 * to have never made the unsccessful
5172 * attempt to retrieve the shadow password. */
5174 if (spwent && spwent->sp_pwdp)
5175 sv_setpv(sv, spwent->sp_pwdp);
5179 if (!SvPOK(sv)) /* Use the standard password, then. */
5180 sv_setpv(sv, pwent->pw_passwd);
5183 # ifndef INCOMPLETE_TAINTS
5184 /* passwd is tainted because user himself can diddle with it.
5185 * admittedly not much and in a very limited way, but nevertheless. */
5189 # if Uid_t_sign <= 0
5190 mPUSHi(pwent->pw_uid);
5192 mPUSHu(pwent->pw_uid);
5195 # if Uid_t_sign <= 0
5196 mPUSHi(pwent->pw_gid);
5198 mPUSHu(pwent->pw_gid);
5200 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5201 * because of the poor interface of the Perl getpw*(),
5202 * not because there's some standard/convention saying so.
5203 * A better interface would have been to return a hash,
5204 * but we are accursed by our history, alas. --jhi. */
5206 mPUSHi(pwent->pw_change);
5209 mPUSHi(pwent->pw_quota);
5212 mPUSHs(newSVpv(pwent->pw_age, 0));
5214 /* I think that you can never get this compiled, but just in case. */
5215 PUSHs(sv_mortalcopy(&PL_sv_no));
5220 /* pw_class and pw_comment are mutually exclusive--.
5221 * see the above note for pw_change, pw_quota, and pw_age. */
5223 mPUSHs(newSVpv(pwent->pw_class, 0));
5226 mPUSHs(newSVpv(pwent->pw_comment, 0));
5228 /* I think that you can never get this compiled, but just in case. */
5229 PUSHs(sv_mortalcopy(&PL_sv_no));
5234 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5236 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5238 # ifndef INCOMPLETE_TAINTS
5239 /* pw_gecos is tainted because user himself can diddle with it. */
5243 mPUSHs(newSVpv(pwent->pw_dir, 0));
5245 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5246 # ifndef INCOMPLETE_TAINTS
5247 /* pw_shell is tainted because user himself can diddle with it. */
5252 mPUSHi(pwent->pw_expire);
5257 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5263 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5268 DIE(aTHX_ PL_no_func, "setpwent");
5274 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5279 DIE(aTHX_ PL_no_func, "endpwent");
5287 const I32 which = PL_op->op_type;
5288 const struct group *grent;
5290 if (which == OP_GGRNAM) {
5291 const char* const name = POPpbytex;
5292 grent = (const struct group *)getgrnam(name);
5294 else if (which == OP_GGRGID) {
5295 const Gid_t gid = POPi;
5296 grent = (const struct group *)getgrgid(gid);
5300 grent = (struct group *)getgrent();
5302 DIE(aTHX_ PL_no_func, "getgrent");
5306 if (GIMME != G_ARRAY) {
5307 SV * const sv = sv_newmortal();
5311 if (which == OP_GGRNAM)
5312 sv_setiv(sv, (IV)grent->gr_gid);
5314 sv_setpv(sv, grent->gr_name);
5320 mPUSHs(newSVpv(grent->gr_name, 0));
5323 mPUSHs(newSVpv(grent->gr_passwd, 0));
5325 PUSHs(sv_mortalcopy(&PL_sv_no));
5328 mPUSHi(grent->gr_gid);
5330 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5331 /* In UNICOS/mk (_CRAYMPP) the multithreading
5332 * versions (getgrnam_r, getgrgid_r)
5333 * seem to return an illegal pointer
5334 * as the group members list, gr_mem.
5335 * getgrent() doesn't even have a _r version
5336 * but the gr_mem is poisonous anyway.
5337 * So yes, you cannot get the list of group
5338 * members if building multithreaded in UNICOS/mk. */
5339 PUSHs(space_join_names_mortal(grent->gr_mem));
5345 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5351 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5356 DIE(aTHX_ PL_no_func, "setgrent");
5362 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5367 DIE(aTHX_ PL_no_func, "endgrent");
5377 if (!(tmps = PerlProc_getlogin()))
5379 PUSHp(tmps, strlen(tmps));
5382 DIE(aTHX_ PL_no_func, "getlogin");
5386 /* Miscellaneous. */
5391 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5392 register I32 items = SP - MARK;
5393 unsigned long a[20];
5398 while (++MARK <= SP) {
5399 if (SvTAINTED(*MARK)) {
5405 TAINT_PROPER("syscall");
5408 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5409 * or where sizeof(long) != sizeof(char*). But such machines will
5410 * not likely have syscall implemented either, so who cares?
5412 while (++MARK <= SP) {
5413 if (SvNIOK(*MARK) || !i)
5414 a[i++] = SvIV(*MARK);
5415 else if (*MARK == &PL_sv_undef)
5418 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5424 DIE(aTHX_ "Too many args to syscall");
5426 DIE(aTHX_ "Too few args to syscall");
5428 retval = syscall(a[0]);
5431 retval = syscall(a[0],a[1]);
5434 retval = syscall(a[0],a[1],a[2]);
5437 retval = syscall(a[0],a[1],a[2],a[3]);
5440 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5443 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5446 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5449 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5453 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5456 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5459 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5463 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5467 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5471 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5472 a[10],a[11],a[12],a[13]);
5474 #endif /* atarist */
5480 DIE(aTHX_ PL_no_func, "syscall");
5484 #ifdef FCNTL_EMULATE_FLOCK
5486 /* XXX Emulate flock() with fcntl().
5487 What's really needed is a good file locking module.
5491 fcntl_emulate_flock(int fd, int operation)
5495 switch (operation & ~LOCK_NB) {
5497 flock.l_type = F_RDLCK;
5500 flock.l_type = F_WRLCK;
5503 flock.l_type = F_UNLCK;
5509 flock.l_whence = SEEK_SET;
5510 flock.l_start = flock.l_len = (Off_t)0;
5512 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5515 #endif /* FCNTL_EMULATE_FLOCK */
5517 #ifdef LOCKF_EMULATE_FLOCK
5519 /* XXX Emulate flock() with lockf(). This is just to increase
5520 portability of scripts. The calls are not completely
5521 interchangeable. What's really needed is a good file
5525 /* The lockf() constants might have been defined in <unistd.h>.
5526 Unfortunately, <unistd.h> causes troubles on some mixed
5527 (BSD/POSIX) systems, such as SunOS 4.1.3.
5529 Further, the lockf() constants aren't POSIX, so they might not be
5530 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5531 just stick in the SVID values and be done with it. Sigh.
5535 # define F_ULOCK 0 /* Unlock a previously locked region */
5538 # define F_LOCK 1 /* Lock a region for exclusive use */
5541 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5544 # define F_TEST 3 /* Test a region for other processes locks */
5548 lockf_emulate_flock(int fd, int operation)
5551 const int save_errno = errno;
5554 /* flock locks entire file so for lockf we need to do the same */
5555 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5556 if (pos > 0) /* is seekable and needs to be repositioned */
5557 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5558 pos = -1; /* seek failed, so don't seek back afterwards */
5561 switch (operation) {
5563 /* LOCK_SH - get a shared lock */
5565 /* LOCK_EX - get an exclusive lock */
5567 i = lockf (fd, F_LOCK, 0);
5570 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5571 case LOCK_SH|LOCK_NB:
5572 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5573 case LOCK_EX|LOCK_NB:
5574 i = lockf (fd, F_TLOCK, 0);
5576 if ((errno == EAGAIN) || (errno == EACCES))
5577 errno = EWOULDBLOCK;
5580 /* LOCK_UN - unlock (non-blocking is a no-op) */
5582 case LOCK_UN|LOCK_NB:
5583 i = lockf (fd, F_ULOCK, 0);
5586 /* Default - can't decipher operation */
5593 if (pos > 0) /* need to restore position of the handle */
5594 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5599 #endif /* LOCKF_EMULATE_FLOCK */
5603 * c-indentation-style: bsd
5605 * indent-tabs-mode: t
5608 * ex: set ts=8 sts=4 sw=4 noet: