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) (emulate_eaccess((p), (f)))
303 #if !defined(PERL_EFF_ACCESS)
304 /* With it or without it: anyway you get a warning: either that
305 it is unused, or it is declared static and never defined.
308 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
310 PERL_UNUSED_ARG(path);
311 PERL_UNUSED_ARG(mode);
312 Perl_croak(aTHX_ "switching effective uid is not implemented");
322 const char * const tmps = POPpconstx;
323 const I32 gimme = GIMME_V;
324 const char *mode = "r";
327 if (PL_op->op_private & OPpOPEN_IN_RAW)
329 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
331 fp = PerlProc_popen(tmps, mode);
333 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
335 PerlIO_apply_layers(aTHX_ fp,mode,type);
337 if (gimme == G_VOID) {
339 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
342 else if (gimme == G_SCALAR) {
345 PL_rs = &PL_sv_undef;
346 sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */
347 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
355 SV * const sv = newSV(79);
356 if (sv_gets(sv, fp, 0) == NULL) {
360 XPUSHs(sv_2mortal(sv));
361 if (SvLEN(sv) - SvCUR(sv) > 20) {
362 SvPV_shrink_to_cur(sv);
367 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
368 TAINT; /* "I believe that this is not gratuitous!" */
371 STATUS_NATIVE_CHILD_SET(-1);
372 if (gimme == G_SCALAR)
383 tryAMAGICunTARGET(iter, -1);
385 /* Note that we only ever get here if File::Glob fails to load
386 * without at the same time croaking, for some reason, or if
387 * perl was built with PERL_EXTERNAL_GLOB */
394 * The external globbing program may use things we can't control,
395 * so for security reasons we must assume the worst.
398 taint_proper(PL_no_security, "glob");
402 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
403 PL_last_in_gv = (GV*)*PL_stack_sp--;
405 SAVESPTR(PL_rs); /* This is not permanent, either. */
406 PL_rs = sv_2mortal(newSVpvs("\000"));
409 *SvPVX(PL_rs) = '\n';
413 result = do_readline();
421 PL_last_in_gv = cGVOP_gv;
422 return do_readline();
433 do_join(TARG, &PL_sv_no, MARK, SP);
437 else if (SP == MARK) {
445 tmps = SvPV_const(tmpsv, len);
446 if ((!tmps || !len) && PL_errgv) {
447 SV * const error = ERRSV;
448 SvUPGRADE(error, SVt_PV);
449 if (SvPOK(error) && SvCUR(error))
450 sv_catpvs(error, "\t...caught");
452 tmps = SvPV_const(tmpsv, len);
455 tmpsv = sv_2mortal(newSVpvs("Warning: something's wrong"));
457 Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv));
469 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
471 if (SP - MARK != 1) {
473 do_join(TARG, &PL_sv_no, MARK, SP);
475 tmps = SvPV_const(tmpsv, len);
481 tmps = SvROK(tmpsv) ? NULL : SvPV_const(tmpsv, len);
484 SV * const error = ERRSV;
485 SvUPGRADE(error, SVt_PV);
486 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
488 SvSetSV(error,tmpsv);
489 else if (sv_isobject(error)) {
490 HV * const stash = SvSTASH(SvRV(error));
491 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
493 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
494 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
501 call_sv((SV*)GvCV(gv),
502 G_SCALAR|G_EVAL|G_KEEPERR);
503 sv_setsv(error,*PL_stack_sp--);
509 if (SvPOK(error) && SvCUR(error))
510 sv_catpvs(error, "\t...propagated");
513 tmps = SvPV_const(tmpsv, len);
519 tmpsv = sv_2mortal(newSVpvs("Died"));
521 DIE(aTHX_ "%"SVf, SVfARG(tmpsv));
537 GV * const gv = (GV *)*++MARK;
540 DIE(aTHX_ PL_no_usym, "filehandle");
541 if ((io = GvIOp(gv))) {
543 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
545 mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
547 /* Method's args are same as ours ... */
548 /* ... except handle is replaced by the object */
549 *MARK-- = SvTIED_obj((SV*)io, mg);
553 call_method("OPEN", G_SCALAR);
567 tmps = SvPV_const(sv, len);
568 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
571 PUSHi( (I32)PL_forkprocess );
572 else if (PL_forkprocess == 0) /* we are a new child */
582 GV * const gv = (MAXARG == 0) ? PL_defoutgv : (GV*)POPs;
585 IO * const io = GvIO(gv);
587 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
590 XPUSHs(SvTIED_obj((SV*)io, mg));
593 call_method("CLOSE", G_SCALAR);
601 PUSHs(boolSV(do_close(gv, TRUE)));
614 GV * const wgv = (GV*)POPs;
615 GV * const rgv = (GV*)POPs;
620 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
621 DIE(aTHX_ PL_no_usym, "filehandle");
626 do_close(rgv, FALSE);
628 do_close(wgv, FALSE);
630 if (PerlProc_pipe(fd) < 0)
633 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
634 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
635 IoOFP(rstio) = IoIFP(rstio);
636 IoIFP(wstio) = IoOFP(wstio);
637 IoTYPE(rstio) = IoTYPE_RDONLY;
638 IoTYPE(wstio) = IoTYPE_WRONLY;
640 if (!IoIFP(rstio) || !IoOFP(wstio)) {
642 PerlIO_close(IoIFP(rstio));
644 PerlLIO_close(fd[0]);
646 PerlIO_close(IoOFP(wstio));
648 PerlLIO_close(fd[1]);
651 #if defined(HAS_FCNTL) && defined(F_SETFD)
652 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
653 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
660 DIE(aTHX_ PL_no_func, "pipe");
676 if (gv && (io = GvIO(gv))
677 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
680 XPUSHs(SvTIED_obj((SV*)io, mg));
683 call_method("FILENO", G_SCALAR);
689 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
690 /* Can't do this because people seem to do things like
691 defined(fileno($foo)) to check whether $foo is a valid fh.
692 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
693 report_evil_fh(gv, io, PL_op->op_type);
698 PUSHi(PerlIO_fileno(fp));
711 anum = PerlLIO_umask(022);
712 /* setting it to 022 between the two calls to umask avoids
713 * to have a window where the umask is set to 0 -- meaning
714 * that another thread could create world-writeable files. */
716 (void)PerlLIO_umask(anum);
719 anum = PerlLIO_umask(POPi);
720 TAINT_PROPER("umask");
723 /* Only DIE if trying to restrict permissions on "user" (self).
724 * Otherwise it's harmless and more useful to just return undef
725 * since 'group' and 'other' concepts probably don't exist here. */
726 if (MAXARG >= 1 && (POPi & 0700))
727 DIE(aTHX_ "umask not implemented");
728 XPUSHs(&PL_sv_undef);
749 if (gv && (io = GvIO(gv))) {
750 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
753 XPUSHs(SvTIED_obj((SV*)io, mg));
758 call_method("BINMODE", G_SCALAR);
766 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
767 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
768 report_evil_fh(gv, io, PL_op->op_type);
769 SETERRNO(EBADF,RMS_IFI);
775 const int mode = mode_from_discipline(discp);
776 const char *const d = (discp ? SvPV_nolen_const(discp) : NULL);
777 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
778 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
779 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
800 const I32 markoff = MARK - PL_stack_base;
801 const char *methname;
802 int how = PERL_MAGIC_tied;
806 switch(SvTYPE(varsv)) {
808 methname = "TIEHASH";
809 HvEITER_set((HV *)varsv, 0);
812 methname = "TIEARRAY";
815 #ifdef GV_UNIQUE_CHECK
816 if (GvUNIQUE((GV*)varsv)) {
817 Perl_croak(aTHX_ "Attempt to tie unique GV");
820 methname = "TIEHANDLE";
821 how = PERL_MAGIC_tiedscalar;
822 /* For tied filehandles, we apply tiedscalar magic to the IO
823 slot of the GP rather than the GV itself. AMS 20010812 */
825 GvIOp(varsv) = newIO();
826 varsv = (SV *)GvIOp(varsv);
829 methname = "TIESCALAR";
830 how = PERL_MAGIC_tiedscalar;
834 if (sv_isobject(*MARK)) {
836 PUSHSTACKi(PERLSI_MAGIC);
838 EXTEND(SP,(I32)items);
842 call_method(methname, G_SCALAR);
845 /* Not clear why we don't call call_method here too.
846 * perhaps to get different error message ?
848 stash = gv_stashsv(*MARK, 0);
849 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
850 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
851 methname, SVfARG(*MARK));
854 PUSHSTACKi(PERLSI_MAGIC);
856 EXTEND(SP,(I32)items);
860 call_sv((SV*)GvCV(gv), G_SCALAR);
866 if (sv_isobject(sv)) {
867 sv_unmagic(varsv, how);
868 /* Croak if a self-tie on an aggregate is attempted. */
869 if (varsv == SvRV(sv) &&
870 (SvTYPE(varsv) == SVt_PVAV ||
871 SvTYPE(varsv) == SVt_PVHV))
873 "Self-ties of arrays and hashes are not supported");
874 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
877 SP = PL_stack_base + markoff;
887 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
888 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
890 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
893 if ((mg = SvTIED_mg(sv, how))) {
894 SV * const obj = SvRV(SvTIED_obj(sv, mg));
896 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
898 if (gv && isGV(gv) && (cv = GvCV(gv))) {
900 XPUSHs(SvTIED_obj((SV*)gv, mg));
901 XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
904 call_sv((SV *)cv, G_VOID);
908 else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
909 Perl_warner(aTHX_ packWARN(WARN_UNTIE),
910 "untie attempted while %"UVuf" inner references still exist",
911 (UV)SvREFCNT(obj) - 1 ) ;
915 sv_unmagic(sv, how) ;
925 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
926 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
928 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
931 if ((mg = SvTIED_mg(sv, how))) {
932 SV *osv = SvTIED_obj(sv, mg);
933 if (osv == mg->mg_obj)
934 osv = sv_mortalcopy(osv);
948 HV * const hv = (HV*)POPs;
949 SV * const sv = sv_2mortal(newSVpvs("AnyDBM_File"));
950 stash = gv_stashsv(sv, 0);
951 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
953 require_pv("AnyDBM_File.pm");
955 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
956 DIE(aTHX_ "No dbm on this machine");
966 PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
968 PUSHs(sv_2mortal(newSVuv(O_RDWR)));
971 call_sv((SV*)GvCV(gv), G_SCALAR);
974 if (!sv_isobject(TOPs)) {
979 PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
982 call_sv((SV*)GvCV(gv), G_SCALAR);
986 if (sv_isobject(TOPs)) {
987 sv_unmagic((SV *) hv, PERL_MAGIC_tied);
988 sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, NULL, 0);
1005 struct timeval timebuf;
1006 struct timeval *tbuf = &timebuf;
1009 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1014 # if BYTEORDER & 0xf0000
1015 # define ORDERBYTE (0x88888888 - BYTEORDER)
1017 # define ORDERBYTE (0x4444 - BYTEORDER)
1023 for (i = 1; i <= 3; i++) {
1024 SV * const sv = SP[i];
1027 if (SvREADONLY(sv)) {
1029 sv_force_normal_flags(sv, 0);
1030 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1031 DIE(aTHX_ PL_no_modify);
1034 if (ckWARN(WARN_MISC))
1035 Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1036 SvPV_force_nolen(sv); /* force string conversion */
1043 /* little endians can use vecs directly */
1044 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1051 masksize = NFDBITS / NBBY;
1053 masksize = sizeof(long); /* documented int, everyone seems to use long */
1055 Zero(&fd_sets[0], 4, char*);
1058 # if SELECT_MIN_BITS == 1
1059 growsize = sizeof(fd_set);
1061 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1062 # undef SELECT_MIN_BITS
1063 # define SELECT_MIN_BITS __FD_SETSIZE
1065 /* If SELECT_MIN_BITS is greater than one we most probably will want
1066 * to align the sizes with SELECT_MIN_BITS/8 because for example
1067 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1068 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1069 * on (sets/tests/clears bits) is 32 bits. */
1070 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1078 timebuf.tv_sec = (long)value;
1079 value -= (NV)timebuf.tv_sec;
1080 timebuf.tv_usec = (long)(value * 1000000.0);
1085 for (i = 1; i <= 3; i++) {
1087 if (!SvOK(sv) || SvCUR(sv) == 0) {
1094 Sv_Grow(sv, growsize);
1098 while (++j <= growsize) {
1102 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1104 Newx(fd_sets[i], growsize, char);
1105 for (offset = 0; offset < growsize; offset += masksize) {
1106 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1107 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1110 fd_sets[i] = SvPVX(sv);
1114 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1115 /* Can't make just the (void*) conditional because that would be
1116 * cpp #if within cpp macro, and not all compilers like that. */
1117 nfound = PerlSock_select(
1119 (Select_fd_set_t) fd_sets[1],
1120 (Select_fd_set_t) fd_sets[2],
1121 (Select_fd_set_t) fd_sets[3],
1122 (void*) tbuf); /* Workaround for compiler bug. */
1124 nfound = PerlSock_select(
1126 (Select_fd_set_t) fd_sets[1],
1127 (Select_fd_set_t) fd_sets[2],
1128 (Select_fd_set_t) fd_sets[3],
1131 for (i = 1; i <= 3; i++) {
1134 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1136 for (offset = 0; offset < growsize; offset += masksize) {
1137 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1138 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1140 Safefree(fd_sets[i]);
1147 if (GIMME == G_ARRAY && tbuf) {
1148 value = (NV)(timebuf.tv_sec) +
1149 (NV)(timebuf.tv_usec) / 1000000.0;
1150 PUSHs(sv_2mortal(newSVnv(value)));
1154 DIE(aTHX_ "select not implemented");
1159 Perl_setdefout(pTHX_ GV *gv)
1162 SvREFCNT_inc_simple_void(gv);
1164 SvREFCNT_dec(PL_defoutgv);
1172 GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : NULL;
1173 GV * egv = GvEGV(PL_defoutgv);
1179 XPUSHs(&PL_sv_undef);
1181 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1182 if (gvp && *gvp == egv) {
1183 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1187 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1192 if (!GvIO(newdefout))
1193 gv_IOadd(newdefout);
1194 setdefout(newdefout);
1204 GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs;
1206 if (gv && (io = GvIO(gv))) {
1207 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1209 const I32 gimme = GIMME_V;
1211 XPUSHs(SvTIED_obj((SV*)io, mg));
1214 call_method("GETC", gimme);
1217 if (gimme == G_SCALAR)
1218 SvSetMagicSV_nosteal(TARG, TOPs);
1222 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1223 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1224 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1225 report_evil_fh(gv, io, PL_op->op_type);
1226 SETERRNO(EBADF,RMS_IFI);
1230 sv_setpvn(TARG, " ", 1);
1231 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1232 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1233 /* Find out how many bytes the char needs */
1234 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1237 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1238 SvCUR_set(TARG,1+len);
1247 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1250 register PERL_CONTEXT *cx;
1251 const I32 gimme = GIMME_V;
1256 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1258 cx->blk_sub.retop = 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_sub.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);
2025 sv_setpvn(GvSV(gv), "-", 1);
2026 SvSETMAGIC(GvSV(gv));
2028 else if (!nextargv(gv))
2033 gv = PL_last_in_gv; /* eof */
2036 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
2039 IO * const io = GvIO(gv);
2041 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
2043 XPUSHs(SvTIED_obj((SV*)io, mg));
2046 call_method("EOF", G_SCALAR);
2053 PUSHs(boolSV(!gv || do_eof(gv)));
2064 PL_last_in_gv = (GV*)POPs;
2067 if (gv && (io = GvIO(gv))) {
2068 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2071 XPUSHs(SvTIED_obj((SV*)io, mg));
2074 call_method("TELL", G_SCALAR);
2081 #if LSEEKSIZE > IVSIZE
2082 PUSHn( do_tell(gv) );
2084 PUSHi( do_tell(gv) );
2092 const int whence = POPi;
2093 #if LSEEKSIZE > IVSIZE
2094 const Off_t offset = (Off_t)SvNVx(POPs);
2096 const Off_t offset = (Off_t)SvIVx(POPs);
2099 GV * const gv = PL_last_in_gv = (GV*)POPs;
2102 if (gv && (io = GvIO(gv))) {
2103 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2106 XPUSHs(SvTIED_obj((SV*)io, mg));
2107 #if LSEEKSIZE > IVSIZE
2108 XPUSHs(sv_2mortal(newSVnv((NV) offset)));
2110 XPUSHs(sv_2mortal(newSViv(offset)));
2112 XPUSHs(sv_2mortal(newSViv(whence)));
2115 call_method("SEEK", G_SCALAR);
2122 if (PL_op->op_type == OP_SEEK)
2123 PUSHs(boolSV(do_seek(gv, offset, whence)));
2125 const Off_t sought = do_sysseek(gv, offset, whence);
2127 PUSHs(&PL_sv_undef);
2129 SV* const sv = sought ?
2130 #if LSEEKSIZE > IVSIZE
2135 : newSVpvn(zero_but_true, ZBTLEN);
2136 PUSHs(sv_2mortal(sv));
2146 /* There seems to be no consensus on the length type of truncate()
2147 * and ftruncate(), both off_t and size_t have supporters. In
2148 * general one would think that when using large files, off_t is
2149 * at least as wide as size_t, so using an off_t should be okay. */
2150 /* XXX Configure probe for the length type of *truncate() needed XXX */
2153 #if Off_t_size > IVSIZE
2158 /* Checking for length < 0 is problematic as the type might or
2159 * might not be signed: if it is not, clever compilers will moan. */
2160 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2167 if (PL_op->op_flags & OPf_SPECIAL) {
2168 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2177 TAINT_PROPER("truncate");
2178 if (!(fp = IoIFP(io))) {
2184 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2186 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2193 SV * const sv = POPs;
2196 if (SvTYPE(sv) == SVt_PVGV) {
2197 tmpgv = (GV*)sv; /* *main::FRED for example */
2198 goto do_ftruncate_gv;
2200 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2201 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
2202 goto do_ftruncate_gv;
2204 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2205 io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
2206 goto do_ftruncate_io;
2209 name = SvPV_nolen_const(sv);
2210 TAINT_PROPER("truncate");
2212 if (truncate(name, len) < 0)
2216 const int tmpfd = PerlLIO_open(name, O_RDWR);
2221 if (my_chsize(tmpfd, len) < 0)
2223 PerlLIO_close(tmpfd);
2232 SETERRNO(EBADF,RMS_IFI);
2240 SV * const argsv = POPs;
2241 const unsigned int func = POPu;
2242 const int optype = PL_op->op_type;
2243 GV * const gv = (GV*)POPs;
2244 IO * const io = gv ? GvIOn(gv) : NULL;
2248 if (!io || !argsv || !IoIFP(io)) {
2249 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2250 report_evil_fh(gv, io, PL_op->op_type);
2251 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2255 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2258 s = SvPV_force(argsv, len);
2259 need = IOCPARM_LEN(func);
2261 s = Sv_Grow(argsv, need + 1);
2262 SvCUR_set(argsv, need);
2265 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2268 retval = SvIV(argsv);
2269 s = INT2PTR(char*,retval); /* ouch */
2272 TAINT_PROPER(PL_op_desc[optype]);
2274 if (optype == OP_IOCTL)
2276 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2278 DIE(aTHX_ "ioctl is not implemented");
2282 DIE(aTHX_ "fcntl is not implemented");
2284 #if defined(OS2) && defined(__EMX__)
2285 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2287 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2291 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2293 if (s[SvCUR(argsv)] != 17)
2294 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2296 s[SvCUR(argsv)] = 0; /* put our null back */
2297 SvSETMAGIC(argsv); /* Assume it has changed */
2306 PUSHp(zero_but_true, ZBTLEN);
2319 const int argtype = POPi;
2320 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
2322 if (gv && (io = GvIO(gv)))
2328 /* XXX Looks to me like io is always NULL at this point */
2330 (void)PerlIO_flush(fp);
2331 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2334 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2335 report_evil_fh(gv, io, PL_op->op_type);
2337 SETERRNO(EBADF,RMS_IFI);
2342 DIE(aTHX_ PL_no_func, "flock()");
2352 const int protocol = POPi;
2353 const int type = POPi;
2354 const int domain = POPi;
2355 GV * const gv = (GV*)POPs;
2356 register IO * const io = gv ? GvIOn(gv) : NULL;
2360 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2361 report_evil_fh(gv, io, PL_op->op_type);
2362 if (io && IoIFP(io))
2363 do_close(gv, FALSE);
2364 SETERRNO(EBADF,LIB_INVARG);
2369 do_close(gv, FALSE);
2371 TAINT_PROPER("socket");
2372 fd = PerlSock_socket(domain, type, protocol);
2375 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2376 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2377 IoTYPE(io) = IoTYPE_SOCKET;
2378 if (!IoIFP(io) || !IoOFP(io)) {
2379 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2380 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2381 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2384 #if defined(HAS_FCNTL) && defined(F_SETFD)
2385 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2389 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2394 DIE(aTHX_ PL_no_sock_func, "socket");
2400 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2402 const int protocol = POPi;
2403 const int type = POPi;
2404 const int domain = POPi;
2405 GV * const gv2 = (GV*)POPs;
2406 GV * const gv1 = (GV*)POPs;
2407 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2408 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2411 if (!gv1 || !gv2 || !io1 || !io2) {
2412 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2414 report_evil_fh(gv1, io1, PL_op->op_type);
2416 report_evil_fh(gv1, io2, PL_op->op_type);
2418 if (io1 && IoIFP(io1))
2419 do_close(gv1, FALSE);
2420 if (io2 && IoIFP(io2))
2421 do_close(gv2, FALSE);
2426 do_close(gv1, FALSE);
2428 do_close(gv2, FALSE);
2430 TAINT_PROPER("socketpair");
2431 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2433 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2434 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2435 IoTYPE(io1) = IoTYPE_SOCKET;
2436 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2437 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2438 IoTYPE(io2) = IoTYPE_SOCKET;
2439 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2440 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2441 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2442 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2443 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2444 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2445 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2448 #if defined(HAS_FCNTL) && defined(F_SETFD)
2449 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2450 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2455 DIE(aTHX_ PL_no_sock_func, "socketpair");
2463 SV * const addrsv = POPs;
2464 /* OK, so on what platform does bind modify addr? */
2466 GV * const gv = (GV*)POPs;
2467 register IO * const io = GvIOn(gv);
2470 if (!io || !IoIFP(io))
2473 addr = SvPV_const(addrsv, len);
2474 TAINT_PROPER("bind");
2475 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2481 if (ckWARN(WARN_CLOSED))
2482 report_evil_fh(gv, io, PL_op->op_type);
2483 SETERRNO(EBADF,SS_IVCHAN);
2486 DIE(aTHX_ PL_no_sock_func, "bind");
2494 SV * const addrsv = POPs;
2495 GV * const gv = (GV*)POPs;
2496 register IO * const io = GvIOn(gv);
2500 if (!io || !IoIFP(io))
2503 addr = SvPV_const(addrsv, len);
2504 TAINT_PROPER("connect");
2505 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2511 if (ckWARN(WARN_CLOSED))
2512 report_evil_fh(gv, io, PL_op->op_type);
2513 SETERRNO(EBADF,SS_IVCHAN);
2516 DIE(aTHX_ PL_no_sock_func, "connect");
2524 const int backlog = POPi;
2525 GV * const gv = (GV*)POPs;
2526 register IO * const io = gv ? GvIOn(gv) : NULL;
2528 if (!gv || !io || !IoIFP(io))
2531 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2537 if (ckWARN(WARN_CLOSED))
2538 report_evil_fh(gv, io, PL_op->op_type);
2539 SETERRNO(EBADF,SS_IVCHAN);
2542 DIE(aTHX_ PL_no_sock_func, "listen");
2552 char namebuf[MAXPATHLEN];
2553 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2554 Sock_size_t len = sizeof (struct sockaddr_in);
2556 Sock_size_t len = sizeof namebuf;
2558 GV * const ggv = (GV*)POPs;
2559 GV * const ngv = (GV*)POPs;
2568 if (!gstio || !IoIFP(gstio))
2572 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2575 /* Some platforms indicate zero length when an AF_UNIX client is
2576 * not bound. Simulate a non-zero-length sockaddr structure in
2578 namebuf[0] = 0; /* sun_len */
2579 namebuf[1] = AF_UNIX; /* sun_family */
2587 do_close(ngv, FALSE);
2588 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2589 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2590 IoTYPE(nstio) = IoTYPE_SOCKET;
2591 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2592 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2593 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2594 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2597 #if defined(HAS_FCNTL) && defined(F_SETFD)
2598 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2602 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2603 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2605 #ifdef __SCO_VERSION__
2606 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2609 PUSHp(namebuf, len);
2613 if (ckWARN(WARN_CLOSED))
2614 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2615 SETERRNO(EBADF,SS_IVCHAN);
2621 DIE(aTHX_ PL_no_sock_func, "accept");
2629 const int how = POPi;
2630 GV * const gv = (GV*)POPs;
2631 register IO * const io = GvIOn(gv);
2633 if (!io || !IoIFP(io))
2636 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2640 if (ckWARN(WARN_CLOSED))
2641 report_evil_fh(gv, io, PL_op->op_type);
2642 SETERRNO(EBADF,SS_IVCHAN);
2645 DIE(aTHX_ PL_no_sock_func, "shutdown");
2653 const int optype = PL_op->op_type;
2654 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2655 const unsigned int optname = (unsigned int) POPi;
2656 const unsigned int lvl = (unsigned int) POPi;
2657 GV * const gv = (GV*)POPs;
2658 register IO * const io = GvIOn(gv);
2662 if (!io || !IoIFP(io))
2665 fd = PerlIO_fileno(IoIFP(io));
2669 (void)SvPOK_only(sv);
2673 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2680 #if defined(__SYMBIAN32__)
2681 # define SETSOCKOPT_OPTION_VALUE_T void *
2683 # define SETSOCKOPT_OPTION_VALUE_T const char *
2685 /* XXX TODO: We need to have a proper type (a Configure probe,
2686 * etc.) for what the C headers think of the third argument of
2687 * setsockopt(), the option_value read-only buffer: is it
2688 * a "char *", or a "void *", const or not. Some compilers
2689 * don't take kindly to e.g. assuming that "char *" implicitly
2690 * promotes to a "void *", or to explicitly promoting/demoting
2691 * consts to non/vice versa. The "const void *" is the SUS
2692 * definition, but that does not fly everywhere for the above
2694 SETSOCKOPT_OPTION_VALUE_T buf;
2698 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2702 aint = (int)SvIV(sv);
2703 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2706 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2715 if (ckWARN(WARN_CLOSED))
2716 report_evil_fh(gv, io, optype);
2717 SETERRNO(EBADF,SS_IVCHAN);
2722 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2730 const int optype = PL_op->op_type;
2731 GV * const gv = (GV*)POPs;
2732 register IO * const io = GvIOn(gv);
2737 if (!io || !IoIFP(io))
2740 sv = sv_2mortal(newSV(257));
2741 (void)SvPOK_only(sv);
2745 fd = PerlIO_fileno(IoIFP(io));
2747 case OP_GETSOCKNAME:
2748 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2751 case OP_GETPEERNAME:
2752 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2754 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2756 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";
2757 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2758 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2759 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2760 sizeof(u_short) + sizeof(struct in_addr))) {
2767 #ifdef BOGUS_GETNAME_RETURN
2768 /* Interactive Unix, getpeername() and getsockname()
2769 does not return valid namelen */
2770 if (len == BOGUS_GETNAME_RETURN)
2771 len = sizeof(struct sockaddr);
2779 if (ckWARN(WARN_CLOSED))
2780 report_evil_fh(gv, io, optype);
2781 SETERRNO(EBADF,SS_IVCHAN);
2786 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2801 if (PL_op->op_flags & OPf_REF) {
2803 if (PL_op->op_type == OP_LSTAT) {
2804 if (gv != PL_defgv) {
2805 do_fstat_warning_check:
2806 if (ckWARN(WARN_IO))
2807 Perl_warner(aTHX_ packWARN(WARN_IO),
2808 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2809 } else if (PL_laststype != OP_LSTAT)
2810 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2814 if (gv != PL_defgv) {
2815 PL_laststype = OP_STAT;
2817 sv_setpvn(PL_statname, "", 0);
2824 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2825 } else if (IoDIRP(io)) {
2828 PerlLIO_fstat(dirfd(IoDIRP(io)), &PL_statcache);
2830 DIE(aTHX_ PL_no_func, "dirfd");
2833 PL_laststatval = -1;
2839 if (PL_laststatval < 0) {
2840 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2841 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2846 SV* const sv = POPs;
2847 if (SvTYPE(sv) == SVt_PVGV) {
2850 } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2852 if (PL_op->op_type == OP_LSTAT)
2853 goto do_fstat_warning_check;
2855 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2857 if (PL_op->op_type == OP_LSTAT)
2858 goto do_fstat_warning_check;
2859 goto do_fstat_have_io;
2862 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2864 PL_laststype = PL_op->op_type;
2865 if (PL_op->op_type == OP_LSTAT)
2866 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2868 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2869 if (PL_laststatval < 0) {
2870 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2871 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2877 if (gimme != G_ARRAY) {
2878 if (gimme != G_VOID)
2879 XPUSHs(boolSV(max));
2885 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2886 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2887 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2888 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2889 #if Uid_t_size > IVSIZE
2890 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2892 # if Uid_t_sign <= 0
2893 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2895 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2898 #if Gid_t_size > IVSIZE
2899 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2901 # if Gid_t_sign <= 0
2902 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2904 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2907 #ifdef USE_STAT_RDEV
2908 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2910 PUSHs(sv_2mortal(newSVpvs("")));
2912 #if Off_t_size > IVSIZE
2913 PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
2915 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2918 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2919 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2920 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2922 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_atime)));
2923 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_mtime)));
2924 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_ctime)));
2926 #ifdef USE_STAT_BLOCKS
2927 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2928 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2930 PUSHs(sv_2mortal(newSVpvs("")));
2931 PUSHs(sv_2mortal(newSVpvs("")));
2937 /* This macro is used by the stacked filetest operators :
2938 * if the previous filetest failed, short-circuit and pass its value.
2939 * Else, discard it from the stack and continue. --rgs
2941 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2942 if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
2943 else { (void)POPs; PUTBACK; } \
2950 /* Not const, because things tweak this below. Not bool, because there's
2951 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2952 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2953 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2954 /* Giving some sort of initial value silences compilers. */
2956 int access_mode = R_OK;
2958 int access_mode = 0;
2961 /* access_mode is never used, but leaving use_access in makes the
2962 conditional compiling below much clearer. */
2965 int stat_mode = S_IRUSR;
2967 bool effective = FALSE;
2970 STACKED_FTEST_CHECK;
2972 switch (PL_op->op_type) {
2974 #if !(defined(HAS_ACCESS) && defined(R_OK))
2980 #if defined(HAS_ACCESS) && defined(W_OK)
2985 stat_mode = S_IWUSR;
2989 #if defined(HAS_ACCESS) && defined(X_OK)
2994 stat_mode = S_IXUSR;
2998 #ifdef PERL_EFF_ACCESS
3001 stat_mode = S_IWUSR;
3005 #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 (SvTYPE(sv) == SVt_PVGV) {
3410 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
3414 tmps = SvPVx_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(PerlIO_fileno(IoIFP(io))) >= 0);
3448 else if (IoDIRP(io)) {
3450 PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0);
3452 DIE(aTHX_ PL_no_func, "dirfd");
3456 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3457 report_evil_fh(gv, io, PL_op->op_type);
3458 SETERRNO(EBADF, RMS_IFI);
3463 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3464 report_evil_fh(gv, io, PL_op->op_type);
3465 SETERRNO(EBADF,RMS_IFI);
3469 DIE(aTHX_ PL_no_func, "fchdir");
3473 PUSHi( PerlDir_chdir(tmps) >= 0 );
3475 /* Clear the DEFAULT element of ENV so we'll get the new value
3477 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3484 dVAR; dSP; dMARK; dTARGET;
3485 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3496 char * const tmps = POPpx;
3497 TAINT_PROPER("chroot");
3498 PUSHi( chroot(tmps) >= 0 );
3501 DIE(aTHX_ PL_no_func, "chroot");
3509 const char * const tmps2 = POPpconstx;
3510 const char * const tmps = SvPV_nolen_const(TOPs);
3511 TAINT_PROPER("rename");
3513 anum = PerlLIO_rename(tmps, tmps2);
3515 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3516 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3519 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3520 (void)UNLINK(tmps2);
3521 if (!(anum = link(tmps, tmps2)))
3522 anum = UNLINK(tmps);
3530 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3534 const int op_type = PL_op->op_type;
3538 if (op_type == OP_LINK)
3539 DIE(aTHX_ PL_no_func, "link");
3541 # ifndef HAS_SYMLINK
3542 if (op_type == OP_SYMLINK)
3543 DIE(aTHX_ PL_no_func, "symlink");
3547 const char * const tmps2 = POPpconstx;
3548 const char * const tmps = SvPV_nolen_const(TOPs);
3549 TAINT_PROPER(PL_op_desc[op_type]);
3551 # if defined(HAS_LINK)
3552 # if defined(HAS_SYMLINK)
3553 /* Both present - need to choose which. */
3554 (op_type == OP_LINK) ?
3555 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3557 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3558 PerlLIO_link(tmps, tmps2);
3561 # if defined(HAS_SYMLINK)
3562 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3563 symlink(tmps, tmps2);
3568 SETi( result >= 0 );
3575 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3586 char buf[MAXPATHLEN];
3589 #ifndef INCOMPLETE_TAINTS
3593 len = readlink(tmps, buf, sizeof(buf) - 1);
3601 RETSETUNDEF; /* just pretend it's a normal file */
3605 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3607 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3609 char * const save_filename = filename;
3614 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3616 Newx(cmdline, size, char);
3617 my_strlcpy(cmdline, cmd, size);
3618 my_strlcat(cmdline, " ", size);
3619 for (s = cmdline + strlen(cmdline); *filename; ) {
3623 if (s - cmdline < size)
3624 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3625 myfp = PerlProc_popen(cmdline, "r");
3629 SV * const tmpsv = sv_newmortal();
3630 /* Need to save/restore 'PL_rs' ?? */
3631 s = sv_gets(tmpsv, myfp, 0);
3632 (void)PerlProc_pclose(myfp);
3636 #ifdef HAS_SYS_ERRLIST
3641 /* you don't see this */
3642 const char * const errmsg =
3643 #ifdef HAS_SYS_ERRLIST
3651 if (instr(s, errmsg)) {
3658 #define EACCES EPERM
3660 if (instr(s, "cannot make"))
3661 SETERRNO(EEXIST,RMS_FEX);
3662 else if (instr(s, "existing file"))
3663 SETERRNO(EEXIST,RMS_FEX);
3664 else if (instr(s, "ile exists"))
3665 SETERRNO(EEXIST,RMS_FEX);
3666 else if (instr(s, "non-exist"))
3667 SETERRNO(ENOENT,RMS_FNF);
3668 else if (instr(s, "does not exist"))
3669 SETERRNO(ENOENT,RMS_FNF);
3670 else if (instr(s, "not empty"))
3671 SETERRNO(EBUSY,SS_DEVOFFLINE);
3672 else if (instr(s, "cannot access"))
3673 SETERRNO(EACCES,RMS_PRV);
3675 SETERRNO(EPERM,RMS_PRV);
3678 else { /* some mkdirs return no failure indication */
3679 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3680 if (PL_op->op_type == OP_RMDIR)
3685 SETERRNO(EACCES,RMS_PRV); /* a guess */
3694 /* This macro removes trailing slashes from a directory name.
3695 * Different operating and file systems take differently to
3696 * trailing slashes. According to POSIX 1003.1 1996 Edition
3697 * any number of trailing slashes should be allowed.
3698 * Thusly we snip them away so that even non-conforming
3699 * systems are happy.
3700 * We should probably do this "filtering" for all
3701 * the functions that expect (potentially) directory names:
3702 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3703 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3705 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3706 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3709 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3710 (tmps) = savepvn((tmps), (len)); \
3720 const int mode = (MAXARG > 1) ? POPi : 0777;
3722 TRIMSLASHES(tmps,len,copy);
3724 TAINT_PROPER("mkdir");
3726 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3730 SETi( dooneliner("mkdir", tmps) );
3731 oldumask = PerlLIO_umask(0);
3732 PerlLIO_umask(oldumask);
3733 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3748 TRIMSLASHES(tmps,len,copy);
3749 TAINT_PROPER("rmdir");
3751 SETi( PerlDir_rmdir(tmps) >= 0 );
3753 SETi( dooneliner("rmdir", tmps) );
3760 /* Directory calls. */
3764 #if defined(Direntry_t) && defined(HAS_READDIR)
3766 const char * const dirname = POPpconstx;
3767 GV * const gv = (GV*)POPs;
3768 register IO * const io = GvIOn(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))
3826 XPUSHs(sv_2mortal(sv));
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)
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)
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;
4076 while (++MARK <= SP) {
4077 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4082 TAINT_PROPER("system");
4084 PERL_FLUSHALL_FOR_CHILD;
4085 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4091 if (PerlProc_pipe(pp) >= 0)
4093 while ((childpid = PerlProc_fork()) == -1) {
4094 if (errno != EAGAIN) {
4099 PerlLIO_close(pp[0]);
4100 PerlLIO_close(pp[1]);
4107 Sigsave_t ihand,qhand; /* place to save signals during system() */
4111 PerlLIO_close(pp[1]);
4113 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4114 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4117 result = wait4pid(childpid, &status, 0);
4118 } while (result == -1 && errno == EINTR);
4120 (void)rsignal_restore(SIGINT, &ihand);
4121 (void)rsignal_restore(SIGQUIT, &qhand);
4123 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4124 do_execfree(); /* free any memory child malloced on fork */
4131 while (n < sizeof(int)) {
4132 n1 = PerlLIO_read(pp[0],
4133 (void*)(((char*)&errkid)+n),
4139 PerlLIO_close(pp[0]);
4140 if (n) { /* Error */
4141 if (n != sizeof(int))
4142 DIE(aTHX_ "panic: kid popen errno read");
4143 errno = errkid; /* Propagate errno from kid */
4144 STATUS_NATIVE_CHILD_SET(-1);
4147 XPUSHi(STATUS_CURRENT);
4151 PerlLIO_close(pp[0]);
4152 #if defined(HAS_FCNTL) && defined(F_SETFD)
4153 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4156 if (PL_op->op_flags & OPf_STACKED) {
4157 SV * const really = *++MARK;
4158 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4160 else if (SP - MARK != 1)
4161 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4163 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4167 #else /* ! FORK or VMS or OS/2 */
4170 if (PL_op->op_flags & OPf_STACKED) {
4171 SV * const really = *++MARK;
4172 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4173 value = (I32)do_aspawn(really, MARK, SP);
4175 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4178 else if (SP - MARK != 1) {
4179 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4180 value = (I32)do_aspawn(NULL, MARK, SP);
4182 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4186 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4188 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4190 STATUS_NATIVE_CHILD_SET(value);
4193 XPUSHi(result ? value : STATUS_CURRENT);
4194 #endif /* !FORK or VMS */
4200 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4205 while (++MARK <= SP) {
4206 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4211 TAINT_PROPER("exec");
4213 PERL_FLUSHALL_FOR_CHILD;
4214 if (PL_op->op_flags & OPf_STACKED) {
4215 SV * const really = *++MARK;
4216 value = (I32)do_aexec(really, MARK, SP);
4218 else if (SP - MARK != 1)
4220 value = (I32)vms_do_aexec(NULL, MARK, SP);
4224 (void ) do_aspawn(NULL, MARK, SP);
4228 value = (I32)do_aexec(NULL, MARK, SP);
4233 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4236 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4239 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4253 # ifdef THREADS_HAVE_PIDS
4254 if (PL_ppid != 1 && getppid() == 1)
4255 /* maybe the parent process has died. Refresh ppid cache */
4259 XPUSHi( getppid() );
4263 DIE(aTHX_ PL_no_func, "getppid");
4272 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4275 pgrp = (I32)BSD_GETPGRP(pid);
4277 if (pid != 0 && pid != PerlProc_getpid())
4278 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4284 DIE(aTHX_ PL_no_func, "getpgrp()");
4303 TAINT_PROPER("setpgrp");
4305 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4307 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4308 || (pid != 0 && pid != PerlProc_getpid()))
4310 DIE(aTHX_ "setpgrp can't take arguments");
4312 SETi( setpgrp() >= 0 );
4313 #endif /* USE_BSDPGRP */
4316 DIE(aTHX_ PL_no_func, "setpgrp()");
4322 #ifdef HAS_GETPRIORITY
4324 const int who = POPi;
4325 const int which = TOPi;
4326 SETi( getpriority(which, who) );
4329 DIE(aTHX_ PL_no_func, "getpriority()");
4335 #ifdef HAS_SETPRIORITY
4337 const int niceval = POPi;
4338 const int who = POPi;
4339 const int which = TOPi;
4340 TAINT_PROPER("setpriority");
4341 SETi( setpriority(which, who, niceval) >= 0 );
4344 DIE(aTHX_ PL_no_func, "setpriority()");
4354 XPUSHn( time(NULL) );
4356 XPUSHi( time(NULL) );
4368 (void)PerlProc_times(&PL_timesbuf);
4370 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4371 /* struct tms, though same data */
4375 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
4376 if (GIMME == G_ARRAY) {
4377 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
4378 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
4379 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
4385 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4387 if (GIMME == G_ARRAY) {
4388 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4389 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4390 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4394 DIE(aTHX_ "times not implemented");
4396 #endif /* HAS_TIMES */
4399 #ifdef LOCALTIME_EDGECASE_BROKEN
4400 static struct tm *S_my_localtime (pTHX_ Time_t *tp)
4405 /* No workarounds in the valid range */
4406 if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4407 return (localtime (tp));
4409 /* This edge case is to workaround the undefined behaviour, where the
4410 * TIMEZONE makes the time go beyond the defined range.
4411 * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4412 * If there is a negative offset in TZ, like MET-1METDST, some broken
4413 * implementations of localtime () (like AIX 5.2) barf with bogus
4415 * 0x7fffffff gmtime 2038-01-19 03:14:07
4416 * 0x7fffffff localtime 1901-12-13 21:45:51
4417 * 0x7fffffff mylocaltime 2038-01-19 04:14:07
4418 * 0x3c19137f gmtime 2001-12-13 20:45:51
4419 * 0x3c19137f localtime 2001-12-13 21:45:51
4420 * 0x3c19137f mylocaltime 2001-12-13 21:45:51
4421 * Given that legal timezones are typically between GMT-12 and GMT+12
4422 * we turn back the clock 23 hours before calling the localtime
4423 * function, and add those to the return value. This will never cause
4424 * day wrapping problems, since the edge case is Tue Jan *19*
4426 T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4429 if (P->tm_hour >= 24) {
4431 P->tm_mday++; /* 18 -> 19 */
4432 P->tm_wday++; /* Mon -> Tue */
4433 P->tm_yday++; /* 18 -> 19 */
4436 } /* S_my_localtime */
4444 const struct tm *tmbuf;
4445 static const char * const dayname[] =
4446 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4447 static const char * const monname[] =
4448 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4449 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4455 when = (Time_t)SvNVx(POPs);
4457 when = (Time_t)SvIVx(POPs);
4460 if (PL_op->op_type == OP_LOCALTIME)
4461 #ifdef LOCALTIME_EDGECASE_BROKEN
4462 tmbuf = S_my_localtime(aTHX_ &when);
4464 tmbuf = localtime(&when);
4467 tmbuf = gmtime(&when);
4469 if (GIMME != G_ARRAY) {
4475 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4476 dayname[tmbuf->tm_wday],
4477 monname[tmbuf->tm_mon],
4482 tmbuf->tm_year + 1900);
4483 PUSHs(sv_2mortal(tsv));
4488 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4489 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4490 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4491 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4492 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4493 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4494 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4495 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4496 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4507 anum = alarm((unsigned int)anum);
4514 DIE(aTHX_ PL_no_func, "alarm");
4525 (void)time(&lasttime);
4530 PerlProc_sleep((unsigned int)duration);
4533 XPUSHi(when - lasttime);
4537 /* Shared memory. */
4538 /* Merged with some message passing. */
4542 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4543 dVAR; dSP; dMARK; dTARGET;
4544 const int op_type = PL_op->op_type;
4549 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4552 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4555 value = (I32)(do_semop(MARK, SP) >= 0);
4558 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4574 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4575 dVAR; dSP; dMARK; dTARGET;
4576 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4583 DIE(aTHX_ "System V IPC is not implemented on this machine");
4589 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4590 dVAR; dSP; dMARK; dTARGET;
4591 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4599 PUSHp(zero_but_true, ZBTLEN);
4607 /* I can't const this further without getting warnings about the types of
4608 various arrays passed in from structures. */
4610 S_space_join_names_mortal(pTHX_ char *const *array)
4614 if (array && *array) {
4615 target = sv_2mortal(newSVpvs(""));
4617 sv_catpv(target, *array);
4620 sv_catpvs(target, " ");
4623 target = sv_mortalcopy(&PL_sv_no);
4628 /* Get system info. */
4632 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4634 I32 which = PL_op->op_type;
4635 register char **elem;
4637 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4638 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4639 struct hostent *gethostbyname(Netdb_name_t);
4640 struct hostent *gethostent(void);
4642 struct hostent *hent;
4646 if (which == OP_GHBYNAME) {
4647 #ifdef HAS_GETHOSTBYNAME
4648 const char* const name = POPpbytex;
4649 hent = PerlSock_gethostbyname(name);
4651 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4654 else if (which == OP_GHBYADDR) {
4655 #ifdef HAS_GETHOSTBYADDR
4656 const int addrtype = POPi;
4657 SV * const addrsv = POPs;
4659 Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4661 hent = PerlSock_gethostbyaddr((const char*)addr, (Netdb_hlen_t) addrlen, addrtype);
4663 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4667 #ifdef HAS_GETHOSTENT
4668 hent = PerlSock_gethostent();
4670 DIE(aTHX_ PL_no_sock_func, "gethostent");
4673 #ifdef HOST_NOT_FOUND
4675 #ifdef USE_REENTRANT_API
4676 # ifdef USE_GETHOSTENT_ERRNO
4677 h_errno = PL_reentrant_buffer->_gethostent_errno;
4680 STATUS_UNIX_SET(h_errno);
4684 if (GIMME != G_ARRAY) {
4685 PUSHs(sv = sv_newmortal());
4687 if (which == OP_GHBYNAME) {
4689 sv_setpvn(sv, hent->h_addr, hent->h_length);
4692 sv_setpv(sv, (char*)hent->h_name);
4698 PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
4699 PUSHs(space_join_names_mortal(hent->h_aliases));
4700 PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
4701 len = hent->h_length;
4702 PUSHs(sv_2mortal(newSViv((IV)len)));
4704 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4705 XPUSHs(sv_2mortal(newSVpvn(*elem, len)));
4709 PUSHs(newSVpvn(hent->h_addr, len));
4711 PUSHs(sv_mortalcopy(&PL_sv_no));
4716 DIE(aTHX_ PL_no_sock_func, "gethostent");
4722 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4724 I32 which = PL_op->op_type;
4726 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4727 struct netent *getnetbyaddr(Netdb_net_t, int);
4728 struct netent *getnetbyname(Netdb_name_t);
4729 struct netent *getnetent(void);
4731 struct netent *nent;
4733 if (which == OP_GNBYNAME){
4734 #ifdef HAS_GETNETBYNAME
4735 const char * const name = POPpbytex;
4736 nent = PerlSock_getnetbyname(name);
4738 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4741 else if (which == OP_GNBYADDR) {
4742 #ifdef HAS_GETNETBYADDR
4743 const int addrtype = POPi;
4744 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4745 nent = PerlSock_getnetbyaddr(addr, addrtype);
4747 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4751 #ifdef HAS_GETNETENT
4752 nent = PerlSock_getnetent();
4754 DIE(aTHX_ PL_no_sock_func, "getnetent");
4757 #ifdef HOST_NOT_FOUND
4759 #ifdef USE_REENTRANT_API
4760 # ifdef USE_GETNETENT_ERRNO
4761 h_errno = PL_reentrant_buffer->_getnetent_errno;
4764 STATUS_UNIX_SET(h_errno);
4769 if (GIMME != G_ARRAY) {
4770 PUSHs(sv = sv_newmortal());
4772 if (which == OP_GNBYNAME)
4773 sv_setiv(sv, (IV)nent->n_net);
4775 sv_setpv(sv, nent->n_name);
4781 PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
4782 PUSHs(space_join_names_mortal(nent->n_aliases));
4783 PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
4784 PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
4789 DIE(aTHX_ PL_no_sock_func, "getnetent");
4795 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4797 I32 which = PL_op->op_type;
4799 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4800 struct protoent *getprotobyname(Netdb_name_t);
4801 struct protoent *getprotobynumber(int);
4802 struct protoent *getprotoent(void);
4804 struct protoent *pent;
4806 if (which == OP_GPBYNAME) {
4807 #ifdef HAS_GETPROTOBYNAME
4808 const char* const name = POPpbytex;
4809 pent = PerlSock_getprotobyname(name);
4811 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4814 else if (which == OP_GPBYNUMBER) {
4815 #ifdef HAS_GETPROTOBYNUMBER
4816 const int number = POPi;
4817 pent = PerlSock_getprotobynumber(number);
4819 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4823 #ifdef HAS_GETPROTOENT
4824 pent = PerlSock_getprotoent();
4826 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4830 if (GIMME != G_ARRAY) {
4831 PUSHs(sv = sv_newmortal());
4833 if (which == OP_GPBYNAME)
4834 sv_setiv(sv, (IV)pent->p_proto);
4836 sv_setpv(sv, pent->p_name);
4842 PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
4843 PUSHs(space_join_names_mortal(pent->p_aliases));
4844 PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
4849 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4855 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4857 I32 which = PL_op->op_type;
4859 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4860 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4861 struct servent *getservbyport(int, Netdb_name_t);
4862 struct servent *getservent(void);
4864 struct servent *sent;
4866 if (which == OP_GSBYNAME) {
4867 #ifdef HAS_GETSERVBYNAME
4868 const char * const proto = POPpbytex;
4869 const char * const name = POPpbytex;
4870 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4872 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4875 else if (which == OP_GSBYPORT) {
4876 #ifdef HAS_GETSERVBYPORT
4877 const char * const proto = POPpbytex;
4878 unsigned short port = (unsigned short)POPu;
4880 port = PerlSock_htons(port);
4882 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4884 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4888 #ifdef HAS_GETSERVENT
4889 sent = PerlSock_getservent();
4891 DIE(aTHX_ PL_no_sock_func, "getservent");
4895 if (GIMME != G_ARRAY) {
4896 PUSHs(sv = sv_newmortal());
4898 if (which == OP_GSBYNAME) {
4900 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4902 sv_setiv(sv, (IV)(sent->s_port));
4906 sv_setpv(sv, sent->s_name);
4912 PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
4913 PUSHs(space_join_names_mortal(sent->s_aliases));
4915 PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
4917 PUSHs(sv_2mortal(newSViv((IV)(sent->s_port))));
4919 PUSHs(sv_2mortal(newSVpv(sent->s_proto, 0)));
4924 DIE(aTHX_ PL_no_sock_func, "getservent");
4930 #ifdef HAS_SETHOSTENT
4932 PerlSock_sethostent(TOPi);
4935 DIE(aTHX_ PL_no_sock_func, "sethostent");
4941 #ifdef HAS_SETNETENT
4943 PerlSock_setnetent(TOPi);
4946 DIE(aTHX_ PL_no_sock_func, "setnetent");
4952 #ifdef HAS_SETPROTOENT
4954 PerlSock_setprotoent(TOPi);
4957 DIE(aTHX_ PL_no_sock_func, "setprotoent");
4963 #ifdef HAS_SETSERVENT
4965 PerlSock_setservent(TOPi);
4968 DIE(aTHX_ PL_no_sock_func, "setservent");
4974 #ifdef HAS_ENDHOSTENT
4976 PerlSock_endhostent();
4980 DIE(aTHX_ PL_no_sock_func, "endhostent");
4986 #ifdef HAS_ENDNETENT
4988 PerlSock_endnetent();
4992 DIE(aTHX_ PL_no_sock_func, "endnetent");
4998 #ifdef HAS_ENDPROTOENT
5000 PerlSock_endprotoent();
5004 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5010 #ifdef HAS_ENDSERVENT
5012 PerlSock_endservent();
5016 DIE(aTHX_ PL_no_sock_func, "endservent");
5024 I32 which = PL_op->op_type;
5026 struct passwd *pwent = NULL;
5028 * We currently support only the SysV getsp* shadow password interface.
5029 * The interface is declared in <shadow.h> and often one needs to link
5030 * with -lsecurity or some such.
5031 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5034 * AIX getpwnam() is clever enough to return the encrypted password
5035 * only if the caller (euid?) is root.
5037 * There are at least three other shadow password APIs. Many platforms
5038 * seem to contain more than one interface for accessing the shadow
5039 * password databases, possibly for compatibility reasons.
5040 * The getsp*() is by far he simplest one, the other two interfaces
5041 * are much more complicated, but also very similar to each other.
5046 * struct pr_passwd *getprpw*();
5047 * The password is in
5048 * char getprpw*(...).ufld.fd_encrypt[]
5049 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5054 * struct es_passwd *getespw*();
5055 * The password is in
5056 * char *(getespw*(...).ufld.fd_encrypt)
5057 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5060 * struct userpw *getuserpw();
5061 * The password is in
5062 * char *(getuserpw(...)).spw_upw_passwd
5063 * (but the de facto standard getpwnam() should work okay)
5065 * Mention I_PROT here so that Configure probes for it.
5067 * In HP-UX for getprpw*() the manual page claims that one should include
5068 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5069 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5070 * and pp_sys.c already includes <shadow.h> if there is such.
5072 * Note that <sys/security.h> is already probed for, but currently
5073 * it is only included in special cases.
5075 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5076 * be preferred interface, even though also the getprpw*() interface
5077 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5078 * One also needs to call set_auth_parameters() in main() before
5079 * doing anything else, whether one is using getespw*() or getprpw*().
5081 * Note that accessing the shadow databases can be magnitudes
5082 * slower than accessing the standard databases.
5087 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5088 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5089 * the pw_comment is left uninitialized. */
5090 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5096 const char* const name = POPpbytex;
5097 pwent = getpwnam(name);
5103 pwent = getpwuid(uid);
5107 # ifdef HAS_GETPWENT
5109 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5110 if (pwent) pwent = getpwnam(pwent->pw_name);
5113 DIE(aTHX_ PL_no_func, "getpwent");
5119 if (GIMME != G_ARRAY) {
5120 PUSHs(sv = sv_newmortal());
5122 if (which == OP_GPWNAM)
5123 # if Uid_t_sign <= 0
5124 sv_setiv(sv, (IV)pwent->pw_uid);
5126 sv_setuv(sv, (UV)pwent->pw_uid);
5129 sv_setpv(sv, pwent->pw_name);
5135 PUSHs(sv_2mortal(newSVpv(pwent->pw_name, 0)));
5137 PUSHs(sv = sv_2mortal(newSViv(0)));
5138 /* If we have getspnam(), we try to dig up the shadow
5139 * password. If we are underprivileged, the shadow
5140 * interface will set the errno to EACCES or similar,
5141 * and return a null pointer. If this happens, we will
5142 * use the dummy password (usually "*" or "x") from the
5143 * standard password database.
5145 * In theory we could skip the shadow call completely
5146 * if euid != 0 but in practice we cannot know which
5147 * security measures are guarding the shadow databases
5148 * on a random platform.
5150 * Resist the urge to use additional shadow interfaces.
5151 * Divert the urge to writing an extension instead.
5154 /* Some AIX setups falsely(?) detect some getspnam(), which
5155 * has a different API than the Solaris/IRIX one. */
5156 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5158 const int saverrno = errno;
5159 const struct spwd * const spwent = getspnam(pwent->pw_name);
5160 /* Save and restore errno so that
5161 * underprivileged attempts seem
5162 * to have never made the unsccessful
5163 * attempt to retrieve the shadow password. */
5165 if (spwent && spwent->sp_pwdp)
5166 sv_setpv(sv, spwent->sp_pwdp);
5170 if (!SvPOK(sv)) /* Use the standard password, then. */
5171 sv_setpv(sv, pwent->pw_passwd);
5174 # ifndef INCOMPLETE_TAINTS
5175 /* passwd is tainted because user himself can diddle with it.
5176 * admittedly not much and in a very limited way, but nevertheless. */
5180 # if Uid_t_sign <= 0
5181 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_uid)));
5183 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_uid)));
5186 # if Uid_t_sign <= 0
5187 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_gid)));
5189 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_gid)));
5191 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5192 * because of the poor interface of the Perl getpw*(),
5193 * not because there's some standard/convention saying so.
5194 * A better interface would have been to return a hash,
5195 * but we are accursed by our history, alas. --jhi. */
5197 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_change)));
5200 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_quota)));
5203 PUSHs(sv_2mortal(newSVpv(pwent->pw_age, 0)));
5205 /* I think that you can never get this compiled, but just in case. */
5206 PUSHs(sv_mortalcopy(&PL_sv_no));
5211 /* pw_class and pw_comment are mutually exclusive--.
5212 * see the above note for pw_change, pw_quota, and pw_age. */
5214 PUSHs(sv_2mortal(newSVpv(pwent->pw_class, 0)));
5217 PUSHs(sv_2mortal(newSVpv(pwent->pw_comment, 0)));
5219 /* I think that you can never get this compiled, but just in case. */
5220 PUSHs(sv_mortalcopy(&PL_sv_no));
5225 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5227 PUSHs(sv_mortalcopy(&PL_sv_no));
5229 # ifndef INCOMPLETE_TAINTS
5230 /* pw_gecos is tainted because user himself can diddle with it. */
5234 PUSHs(sv_2mortal(newSVpv(pwent->pw_dir, 0)));
5236 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5237 # ifndef INCOMPLETE_TAINTS
5238 /* pw_shell is tainted because user himself can diddle with it. */
5243 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_expire)));
5248 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5254 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5259 DIE(aTHX_ PL_no_func, "setpwent");
5265 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5270 DIE(aTHX_ PL_no_func, "endpwent");
5278 const I32 which = PL_op->op_type;
5279 const struct group *grent;
5281 if (which == OP_GGRNAM) {
5282 const char* const name = POPpbytex;
5283 grent = (const struct group *)getgrnam(name);
5285 else if (which == OP_GGRGID) {
5286 const Gid_t gid = POPi;
5287 grent = (const struct group *)getgrgid(gid);
5291 grent = (struct group *)getgrent();
5293 DIE(aTHX_ PL_no_func, "getgrent");
5297 if (GIMME != G_ARRAY) {
5298 SV * const sv = sv_newmortal();
5302 if (which == OP_GGRNAM)
5303 sv_setiv(sv, (IV)grent->gr_gid);
5305 sv_setpv(sv, grent->gr_name);
5311 PUSHs(sv_2mortal(newSVpv(grent->gr_name, 0)));
5314 PUSHs(sv_2mortal(newSVpv(grent->gr_passwd, 0)));
5316 PUSHs(sv_mortalcopy(&PL_sv_no));
5319 PUSHs(sv_2mortal(newSViv((IV)grent->gr_gid)));
5321 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5322 /* In UNICOS/mk (_CRAYMPP) the multithreading
5323 * versions (getgrnam_r, getgrgid_r)
5324 * seem to return an illegal pointer
5325 * as the group members list, gr_mem.
5326 * getgrent() doesn't even have a _r version
5327 * but the gr_mem is poisonous anyway.
5328 * So yes, you cannot get the list of group
5329 * members if building multithreaded in UNICOS/mk. */
5330 PUSHs(space_join_names_mortal(grent->gr_mem));
5336 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5342 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5347 DIE(aTHX_ PL_no_func, "setgrent");
5353 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5358 DIE(aTHX_ PL_no_func, "endgrent");
5368 if (!(tmps = PerlProc_getlogin()))
5370 PUSHp(tmps, strlen(tmps));
5373 DIE(aTHX_ PL_no_func, "getlogin");
5377 /* Miscellaneous. */
5382 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5383 register I32 items = SP - MARK;
5384 unsigned long a[20];
5389 while (++MARK <= SP) {
5390 if (SvTAINTED(*MARK)) {
5396 TAINT_PROPER("syscall");
5399 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5400 * or where sizeof(long) != sizeof(char*). But such machines will
5401 * not likely have syscall implemented either, so who cares?
5403 while (++MARK <= SP) {
5404 if (SvNIOK(*MARK) || !i)
5405 a[i++] = SvIV(*MARK);
5406 else if (*MARK == &PL_sv_undef)
5409 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5415 DIE(aTHX_ "Too many args to syscall");
5417 DIE(aTHX_ "Too few args to syscall");
5419 retval = syscall(a[0]);
5422 retval = syscall(a[0],a[1]);
5425 retval = syscall(a[0],a[1],a[2]);
5428 retval = syscall(a[0],a[1],a[2],a[3]);
5431 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5434 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5437 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5440 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5444 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5447 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5450 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5454 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5458 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5462 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5463 a[10],a[11],a[12],a[13]);
5465 #endif /* atarist */
5471 DIE(aTHX_ PL_no_func, "syscall");
5475 #ifdef FCNTL_EMULATE_FLOCK
5477 /* XXX Emulate flock() with fcntl().
5478 What's really needed is a good file locking module.
5482 fcntl_emulate_flock(int fd, int operation)
5486 switch (operation & ~LOCK_NB) {
5488 flock.l_type = F_RDLCK;
5491 flock.l_type = F_WRLCK;
5494 flock.l_type = F_UNLCK;
5500 flock.l_whence = SEEK_SET;
5501 flock.l_start = flock.l_len = (Off_t)0;
5503 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5506 #endif /* FCNTL_EMULATE_FLOCK */
5508 #ifdef LOCKF_EMULATE_FLOCK
5510 /* XXX Emulate flock() with lockf(). This is just to increase
5511 portability of scripts. The calls are not completely
5512 interchangeable. What's really needed is a good file
5516 /* The lockf() constants might have been defined in <unistd.h>.
5517 Unfortunately, <unistd.h> causes troubles on some mixed
5518 (BSD/POSIX) systems, such as SunOS 4.1.3.
5520 Further, the lockf() constants aren't POSIX, so they might not be
5521 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5522 just stick in the SVID values and be done with it. Sigh.
5526 # define F_ULOCK 0 /* Unlock a previously locked region */
5529 # define F_LOCK 1 /* Lock a region for exclusive use */
5532 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5535 # define F_TEST 3 /* Test a region for other processes locks */
5539 lockf_emulate_flock(int fd, int operation)
5542 const int save_errno = errno;
5545 /* flock locks entire file so for lockf we need to do the same */
5546 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5547 if (pos > 0) /* is seekable and needs to be repositioned */
5548 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5549 pos = -1; /* seek failed, so don't seek back afterwards */
5552 switch (operation) {
5554 /* LOCK_SH - get a shared lock */
5556 /* LOCK_EX - get an exclusive lock */
5558 i = lockf (fd, F_LOCK, 0);
5561 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5562 case LOCK_SH|LOCK_NB:
5563 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5564 case LOCK_EX|LOCK_NB:
5565 i = lockf (fd, F_TLOCK, 0);
5567 if ((errno == EAGAIN) || (errno == EACCES))
5568 errno = EWOULDBLOCK;
5571 /* LOCK_UN - unlock (non-blocking is a no-op) */
5573 case LOCK_UN|LOCK_NB:
5574 i = lockf (fd, F_ULOCK, 0);
5577 /* Default - can't decipher operation */
5584 if (pos > 0) /* need to restore position of the handle */
5585 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5590 #endif /* LOCKF_EMULATE_FLOCK */
5594 * c-indentation-style: bsd
5596 * indent-tabs-mode: t
5599 * ex: set ts=8 sts=4 sw=4 noet: