3 * Copyright (C) 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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 = PL_curcop->cop_io ? SvPV_nolen_const(PL_curcop->cop_io) : 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) {
444 tmps = SvPV_const(tmpsv, len);
445 if ((!tmps || !len) && PL_errgv) {
446 SV * const error = ERRSV;
447 SvUPGRADE(error, SVt_PV);
448 if (SvPOK(error) && SvCUR(error))
449 sv_catpvs(error, "\t...caught");
451 tmps = SvPV_const(tmpsv, len);
454 tmpsv = sv_2mortal(newSVpvs("Warning: something's wrong"));
456 Perl_warn(aTHX_ "%"SVf, (void*)tmpsv);
468 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
470 if (SP - MARK != 1) {
472 do_join(TARG, &PL_sv_no, MARK, SP);
474 tmps = SvPV_const(tmpsv, len);
480 tmps = SvROK(tmpsv) ? NULL : SvPV_const(tmpsv, len);
483 SV * const error = ERRSV;
484 SvUPGRADE(error, SVt_PV);
485 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
487 SvSetSV(error,tmpsv);
488 else if (sv_isobject(error)) {
489 HV * const stash = SvSTASH(SvRV(error));
490 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
492 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
493 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
500 call_sv((SV*)GvCV(gv),
501 G_SCALAR|G_EVAL|G_KEEPERR);
502 sv_setsv(error,*PL_stack_sp--);
508 if (SvPOK(error) && SvCUR(error))
509 sv_catpvs(error, "\t...propagated");
512 tmps = SvPV_const(tmpsv, len);
518 tmpsv = sv_2mortal(newSVpvs("Died"));
520 DIE(aTHX_ "%"SVf, (void*)tmpsv);
536 GV * const gv = (GV *)*++MARK;
539 DIE(aTHX_ PL_no_usym, "filehandle");
540 if ((io = GvIOp(gv)))
541 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
544 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
546 /* Method's args are same as ours ... */
547 /* ... except handle is replaced by the object */
548 *MARK-- = SvTIED_obj((SV*)io, mg);
552 call_method("OPEN", G_SCALAR);
566 tmps = SvPV_const(sv, len);
567 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
570 PUSHi( (I32)PL_forkprocess );
571 else if (PL_forkprocess == 0) /* we are a new child */
583 GV * const gv = (MAXARG == 0) ? PL_defoutgv : (GV*)POPs;
585 if (gv && (io = GvIO(gv))
586 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
589 XPUSHs(SvTIED_obj((SV*)io, mg));
592 call_method("CLOSE", G_SCALAR);
598 PUSHs(boolSV(do_close(gv, TRUE)));
611 GV * const wgv = (GV*)POPs;
612 GV * const rgv = (GV*)POPs;
617 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
618 DIE(aTHX_ PL_no_usym, "filehandle");
623 do_close(rgv, FALSE);
625 do_close(wgv, FALSE);
627 if (PerlProc_pipe(fd) < 0)
630 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
631 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
632 IoOFP(rstio) = IoIFP(rstio);
633 IoIFP(wstio) = IoOFP(wstio);
634 IoTYPE(rstio) = IoTYPE_RDONLY;
635 IoTYPE(wstio) = IoTYPE_WRONLY;
637 if (!IoIFP(rstio) || !IoOFP(wstio)) {
638 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
639 else PerlLIO_close(fd[0]);
640 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
641 else PerlLIO_close(fd[1]);
644 #if defined(HAS_FCNTL) && defined(F_SETFD)
645 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
646 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
653 DIE(aTHX_ PL_no_func, "pipe");
669 if (gv && (io = GvIO(gv))
670 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
673 XPUSHs(SvTIED_obj((SV*)io, mg));
676 call_method("FILENO", G_SCALAR);
682 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
683 /* Can't do this because people seem to do things like
684 defined(fileno($foo)) to check whether $foo is a valid fh.
685 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
686 report_evil_fh(gv, io, PL_op->op_type);
691 PUSHi(PerlIO_fileno(fp));
704 anum = PerlLIO_umask(0);
705 (void)PerlLIO_umask(anum);
708 anum = PerlLIO_umask(POPi);
709 TAINT_PROPER("umask");
712 /* Only DIE if trying to restrict permissions on "user" (self).
713 * Otherwise it's harmless and more useful to just return undef
714 * since 'group' and 'other' concepts probably don't exist here. */
715 if (MAXARG >= 1 && (POPi & 0700))
716 DIE(aTHX_ "umask not implemented");
717 XPUSHs(&PL_sv_undef);
739 if (gv && (io = GvIO(gv))
740 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
743 XPUSHs(SvTIED_obj((SV*)io, mg));
748 call_method("BINMODE", G_SCALAR);
755 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
756 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
757 report_evil_fh(gv, io, PL_op->op_type);
758 SETERRNO(EBADF,RMS_IFI);
763 if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
764 (discp) ? SvPV_nolen_const(discp) : NULL)) {
765 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
766 if (!PerlIO_binmode(aTHX_ IoOFP(io),IoTYPE(io),
767 mode_from_discipline(discp),
768 (discp) ? SvPV_nolen_const(discp) : NULL)) {
788 const I32 markoff = MARK - PL_stack_base;
789 const char *methname;
790 int how = PERL_MAGIC_tied;
794 switch(SvTYPE(varsv)) {
796 methname = "TIEHASH";
797 HvEITER_set((HV *)varsv, 0);
800 methname = "TIEARRAY";
803 #ifdef GV_UNIQUE_CHECK
804 if (GvUNIQUE((GV*)varsv)) {
805 Perl_croak(aTHX_ "Attempt to tie unique GV");
808 methname = "TIEHANDLE";
809 how = PERL_MAGIC_tiedscalar;
810 /* For tied filehandles, we apply tiedscalar magic to the IO
811 slot of the GP rather than the GV itself. AMS 20010812 */
813 GvIOp(varsv) = newIO();
814 varsv = (SV *)GvIOp(varsv);
817 methname = "TIESCALAR";
818 how = PERL_MAGIC_tiedscalar;
822 if (sv_isobject(*MARK)) {
824 PUSHSTACKi(PERLSI_MAGIC);
826 EXTEND(SP,(I32)items);
830 call_method(methname, G_SCALAR);
833 /* Not clear why we don't call call_method here too.
834 * perhaps to get different error message ?
836 stash = gv_stashsv(*MARK, FALSE);
837 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
838 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
839 methname, (void*)*MARK);
842 PUSHSTACKi(PERLSI_MAGIC);
844 EXTEND(SP,(I32)items);
848 call_sv((SV*)GvCV(gv), G_SCALAR);
854 if (sv_isobject(sv)) {
855 sv_unmagic(varsv, how);
856 /* Croak if a self-tie on an aggregate is attempted. */
857 if (varsv == SvRV(sv) &&
858 (SvTYPE(varsv) == SVt_PVAV ||
859 SvTYPE(varsv) == SVt_PVHV))
861 "Self-ties of arrays and hashes are not supported");
862 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
865 SP = PL_stack_base + markoff;
875 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
876 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
878 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
881 if ((mg = SvTIED_mg(sv, how))) {
882 SV * const obj = SvRV(SvTIED_obj(sv, mg));
884 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
886 if (gv && isGV(gv) && (cv = GvCV(gv))) {
888 XPUSHs(SvTIED_obj((SV*)gv, mg));
889 XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
892 call_sv((SV *)cv, G_VOID);
896 else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
897 Perl_warner(aTHX_ packWARN(WARN_UNTIE),
898 "untie attempted while %"UVuf" inner references still exist",
899 (UV)SvREFCNT(obj) - 1 ) ;
903 sv_unmagic(sv, how) ;
913 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
914 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
916 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
919 if ((mg = SvTIED_mg(sv, how))) {
920 SV *osv = SvTIED_obj(sv, mg);
921 if (osv == mg->mg_obj)
922 osv = sv_mortalcopy(osv);
936 HV * const hv = (HV*)POPs;
937 SV * const sv = sv_2mortal(newSVpvs("AnyDBM_File"));
938 stash = gv_stashsv(sv, FALSE);
939 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
941 require_pv("AnyDBM_File.pm");
943 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
944 DIE(aTHX_ "No dbm on this machine");
954 PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
956 PUSHs(sv_2mortal(newSVuv(O_RDWR)));
959 call_sv((SV*)GvCV(gv), G_SCALAR);
962 if (!sv_isobject(TOPs)) {
967 PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
970 call_sv((SV*)GvCV(gv), G_SCALAR);
974 if (sv_isobject(TOPs)) {
975 sv_unmagic((SV *) hv, PERL_MAGIC_tied);
976 sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, NULL, 0);
993 struct timeval timebuf;
994 struct timeval *tbuf = &timebuf;
997 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1002 # if BYTEORDER & 0xf0000
1003 # define ORDERBYTE (0x88888888 - BYTEORDER)
1005 # define ORDERBYTE (0x4444 - BYTEORDER)
1011 for (i = 1; i <= 3; i++) {
1012 SV * const sv = SP[i];
1015 if (SvREADONLY(sv)) {
1017 sv_force_normal_flags(sv, 0);
1018 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1019 DIE(aTHX_ PL_no_modify);
1022 if (ckWARN(WARN_MISC))
1023 Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1024 SvPV_force_nolen(sv); /* force string conversion */
1031 /* little endians can use vecs directly */
1032 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1039 masksize = NFDBITS / NBBY;
1041 masksize = sizeof(long); /* documented int, everyone seems to use long */
1043 Zero(&fd_sets[0], 4, char*);
1046 # if SELECT_MIN_BITS == 1
1047 growsize = sizeof(fd_set);
1049 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1050 # undef SELECT_MIN_BITS
1051 # define SELECT_MIN_BITS __FD_SETSIZE
1053 /* If SELECT_MIN_BITS is greater than one we most probably will want
1054 * to align the sizes with SELECT_MIN_BITS/8 because for example
1055 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1056 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1057 * on (sets/tests/clears bits) is 32 bits. */
1058 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1066 timebuf.tv_sec = (long)value;
1067 value -= (NV)timebuf.tv_sec;
1068 timebuf.tv_usec = (long)(value * 1000000.0);
1073 for (i = 1; i <= 3; i++) {
1075 if (!SvOK(sv) || SvCUR(sv) == 0) {
1082 Sv_Grow(sv, growsize);
1086 while (++j <= growsize) {
1090 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1092 Newx(fd_sets[i], growsize, char);
1093 for (offset = 0; offset < growsize; offset += masksize) {
1094 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1095 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1098 fd_sets[i] = SvPVX(sv);
1102 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1103 /* Can't make just the (void*) conditional because that would be
1104 * cpp #if within cpp macro, and not all compilers like that. */
1105 nfound = PerlSock_select(
1107 (Select_fd_set_t) fd_sets[1],
1108 (Select_fd_set_t) fd_sets[2],
1109 (Select_fd_set_t) fd_sets[3],
1110 (void*) tbuf); /* Workaround for compiler bug. */
1112 nfound = PerlSock_select(
1114 (Select_fd_set_t) fd_sets[1],
1115 (Select_fd_set_t) fd_sets[2],
1116 (Select_fd_set_t) fd_sets[3],
1119 for (i = 1; i <= 3; i++) {
1122 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1124 for (offset = 0; offset < growsize; offset += masksize) {
1125 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1126 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1128 Safefree(fd_sets[i]);
1135 if (GIMME == G_ARRAY && tbuf) {
1136 value = (NV)(timebuf.tv_sec) +
1137 (NV)(timebuf.tv_usec) / 1000000.0;
1138 PUSHs(sv_2mortal(newSVnv(value)));
1142 DIE(aTHX_ "select not implemented");
1147 Perl_setdefout(pTHX_ GV *gv)
1150 SvREFCNT_inc_simple_void(gv);
1152 SvREFCNT_dec(PL_defoutgv);
1160 GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
1161 GV * egv = GvEGV(PL_defoutgv);
1167 XPUSHs(&PL_sv_undef);
1169 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1170 if (gvp && *gvp == egv) {
1171 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1175 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1180 if (!GvIO(newdefout))
1181 gv_IOadd(newdefout);
1182 setdefout(newdefout);
1193 GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs;
1195 if (gv && (io = GvIO(gv))
1196 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1198 const I32 gimme = GIMME_V;
1200 XPUSHs(SvTIED_obj((SV*)io, mg));
1203 call_method("GETC", gimme);
1206 if (gimme == G_SCALAR)
1207 SvSetMagicSV_nosteal(TARG, TOPs);
1210 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1211 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1212 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1213 report_evil_fh(gv, io, PL_op->op_type);
1214 SETERRNO(EBADF,RMS_IFI);
1218 sv_setpvn(TARG, " ", 1);
1219 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1220 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1221 /* Find out how many bytes the char needs */
1222 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1225 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1226 SvCUR_set(TARG,1+len);
1235 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1238 register PERL_CONTEXT *cx;
1239 const I32 gimme = GIMME_V;
1244 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1246 cx->blk_sub.retop = retop;
1248 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1250 setdefout(gv); /* locally select filehandle so $% et al work */
1281 DIE(aTHX_ "Not a format reference");
1285 SV * const tmpsv = sv_newmortal();
1287 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1288 name = SvPV_nolen_const(tmpsv);
1290 DIE(aTHX_ "Undefined format \"%s\" called", name);
1291 DIE(aTHX_ "Not a format reference");
1294 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1296 IoFLAGS(io) &= ~IOf_DIDTOP;
1297 return doform(cv,gv,PL_op->op_next);
1303 GV * const gv = cxstack[cxstack_ix].blk_sub.gv;
1304 register IO * const io = GvIOp(gv);
1309 register PERL_CONTEXT *cx;
1311 if (!io || !(ofp = IoOFP(io)))
1314 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1315 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1317 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1318 PL_formtarget != PL_toptarget)
1322 if (!IoTOP_GV(io)) {
1325 if (!IoTOP_NAME(io)) {
1327 if (!IoFMT_NAME(io))
1328 IoFMT_NAME(io) = savepv(GvNAME(gv));
1329 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1330 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1331 if ((topgv && GvFORM(topgv)) ||
1332 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1333 IoTOP_NAME(io) = savesvpv(topname);
1335 IoTOP_NAME(io) = savepvs("top");
1337 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1338 if (!topgv || !GvFORM(topgv)) {
1339 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1342 IoTOP_GV(io) = topgv;
1344 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1345 I32 lines = IoLINES_LEFT(io);
1346 const char *s = SvPVX_const(PL_formtarget);
1347 if (lines <= 0) /* Yow, header didn't even fit!!! */
1349 while (lines-- > 0) {
1350 s = strchr(s, '\n');
1356 const STRLEN save = SvCUR(PL_formtarget);
1357 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1358 do_print(PL_formtarget, ofp);
1359 SvCUR_set(PL_formtarget, save);
1360 sv_chop(PL_formtarget, s);
1361 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1364 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1365 do_print(PL_formfeed, ofp);
1366 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1368 PL_formtarget = PL_toptarget;
1369 IoFLAGS(io) |= IOf_DIDTOP;
1372 DIE(aTHX_ "bad top format reference");
1375 SV * const sv = sv_newmortal();
1377 gv_efullname4(sv, fgv, NULL, FALSE);
1378 name = SvPV_nolen_const(sv);
1380 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1382 DIE(aTHX_ "Undefined top format called");
1384 if (cv && CvCLONE(cv))
1385 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1386 return doform(cv, gv, PL_op);
1390 POPBLOCK(cx,PL_curpm);
1396 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1398 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1399 else if (ckWARN(WARN_CLOSED))
1400 report_evil_fh(gv, io, PL_op->op_type);
1405 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1406 if (ckWARN(WARN_IO))
1407 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1409 if (!do_print(PL_formtarget, fp))
1412 FmLINES(PL_formtarget) = 0;
1413 SvCUR_set(PL_formtarget, 0);
1414 *SvEND(PL_formtarget) = '\0';
1415 if (IoFLAGS(io) & IOf_FLUSH)
1416 (void)PerlIO_flush(fp);
1421 PL_formtarget = PL_bodytarget;
1423 PERL_UNUSED_VAR(newsp);
1424 PERL_UNUSED_VAR(gimme);
1425 return cx->blk_sub.retop;
1430 dVAR; dSP; dMARK; dORIGMARK;
1436 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
1438 if (gv && (io = GvIO(gv))
1439 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1441 if (MARK == ORIGMARK) {
1444 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1448 *MARK = SvTIED_obj((SV*)io, mg);
1451 call_method("PRINTF", G_SCALAR);
1454 MARK = ORIGMARK + 1;
1461 if (!(io = GvIO(gv))) {
1462 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1463 report_evil_fh(gv, io, PL_op->op_type);
1464 SETERRNO(EBADF,RMS_IFI);
1467 else if (!(fp = IoOFP(io))) {
1468 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1470 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1471 else if (ckWARN(WARN_CLOSED))
1472 report_evil_fh(gv, io, PL_op->op_type);
1474 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1478 do_sprintf(sv, SP - MARK, MARK + 1);
1479 if (!do_print(sv, fp))
1482 if (IoFLAGS(io) & IOf_FLUSH)
1483 if (PerlIO_flush(fp) == EOF)
1494 PUSHs(&PL_sv_undef);
1502 const int perm = (MAXARG > 3) ? POPi : 0666;
1503 const int mode = POPi;
1504 SV * const sv = POPs;
1505 GV * const gv = (GV *)POPs;
1508 /* Need TIEHANDLE method ? */
1509 const char * const tmps = SvPV_const(sv, len);
1510 /* FIXME? do_open should do const */
1511 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1512 IoLINES(GvIOp(gv)) = 0;
1516 PUSHs(&PL_sv_undef);
1523 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1529 Sock_size_t bufsize;
1537 bool charstart = FALSE;
1538 STRLEN charskip = 0;
1541 GV * const gv = (GV*)*++MARK;
1542 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1543 && gv && (io = GvIO(gv)) )
1545 const MAGIC * mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1549 *MARK = SvTIED_obj((SV*)io, mg);
1551 call_method("READ", G_SCALAR);
1565 sv_setpvn(bufsv, "", 0);
1566 length = SvIVx(*++MARK);
1569 offset = SvIVx(*++MARK);
1573 if (!io || !IoIFP(io)) {
1574 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1575 report_evil_fh(gv, io, PL_op->op_type);
1576 SETERRNO(EBADF,RMS_IFI);
1579 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1580 buffer = SvPVutf8_force(bufsv, blen);
1581 /* UTF-8 may not have been set if they are all low bytes */
1586 buffer = SvPV_force(bufsv, blen);
1587 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1590 DIE(aTHX_ "Negative length");
1598 if (PL_op->op_type == OP_RECV) {
1599 char namebuf[MAXPATHLEN];
1600 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1601 bufsize = sizeof (struct sockaddr_in);
1603 bufsize = sizeof namebuf;
1605 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1609 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1610 /* 'offset' means 'flags' here */
1611 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1612 (struct sockaddr *)namebuf, &bufsize);
1616 /* Bogus return without padding */
1617 bufsize = sizeof (struct sockaddr_in);
1619 SvCUR_set(bufsv, count);
1620 *SvEND(bufsv) = '\0';
1621 (void)SvPOK_only(bufsv);
1625 /* This should not be marked tainted if the fp is marked clean */
1626 if (!(IoFLAGS(io) & IOf_UNTAINT))
1627 SvTAINTED_on(bufsv);
1629 sv_setpvn(TARG, namebuf, bufsize);
1634 if (PL_op->op_type == OP_RECV)
1635 DIE(aTHX_ PL_no_sock_func, "recv");
1637 if (DO_UTF8(bufsv)) {
1638 /* offset adjust in characters not bytes */
1639 blen = sv_len_utf8(bufsv);
1642 if (-offset > (int)blen)
1643 DIE(aTHX_ "Offset outside string");
1646 if (DO_UTF8(bufsv)) {
1647 /* convert offset-as-chars to offset-as-bytes */
1648 if (offset >= (int)blen)
1649 offset += SvCUR(bufsv) - blen;
1651 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1654 bufsize = SvCUR(bufsv);
1655 /* Allocating length + offset + 1 isn't perfect in the case of reading
1656 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1658 (should be 2 * length + offset + 1, or possibly something longer if
1659 PL_encoding is true) */
1660 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1661 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1662 Zero(buffer+bufsize, offset-bufsize, char);
1664 buffer = buffer + offset;
1666 read_target = bufsv;
1668 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1669 concatenate it to the current buffer. */
1671 /* Truncate the existing buffer to the start of where we will be
1673 SvCUR_set(bufsv, offset);
1675 read_target = sv_newmortal();
1676 SvUPGRADE(read_target, SVt_PV);
1677 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1680 if (PL_op->op_type == OP_SYSREAD) {
1681 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1682 if (IoTYPE(io) == IoTYPE_SOCKET) {
1683 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1689 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1694 #ifdef HAS_SOCKET__bad_code_maybe
1695 if (IoTYPE(io) == IoTYPE_SOCKET) {
1696 char namebuf[MAXPATHLEN];
1697 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1698 bufsize = sizeof (struct sockaddr_in);
1700 bufsize = sizeof namebuf;
1702 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1703 (struct sockaddr *)namebuf, &bufsize);
1708 count = PerlIO_read(IoIFP(io), buffer, length);
1709 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1710 if (count == 0 && PerlIO_error(IoIFP(io)))
1714 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1715 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1718 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1719 *SvEND(read_target) = '\0';
1720 (void)SvPOK_only(read_target);
1721 if (fp_utf8 && !IN_BYTES) {
1722 /* Look at utf8 we got back and count the characters */
1723 const char *bend = buffer + count;
1724 while (buffer < bend) {
1726 skip = UTF8SKIP(buffer);
1729 if (buffer - charskip + skip > bend) {
1730 /* partial character - try for rest of it */
1731 length = skip - (bend-buffer);
1732 offset = bend - SvPVX_const(bufsv);
1744 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1745 provided amount read (count) was what was requested (length)
1747 if (got < wanted && count == length) {
1748 length = wanted - got;
1749 offset = bend - SvPVX_const(bufsv);
1752 /* return value is character count */
1756 else if (buffer_utf8) {
1757 /* Let svcatsv upgrade the bytes we read in to utf8.
1758 The buffer is a mortal so will be freed soon. */
1759 sv_catsv_nomg(bufsv, read_target);
1762 /* This should not be marked tainted if the fp is marked clean */
1763 if (!(IoFLAGS(io) & IOf_UNTAINT))
1764 SvTAINTED_on(bufsv);
1776 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1782 STRLEN orig_blen_bytes;
1784 const int op_type = PL_op->op_type;
1788 GV *const gv = (GV*)*++MARK;
1789 if (PL_op->op_type == OP_SYSWRITE
1790 && gv && (io = GvIO(gv))
1791 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
1795 if (MARK == SP - 1) {
1797 sv = sv_2mortal(newSViv(sv_len(*SP)));
1803 *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg);
1805 call_method("WRITE", G_SCALAR);
1820 if (!io || !IoIFP(io)) {
1822 if (ckWARN(WARN_CLOSED))
1823 report_evil_fh(gv, io, PL_op->op_type);
1824 SETERRNO(EBADF,RMS_IFI);
1828 /* Do this first to trigger any overloading. */
1829 buffer = SvPV_const(bufsv, blen);
1830 orig_blen_bytes = blen;
1831 doing_utf8 = DO_UTF8(bufsv);
1833 if (PerlIO_isutf8(IoIFP(io))) {
1834 if (!SvUTF8(bufsv)) {
1835 /* We don't modify the original scalar. */
1836 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1837 buffer = (char *) tmpbuf;
1841 else if (doing_utf8) {
1842 STRLEN tmplen = blen;
1843 U8 *result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1846 buffer = (char *) tmpbuf;
1850 assert((char *)result == buffer);
1851 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1855 if (op_type == OP_SYSWRITE) {
1856 Size_t length = 0; /* This length is in characters. */
1862 /* The SV is bytes, and we've had to upgrade it. */
1863 blen_chars = orig_blen_bytes;
1865 /* The SV really is UTF-8. */
1866 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1867 /* Don't call sv_len_utf8 again because it will call magic
1868 or overloading a second time, and we might get back a
1869 different result. */
1870 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1872 /* It's safe, and it may well be cached. */
1873 blen_chars = sv_len_utf8(bufsv);
1881 length = blen_chars;
1883 #if Size_t_size > IVSIZE
1884 length = (Size_t)SvNVx(*++MARK);
1886 length = (Size_t)SvIVx(*++MARK);
1888 if ((SSize_t)length < 0) {
1890 DIE(aTHX_ "Negative length");
1895 offset = SvIVx(*++MARK);
1897 if (-offset > (IV)blen_chars) {
1899 DIE(aTHX_ "Offset outside string");
1901 offset += blen_chars;
1902 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1904 DIE(aTHX_ "Offset outside string");
1908 if (length > blen_chars - offset)
1909 length = blen_chars - offset;
1911 /* Here we convert length from characters to bytes. */
1912 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1913 /* Either we had to convert the SV, or the SV is magical, or
1914 the SV has overloading, in which case we can't or mustn't
1915 or mustn't call it again. */
1917 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1918 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1920 /* It's a real UTF-8 SV, and it's not going to change under
1921 us. Take advantage of any cache. */
1923 I32 len_I32 = length;
1925 /* Convert the start and end character positions to bytes.
1926 Remember that the second argument to sv_pos_u2b is relative
1928 sv_pos_u2b(bufsv, &start, &len_I32);
1935 buffer = buffer+offset;
1937 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1938 if (IoTYPE(io) == IoTYPE_SOCKET) {
1939 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1945 /* See the note at doio.c:do_print about filesize limits. --jhi */
1946 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1952 const int flags = SvIVx(*++MARK);
1955 char * const sockbuf = SvPVx(*++MARK, mlen);
1956 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1957 flags, (struct sockaddr *)sockbuf, mlen);
1961 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1966 DIE(aTHX_ PL_no_sock_func, "send");
1973 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
1977 #if Size_t_size > IVSIZE
1997 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
1999 gv = PL_last_in_gv = GvEGV(PL_argvgv);
2001 if (io && !IoIFP(io)) {
2002 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2004 IoFLAGS(io) &= ~IOf_START;
2005 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2006 sv_setpvn(GvSV(gv), "-", 1);
2007 SvSETMAGIC(GvSV(gv));
2009 else if (!nextargv(gv))
2014 gv = PL_last_in_gv; /* eof */
2017 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
2020 IO * const io = GvIO(gv);
2022 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
2024 XPUSHs(SvTIED_obj((SV*)io, mg));
2027 call_method("EOF", G_SCALAR);
2034 PUSHs(boolSV(!gv || do_eof(gv)));
2046 PL_last_in_gv = (GV*)POPs;
2049 if (gv && (io = GvIO(gv))
2050 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
2053 XPUSHs(SvTIED_obj((SV*)io, mg));
2056 call_method("TELL", G_SCALAR);
2062 #if LSEEKSIZE > IVSIZE
2063 PUSHn( do_tell(gv) );
2065 PUSHi( do_tell(gv) );
2074 const int whence = POPi;
2075 #if LSEEKSIZE > IVSIZE
2076 const Off_t offset = (Off_t)SvNVx(POPs);
2078 const Off_t offset = (Off_t)SvIVx(POPs);
2082 GV * const gv = PL_last_in_gv = (GV*)POPs;
2084 if (gv && (io = GvIO(gv))
2085 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
2088 XPUSHs(SvTIED_obj((SV*)io, mg));
2089 #if LSEEKSIZE > IVSIZE
2090 XPUSHs(sv_2mortal(newSVnv((NV) offset)));
2092 XPUSHs(sv_2mortal(newSViv(offset)));
2094 XPUSHs(sv_2mortal(newSViv(whence)));
2097 call_method("SEEK", G_SCALAR);
2103 if (PL_op->op_type == OP_SEEK)
2104 PUSHs(boolSV(do_seek(gv, offset, whence)));
2106 const Off_t sought = do_sysseek(gv, offset, whence);
2108 PUSHs(&PL_sv_undef);
2110 SV* const sv = sought ?
2111 #if LSEEKSIZE > IVSIZE
2116 : newSVpvn(zero_but_true, ZBTLEN);
2117 PUSHs(sv_2mortal(sv));
2127 /* There seems to be no consensus on the length type of truncate()
2128 * and ftruncate(), both off_t and size_t have supporters. In
2129 * general one would think that when using large files, off_t is
2130 * at least as wide as size_t, so using an off_t should be okay. */
2131 /* XXX Configure probe for the length type of *truncate() needed XXX */
2134 #if Off_t_size > IVSIZE
2139 /* Checking for length < 0 is problematic as the type might or
2140 * might not be signed: if it is not, clever compilers will moan. */
2141 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2148 if (PL_op->op_flags & OPf_SPECIAL) {
2149 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2158 TAINT_PROPER("truncate");
2159 if (!(fp = IoIFP(io))) {
2165 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2167 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2174 SV * const sv = POPs;
2177 if (SvTYPE(sv) == SVt_PVGV) {
2178 tmpgv = (GV*)sv; /* *main::FRED for example */
2179 goto do_ftruncate_gv;
2181 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2182 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
2183 goto do_ftruncate_gv;
2185 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2186 io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
2187 goto do_ftruncate_io;
2190 name = SvPV_nolen_const(sv);
2191 TAINT_PROPER("truncate");
2193 if (truncate(name, len) < 0)
2197 const int tmpfd = PerlLIO_open(name, O_RDWR);
2202 if (my_chsize(tmpfd, len) < 0)
2204 PerlLIO_close(tmpfd);
2213 SETERRNO(EBADF,RMS_IFI);
2221 SV * const argsv = POPs;
2222 const unsigned int func = POPu;
2223 const int optype = PL_op->op_type;
2224 GV * const gv = (GV*)POPs;
2225 IO * const io = gv ? GvIOn(gv) : NULL;
2229 if (!io || !argsv || !IoIFP(io)) {
2230 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2231 report_evil_fh(gv, io, PL_op->op_type);
2232 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2236 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2239 s = SvPV_force(argsv, len);
2240 need = IOCPARM_LEN(func);
2242 s = Sv_Grow(argsv, need + 1);
2243 SvCUR_set(argsv, need);
2246 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2249 retval = SvIV(argsv);
2250 s = INT2PTR(char*,retval); /* ouch */
2253 TAINT_PROPER(PL_op_desc[optype]);
2255 if (optype == OP_IOCTL)
2257 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2259 DIE(aTHX_ "ioctl is not implemented");
2263 DIE(aTHX_ "fcntl is not implemented");
2265 #if defined(OS2) && defined(__EMX__)
2266 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2268 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2272 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2274 if (s[SvCUR(argsv)] != 17)
2275 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2277 s[SvCUR(argsv)] = 0; /* put our null back */
2278 SvSETMAGIC(argsv); /* Assume it has changed */
2287 PUSHp(zero_but_true, ZBTLEN);
2300 const int argtype = POPi;
2301 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
2303 if (gv && (io = GvIO(gv)))
2309 /* XXX Looks to me like io is always NULL at this point */
2311 (void)PerlIO_flush(fp);
2312 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2315 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2316 report_evil_fh(gv, io, PL_op->op_type);
2318 SETERRNO(EBADF,RMS_IFI);
2323 DIE(aTHX_ PL_no_func, "flock()");
2333 const int protocol = POPi;
2334 const int type = POPi;
2335 const int domain = POPi;
2336 GV * const gv = (GV*)POPs;
2337 register IO * const io = gv ? GvIOn(gv) : NULL;
2341 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2342 report_evil_fh(gv, io, PL_op->op_type);
2343 if (io && IoIFP(io))
2344 do_close(gv, FALSE);
2345 SETERRNO(EBADF,LIB_INVARG);
2350 do_close(gv, FALSE);
2352 TAINT_PROPER("socket");
2353 fd = PerlSock_socket(domain, type, protocol);
2356 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2357 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2358 IoTYPE(io) = IoTYPE_SOCKET;
2359 if (!IoIFP(io) || !IoOFP(io)) {
2360 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2361 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2362 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2365 #if defined(HAS_FCNTL) && defined(F_SETFD)
2366 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2370 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2375 DIE(aTHX_ PL_no_sock_func, "socket");
2381 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2383 const int protocol = POPi;
2384 const int type = POPi;
2385 const int domain = POPi;
2386 GV * const gv2 = (GV*)POPs;
2387 GV * const gv1 = (GV*)POPs;
2388 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2389 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2392 if (!gv1 || !gv2 || !io1 || !io2) {
2393 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2395 report_evil_fh(gv1, io1, PL_op->op_type);
2397 report_evil_fh(gv1, io2, PL_op->op_type);
2399 if (io1 && IoIFP(io1))
2400 do_close(gv1, FALSE);
2401 if (io2 && IoIFP(io2))
2402 do_close(gv2, FALSE);
2407 do_close(gv1, FALSE);
2409 do_close(gv2, FALSE);
2411 TAINT_PROPER("socketpair");
2412 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2414 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2415 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2416 IoTYPE(io1) = IoTYPE_SOCKET;
2417 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2418 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2419 IoTYPE(io2) = IoTYPE_SOCKET;
2420 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2421 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2422 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2423 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2424 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2425 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2426 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2429 #if defined(HAS_FCNTL) && defined(F_SETFD)
2430 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2431 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2436 DIE(aTHX_ PL_no_sock_func, "socketpair");
2444 SV * const addrsv = POPs;
2445 /* OK, so on what platform does bind modify addr? */
2447 GV * const gv = (GV*)POPs;
2448 register IO * const io = GvIOn(gv);
2452 if (!io || !IoIFP(io))
2455 addr = SvPV_const(addrsv, len);
2456 TAINT_PROPER("bind");
2457 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2458 (struct sockaddr *)addr, len) >= 0)
2468 if (ckWARN(WARN_CLOSED))
2469 report_evil_fh(gv, io, PL_op->op_type);
2470 SETERRNO(EBADF,SS_IVCHAN);
2473 DIE(aTHX_ PL_no_sock_func, "bind");
2481 SV * const addrsv = POPs;
2482 GV * const gv = (GV*)POPs;
2483 register IO * const io = GvIOn(gv);
2487 if (!io || !IoIFP(io))
2490 addr = SvPV_const(addrsv, len);
2491 TAINT_PROPER("connect");
2492 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2498 if (ckWARN(WARN_CLOSED))
2499 report_evil_fh(gv, io, PL_op->op_type);
2500 SETERRNO(EBADF,SS_IVCHAN);
2503 DIE(aTHX_ PL_no_sock_func, "connect");
2511 const int backlog = POPi;
2512 GV * const gv = (GV*)POPs;
2513 register IO * const io = gv ? GvIOn(gv) : NULL;
2515 if (!gv || !io || !IoIFP(io))
2518 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2524 if (ckWARN(WARN_CLOSED))
2525 report_evil_fh(gv, io, PL_op->op_type);
2526 SETERRNO(EBADF,SS_IVCHAN);
2529 DIE(aTHX_ PL_no_sock_func, "listen");
2539 char namebuf[MAXPATHLEN];
2540 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2541 Sock_size_t len = sizeof (struct sockaddr_in);
2543 Sock_size_t len = sizeof namebuf;
2545 GV * const ggv = (GV*)POPs;
2546 GV * const ngv = (GV*)POPs;
2555 if (!gstio || !IoIFP(gstio))
2559 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2563 do_close(ngv, FALSE);
2564 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2565 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2566 IoTYPE(nstio) = IoTYPE_SOCKET;
2567 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2568 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2569 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2570 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2573 #if defined(HAS_FCNTL) && defined(F_SETFD)
2574 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2578 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2579 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2581 #ifdef __SCO_VERSION__
2582 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2585 PUSHp(namebuf, len);
2589 if (ckWARN(WARN_CLOSED))
2590 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2591 SETERRNO(EBADF,SS_IVCHAN);
2597 DIE(aTHX_ PL_no_sock_func, "accept");
2605 const int how = POPi;
2606 GV * const gv = (GV*)POPs;
2607 register IO * const io = GvIOn(gv);
2609 if (!io || !IoIFP(io))
2612 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2616 if (ckWARN(WARN_CLOSED))
2617 report_evil_fh(gv, io, PL_op->op_type);
2618 SETERRNO(EBADF,SS_IVCHAN);
2621 DIE(aTHX_ PL_no_sock_func, "shutdown");
2629 const int optype = PL_op->op_type;
2630 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2631 const unsigned int optname = (unsigned int) POPi;
2632 const unsigned int lvl = (unsigned int) POPi;
2633 GV * const gv = (GV*)POPs;
2634 register IO * const io = GvIOn(gv);
2638 if (!io || !IoIFP(io))
2641 fd = PerlIO_fileno(IoIFP(io));
2645 (void)SvPOK_only(sv);
2649 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2656 #if defined(__SYMBIAN32__)
2657 # define SETSOCKOPT_OPTION_VALUE_T void *
2659 # define SETSOCKOPT_OPTION_VALUE_T const char *
2661 /* XXX TODO: We need to have a proper type (a Configure probe,
2662 * etc.) for what the C headers think of the third argument of
2663 * setsockopt(), the option_value read-only buffer: is it
2664 * a "char *", or a "void *", const or not. Some compilers
2665 * don't take kindly to e.g. assuming that "char *" implicitly
2666 * promotes to a "void *", or to explicitly promoting/demoting
2667 * consts to non/vice versa. The "const void *" is the SUS
2668 * definition, but that does not fly everywhere for the above
2670 SETSOCKOPT_OPTION_VALUE_T buf;
2674 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2678 aint = (int)SvIV(sv);
2679 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2682 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2691 if (ckWARN(WARN_CLOSED))
2692 report_evil_fh(gv, io, optype);
2693 SETERRNO(EBADF,SS_IVCHAN);
2698 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2706 const int optype = PL_op->op_type;
2707 GV * const gv = (GV*)POPs;
2708 register IO * const io = GvIOn(gv);
2713 if (!io || !IoIFP(io))
2716 sv = sv_2mortal(newSV(257));
2717 (void)SvPOK_only(sv);
2721 fd = PerlIO_fileno(IoIFP(io));
2723 case OP_GETSOCKNAME:
2724 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2727 case OP_GETPEERNAME:
2728 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2730 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2732 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";
2733 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2734 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2735 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2736 sizeof(u_short) + sizeof(struct in_addr))) {
2743 #ifdef BOGUS_GETNAME_RETURN
2744 /* Interactive Unix, getpeername() and getsockname()
2745 does not return valid namelen */
2746 if (len == BOGUS_GETNAME_RETURN)
2747 len = sizeof(struct sockaddr);
2755 if (ckWARN(WARN_CLOSED))
2756 report_evil_fh(gv, io, optype);
2757 SETERRNO(EBADF,SS_IVCHAN);
2762 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2776 if (PL_op->op_flags & OPf_REF) {
2778 if (PL_op->op_type == OP_LSTAT) {
2779 if (gv != PL_defgv) {
2780 do_fstat_warning_check:
2781 if (ckWARN(WARN_IO))
2782 Perl_warner(aTHX_ packWARN(WARN_IO),
2783 "lstat() on filehandle %s", GvENAME(gv));
2784 } else if (PL_laststype != OP_LSTAT)
2785 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2789 if (gv != PL_defgv) {
2790 PL_laststype = OP_STAT;
2792 sv_setpvn(PL_statname, "", 0);
2793 PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
2794 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
2796 if (PL_laststatval < 0) {
2797 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2798 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2803 SV* const sv = POPs;
2804 if (SvTYPE(sv) == SVt_PVGV) {
2808 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2810 if (PL_op->op_type == OP_LSTAT)
2811 goto do_fstat_warning_check;
2814 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2816 PL_laststype = PL_op->op_type;
2817 if (PL_op->op_type == OP_LSTAT)
2818 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2820 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2821 if (PL_laststatval < 0) {
2822 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2823 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2829 if (gimme != G_ARRAY) {
2830 if (gimme != G_VOID)
2831 XPUSHs(boolSV(max));
2837 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2838 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2839 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2840 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2841 #if Uid_t_size > IVSIZE
2842 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2844 # if Uid_t_sign <= 0
2845 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2847 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2850 #if Gid_t_size > IVSIZE
2851 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2853 # if Gid_t_sign <= 0
2854 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2856 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2859 #ifdef USE_STAT_RDEV
2860 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2862 PUSHs(sv_2mortal(newSVpvs("")));
2864 #if Off_t_size > IVSIZE
2865 PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
2867 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2870 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2871 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2872 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2874 PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2875 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2876 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
2878 #ifdef USE_STAT_BLOCKS
2879 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2880 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2882 PUSHs(sv_2mortal(newSVpvs("")));
2883 PUSHs(sv_2mortal(newSVpvs("")));
2889 /* This macro is used by the stacked filetest operators :
2890 * if the previous filetest failed, short-circuit and pass its value.
2891 * Else, discard it from the stack and continue. --rgs
2893 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2894 if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
2895 else { (void)POPs; PUTBACK; } \
2902 /* Not const, because things tweak this below. Not bool, because there's
2903 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2904 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2905 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2906 /* Giving some sort of initial value silences compilers. */
2908 int access_mode = R_OK;
2910 int access_mode = 0;
2913 /* access_mode is never used, but leaving use_access in makes the
2914 conditional compiling below much clearer. */
2917 int stat_mode = S_IRUSR;
2919 bool effective = FALSE;
2922 STACKED_FTEST_CHECK;
2924 switch (PL_op->op_type) {
2926 #if !(defined(HAS_ACCESS) && defined(R_OK))
2932 #if defined(HAS_ACCESS) && defined(W_OK)
2937 stat_mode = S_IWUSR;
2941 #if defined(HAS_ACCESS) && defined(X_OK)
2946 stat_mode = S_IXUSR;
2950 #ifdef PERL_EFF_ACCESS
2953 stat_mode = S_IWUSR;
2957 #ifndef PERL_EFF_ACCESS
2965 #ifdef PERL_EFF_ACCESS
2970 stat_mode = S_IXUSR;
2976 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2977 const char *const name = POPpx;
2979 # ifdef PERL_EFF_ACCESS
2980 result = PERL_EFF_ACCESS(name, access_mode);
2982 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
2988 result = access(name, access_mode);
2990 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3005 if (cando(stat_mode, effective, &PL_statcache))
3014 const int op_type = PL_op->op_type;
3016 STACKED_FTEST_CHECK;
3021 if (op_type == OP_FTIS)
3024 /* You can't dTARGET inside OP_FTIS, because you'll get
3025 "panic: pad_sv po" - the op is not flagged to have a target. */
3029 #if Off_t_size > IVSIZE
3030 PUSHn(PL_statcache.st_size);
3032 PUSHi(PL_statcache.st_size);
3036 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3039 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3042 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3055 /* I believe that all these three are likely to be defined on most every
3056 system these days. */
3058 if(PL_op->op_type == OP_FTSUID)
3062 if(PL_op->op_type == OP_FTSGID)
3066 if(PL_op->op_type == OP_FTSVTX)
3070 STACKED_FTEST_CHECK;
3075 switch (PL_op->op_type) {
3077 if (PL_statcache.st_uid == PL_uid)
3081 if (PL_statcache.st_uid == PL_euid)
3085 if (PL_statcache.st_size == 0)
3089 if (S_ISSOCK(PL_statcache.st_mode))
3093 if (S_ISCHR(PL_statcache.st_mode))
3097 if (S_ISBLK(PL_statcache.st_mode))
3101 if (S_ISREG(PL_statcache.st_mode))
3105 if (S_ISDIR(PL_statcache.st_mode))
3109 if (S_ISFIFO(PL_statcache.st_mode))
3114 if (PL_statcache.st_mode & S_ISUID)
3120 if (PL_statcache.st_mode & S_ISGID)
3126 if (PL_statcache.st_mode & S_ISVTX)
3137 I32 result = my_lstat();
3141 if (S_ISLNK(PL_statcache.st_mode))
3154 STACKED_FTEST_CHECK;
3156 if (PL_op->op_flags & OPf_REF)
3158 else if (isGV(TOPs))
3160 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3161 gv = (GV*)SvRV(POPs);
3163 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3165 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3166 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3167 else if (tmpsv && SvOK(tmpsv)) {
3168 const char *tmps = SvPV_nolen_const(tmpsv);
3176 if (PerlLIO_isatty(fd))
3181 #if defined(atarist) /* this will work with atariST. Configure will
3182 make guesses for other systems. */
3183 # define FILE_base(f) ((f)->_base)
3184 # define FILE_ptr(f) ((f)->_ptr)
3185 # define FILE_cnt(f) ((f)->_cnt)
3186 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3197 register STDCHAR *s;
3203 STACKED_FTEST_CHECK;
3205 if (PL_op->op_flags & OPf_REF)
3207 else if (isGV(TOPs))
3209 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3210 gv = (GV*)SvRV(POPs);
3216 if (gv == PL_defgv) {
3218 io = GvIO(PL_statgv);
3221 goto really_filename;
3226 PL_laststatval = -1;
3227 sv_setpvn(PL_statname, "", 0);
3228 io = GvIO(PL_statgv);
3230 if (io && IoIFP(io)) {
3231 if (! PerlIO_has_base(IoIFP(io)))
3232 DIE(aTHX_ "-T and -B not implemented on filehandles");
3233 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3234 if (PL_laststatval < 0)
3236 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3237 if (PL_op->op_type == OP_FTTEXT)
3242 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3243 i = PerlIO_getc(IoIFP(io));
3245 (void)PerlIO_ungetc(IoIFP(io),i);
3247 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3249 len = PerlIO_get_bufsiz(IoIFP(io));
3250 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3251 /* sfio can have large buffers - limit to 512 */
3256 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3258 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3260 SETERRNO(EBADF,RMS_IFI);
3268 PL_laststype = OP_STAT;
3269 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3270 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3271 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3273 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3276 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3277 if (PL_laststatval < 0) {
3278 (void)PerlIO_close(fp);
3281 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3282 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3283 (void)PerlIO_close(fp);
3285 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3286 RETPUSHNO; /* special case NFS directories */
3287 RETPUSHYES; /* null file is anything */
3292 /* now scan s to look for textiness */
3293 /* XXX ASCII dependent code */
3295 #if defined(DOSISH) || defined(USEMYBINMODE)
3296 /* ignore trailing ^Z on short files */
3297 if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3301 for (i = 0; i < len; i++, s++) {
3302 if (!*s) { /* null never allowed in text */
3307 else if (!(isPRINT(*s) || isSPACE(*s)))
3310 else if (*s & 128) {
3312 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3315 /* utf8 characters don't count as odd */
3316 if (UTF8_IS_START(*s)) {
3317 int ulen = UTF8SKIP(s);
3318 if (ulen < len - i) {
3320 for (j = 1; j < ulen; j++) {
3321 if (!UTF8_IS_CONTINUATION(s[j]))
3324 --ulen; /* loop does extra increment */
3334 *s != '\n' && *s != '\r' && *s != '\b' &&
3335 *s != '\t' && *s != '\f' && *s != 27)
3340 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3351 const char *tmps = NULL;
3355 SV * const sv = POPs;
3356 if (PL_op->op_flags & OPf_SPECIAL) {
3357 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3359 else if (SvTYPE(sv) == SVt_PVGV) {
3362 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
3366 tmps = SvPVx_nolen_const(sv);
3370 if( !gv && (!tmps || !*tmps) ) {
3371 HV * const table = GvHVn(PL_envgv);
3374 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3375 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3377 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3382 deprecate("chdir('') or chdir(undef) as chdir()");
3383 tmps = SvPV_nolen_const(*svp);
3387 TAINT_PROPER("chdir");
3392 TAINT_PROPER("chdir");
3395 IO* const io = GvIO(gv);
3398 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3400 else if (IoDIRP(io)) {
3402 PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0);
3404 DIE(aTHX_ PL_no_func, "dirfd");
3408 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3409 report_evil_fh(gv, io, PL_op->op_type);
3410 SETERRNO(EBADF, RMS_IFI);
3415 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3416 report_evil_fh(gv, io, PL_op->op_type);
3417 SETERRNO(EBADF,RMS_IFI);
3421 DIE(aTHX_ PL_no_func, "fchdir");
3425 PUSHi( PerlDir_chdir(tmps) >= 0 );
3427 /* Clear the DEFAULT element of ENV so we'll get the new value
3429 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3436 dVAR; dSP; dMARK; dTARGET;
3437 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3448 char * const tmps = POPpx;
3449 TAINT_PROPER("chroot");
3450 PUSHi( chroot(tmps) >= 0 );
3453 DIE(aTHX_ PL_no_func, "chroot");
3461 const char * const tmps2 = POPpconstx;
3462 const char * const tmps = SvPV_nolen_const(TOPs);
3463 TAINT_PROPER("rename");
3465 anum = PerlLIO_rename(tmps, tmps2);
3467 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3468 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3471 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3472 (void)UNLINK(tmps2);
3473 if (!(anum = link(tmps, tmps2)))
3474 anum = UNLINK(tmps);
3482 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3486 const int op_type = PL_op->op_type;
3490 if (op_type == OP_LINK)
3491 DIE(aTHX_ PL_no_func, "link");
3493 # ifndef HAS_SYMLINK
3494 if (op_type == OP_SYMLINK)
3495 DIE(aTHX_ PL_no_func, "symlink");
3499 const char * const tmps2 = POPpconstx;
3500 const char * const tmps = SvPV_nolen_const(TOPs);
3501 TAINT_PROPER(PL_op_desc[op_type]);
3503 # if defined(HAS_LINK)
3504 # if defined(HAS_SYMLINK)
3505 /* Both present - need to choose which. */
3506 (op_type == OP_LINK) ?
3507 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3509 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3510 PerlLIO_link(tmps, tmps2);
3513 # if defined(HAS_SYMLINK)
3514 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3515 symlink(tmps, tmps2);
3520 SETi( result >= 0 );
3527 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3538 char buf[MAXPATHLEN];
3541 #ifndef INCOMPLETE_TAINTS
3545 len = readlink(tmps, buf, sizeof(buf) - 1);
3553 RETSETUNDEF; /* just pretend it's a normal file */
3557 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3559 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3561 char * const save_filename = filename;
3567 Newx(cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3568 strcpy(cmdline, cmd);
3569 strcat(cmdline, " ");
3570 for (s = cmdline + strlen(cmdline); *filename; ) {
3575 myfp = PerlProc_popen(cmdline, "r");
3579 SV * const tmpsv = sv_newmortal();
3580 /* Need to save/restore 'PL_rs' ?? */
3581 s = sv_gets(tmpsv, myfp, 0);
3582 (void)PerlProc_pclose(myfp);
3586 #ifdef HAS_SYS_ERRLIST
3591 /* you don't see this */
3592 const char * const errmsg =
3593 #ifdef HAS_SYS_ERRLIST
3601 if (instr(s, errmsg)) {
3608 #define EACCES EPERM
3610 if (instr(s, "cannot make"))
3611 SETERRNO(EEXIST,RMS_FEX);
3612 else if (instr(s, "existing file"))
3613 SETERRNO(EEXIST,RMS_FEX);
3614 else if (instr(s, "ile exists"))
3615 SETERRNO(EEXIST,RMS_FEX);
3616 else if (instr(s, "non-exist"))
3617 SETERRNO(ENOENT,RMS_FNF);
3618 else if (instr(s, "does not exist"))
3619 SETERRNO(ENOENT,RMS_FNF);
3620 else if (instr(s, "not empty"))
3621 SETERRNO(EBUSY,SS_DEVOFFLINE);
3622 else if (instr(s, "cannot access"))
3623 SETERRNO(EACCES,RMS_PRV);
3625 SETERRNO(EPERM,RMS_PRV);
3628 else { /* some mkdirs return no failure indication */
3629 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3630 if (PL_op->op_type == OP_RMDIR)
3635 SETERRNO(EACCES,RMS_PRV); /* a guess */
3644 /* This macro removes trailing slashes from a directory name.
3645 * Different operating and file systems take differently to
3646 * trailing slashes. According to POSIX 1003.1 1996 Edition
3647 * any number of trailing slashes should be allowed.
3648 * Thusly we snip them away so that even non-conforming
3649 * systems are happy.
3650 * We should probably do this "filtering" for all
3651 * the functions that expect (potentially) directory names:
3652 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3653 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3655 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3656 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3659 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3660 (tmps) = savepvn((tmps), (len)); \
3670 const int mode = (MAXARG > 1) ? POPi : 0777;
3672 TRIMSLASHES(tmps,len,copy);
3674 TAINT_PROPER("mkdir");
3676 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3680 SETi( dooneliner("mkdir", tmps) );
3681 oldumask = PerlLIO_umask(0);
3682 PerlLIO_umask(oldumask);
3683 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3698 TRIMSLASHES(tmps,len,copy);
3699 TAINT_PROPER("rmdir");
3701 SETi( PerlDir_rmdir(tmps) >= 0 );
3703 SETi( dooneliner("rmdir", tmps) );
3710 /* Directory calls. */
3714 #if defined(Direntry_t) && defined(HAS_READDIR)
3716 const char * const dirname = POPpconstx;
3717 GV * const gv = (GV*)POPs;
3718 register IO * const io = GvIOn(gv);
3724 PerlDir_close(IoDIRP(io));
3725 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3731 SETERRNO(EBADF,RMS_DIR);
3734 DIE(aTHX_ PL_no_dir_func, "opendir");
3740 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3741 DIE(aTHX_ PL_no_dir_func, "readdir");
3743 #if !defined(I_DIRENT) && !defined(VMS)
3744 Direntry_t *readdir (DIR *);
3750 const I32 gimme = GIMME;
3751 GV * const gv = (GV *)POPs;
3752 register const Direntry_t *dp;
3753 register IO * const io = GvIOn(gv);
3755 if (!io || !IoDIRP(io)) {
3756 if(ckWARN(WARN_IO)) {
3757 Perl_warner(aTHX_ packWARN(WARN_IO),
3758 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3764 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3768 sv = newSVpvn(dp->d_name, dp->d_namlen);
3770 sv = newSVpv(dp->d_name, 0);
3772 #ifndef INCOMPLETE_TAINTS
3773 if (!(IoFLAGS(io) & IOf_UNTAINT))
3776 XPUSHs(sv_2mortal(sv));
3778 while (gimme == G_ARRAY);
3780 if (!dp && gimme != G_ARRAY)
3787 SETERRNO(EBADF,RMS_ISI);
3788 if (GIMME == G_ARRAY)
3797 #if defined(HAS_TELLDIR) || defined(telldir)
3799 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3800 /* XXX netbsd still seemed to.
3801 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3802 --JHI 1999-Feb-02 */
3803 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3804 long telldir (DIR *);
3806 GV * const gv = (GV*)POPs;
3807 register IO * const io = GvIOn(gv);
3809 if (!io || !IoDIRP(io)) {
3810 if(ckWARN(WARN_IO)) {
3811 Perl_warner(aTHX_ packWARN(WARN_IO),
3812 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3817 PUSHi( PerlDir_tell(IoDIRP(io)) );
3821 SETERRNO(EBADF,RMS_ISI);
3824 DIE(aTHX_ PL_no_dir_func, "telldir");
3830 #if defined(HAS_SEEKDIR) || defined(seekdir)
3832 const long along = POPl;
3833 GV * const gv = (GV*)POPs;
3834 register IO * const io = GvIOn(gv);
3836 if (!io || !IoDIRP(io)) {
3837 if(ckWARN(WARN_IO)) {
3838 Perl_warner(aTHX_ packWARN(WARN_IO),
3839 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3843 (void)PerlDir_seek(IoDIRP(io), along);
3848 SETERRNO(EBADF,RMS_ISI);
3851 DIE(aTHX_ PL_no_dir_func, "seekdir");
3857 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3859 GV * const gv = (GV*)POPs;
3860 register IO * const io = GvIOn(gv);
3862 if (!io || !IoDIRP(io)) {
3863 if(ckWARN(WARN_IO)) {
3864 Perl_warner(aTHX_ packWARN(WARN_IO),
3865 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3869 (void)PerlDir_rewind(IoDIRP(io));
3873 SETERRNO(EBADF,RMS_ISI);
3876 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3882 #if defined(Direntry_t) && defined(HAS_READDIR)
3884 GV * const gv = (GV*)POPs;
3885 register IO * const io = GvIOn(gv);
3887 if (!io || !IoDIRP(io)) {
3888 if(ckWARN(WARN_IO)) {
3889 Perl_warner(aTHX_ packWARN(WARN_IO),
3890 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3894 #ifdef VOID_CLOSEDIR
3895 PerlDir_close(IoDIRP(io));
3897 if (PerlDir_close(IoDIRP(io)) < 0) {
3898 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3907 SETERRNO(EBADF,RMS_IFI);
3910 DIE(aTHX_ PL_no_dir_func, "closedir");
3914 /* Process control. */
3923 PERL_FLUSHALL_FOR_CHILD;
3924 childpid = PerlProc_fork();
3928 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3930 SvREADONLY_off(GvSV(tmpgv));
3931 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3932 SvREADONLY_on(GvSV(tmpgv));
3934 #ifdef THREADS_HAVE_PIDS
3935 PL_ppid = (IV)getppid();
3937 #ifdef PERL_USES_PL_PIDSTATUS
3938 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3944 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3949 PERL_FLUSHALL_FOR_CHILD;
3950 childpid = PerlProc_fork();
3956 DIE(aTHX_ PL_no_func, "fork");
3963 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3968 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
3969 childpid = wait4pid(-1, &argflags, 0);
3971 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
3976 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3977 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3978 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
3980 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
3985 DIE(aTHX_ PL_no_func, "wait");
3991 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
3993 const int optype = POPi;
3994 const Pid_t pid = TOPi;
3998 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
3999 result = wait4pid(pid, &argflags, optype);
4001 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4006 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4007 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4008 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4010 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4015 DIE(aTHX_ PL_no_func, "waitpid");
4021 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4027 while (++MARK <= SP) {
4028 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4033 TAINT_PROPER("system");
4035 PERL_FLUSHALL_FOR_CHILD;
4036 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4042 if (PerlProc_pipe(pp) >= 0)
4044 while ((childpid = PerlProc_fork()) == -1) {
4045 if (errno != EAGAIN) {
4050 PerlLIO_close(pp[0]);
4051 PerlLIO_close(pp[1]);
4058 Sigsave_t ihand,qhand; /* place to save signals during system() */
4062 PerlLIO_close(pp[1]);
4064 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4065 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4068 result = wait4pid(childpid, &status, 0);
4069 } while (result == -1 && errno == EINTR);
4071 (void)rsignal_restore(SIGINT, &ihand);
4072 (void)rsignal_restore(SIGQUIT, &qhand);
4074 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4075 do_execfree(); /* free any memory child malloced on fork */
4082 while (n < sizeof(int)) {
4083 n1 = PerlLIO_read(pp[0],
4084 (void*)(((char*)&errkid)+n),
4090 PerlLIO_close(pp[0]);
4091 if (n) { /* Error */
4092 if (n != sizeof(int))
4093 DIE(aTHX_ "panic: kid popen errno read");
4094 errno = errkid; /* Propagate errno from kid */
4095 STATUS_NATIVE_CHILD_SET(-1);
4098 XPUSHi(STATUS_CURRENT);
4102 PerlLIO_close(pp[0]);
4103 #if defined(HAS_FCNTL) && defined(F_SETFD)
4104 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4107 if (PL_op->op_flags & OPf_STACKED) {
4108 SV * const really = *++MARK;
4109 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4111 else if (SP - MARK != 1)
4112 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4114 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4118 #else /* ! FORK or VMS or OS/2 */
4121 if (PL_op->op_flags & OPf_STACKED) {
4122 SV * const really = *++MARK;
4123 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4124 value = (I32)do_aspawn(really, MARK, SP);
4126 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4129 else if (SP - MARK != 1) {
4130 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4131 value = (I32)do_aspawn(NULL, MARK, SP);
4133 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4137 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4139 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4141 STATUS_NATIVE_CHILD_SET(value);
4144 XPUSHi(result ? value : STATUS_CURRENT);
4145 #endif /* !FORK or VMS */
4151 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4156 while (++MARK <= SP) {
4157 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4162 TAINT_PROPER("exec");
4164 PERL_FLUSHALL_FOR_CHILD;
4165 if (PL_op->op_flags & OPf_STACKED) {
4166 SV * const really = *++MARK;
4167 value = (I32)do_aexec(really, MARK, SP);
4169 else if (SP - MARK != 1)
4171 value = (I32)vms_do_aexec(NULL, MARK, SP);
4175 (void ) do_aspawn(NULL, MARK, SP);
4179 value = (I32)do_aexec(NULL, MARK, SP);
4184 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4187 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4190 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4204 # ifdef THREADS_HAVE_PIDS
4205 if (PL_ppid != 1 && getppid() == 1)
4206 /* maybe the parent process has died. Refresh ppid cache */
4210 XPUSHi( getppid() );
4214 DIE(aTHX_ PL_no_func, "getppid");
4223 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4226 pgrp = (I32)BSD_GETPGRP(pid);
4228 if (pid != 0 && pid != PerlProc_getpid())
4229 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4235 DIE(aTHX_ PL_no_func, "getpgrp()");
4254 TAINT_PROPER("setpgrp");
4256 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4258 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4259 || (pid != 0 && pid != PerlProc_getpid()))
4261 DIE(aTHX_ "setpgrp can't take arguments");
4263 SETi( setpgrp() >= 0 );
4264 #endif /* USE_BSDPGRP */
4267 DIE(aTHX_ PL_no_func, "setpgrp()");
4273 #ifdef HAS_GETPRIORITY
4275 const int who = POPi;
4276 const int which = TOPi;
4277 SETi( getpriority(which, who) );
4280 DIE(aTHX_ PL_no_func, "getpriority()");
4286 #ifdef HAS_SETPRIORITY
4288 const int niceval = POPi;
4289 const int who = POPi;
4290 const int which = TOPi;
4291 TAINT_PROPER("setpriority");
4292 SETi( setpriority(which, who, niceval) >= 0 );
4295 DIE(aTHX_ PL_no_func, "setpriority()");
4305 XPUSHn( time(NULL) );
4307 XPUSHi( time(NULL) );
4319 (void)PerlProc_times(&PL_timesbuf);
4321 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4322 /* struct tms, though same data */
4326 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
4327 if (GIMME == G_ARRAY) {
4328 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
4329 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
4330 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
4336 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4338 if (GIMME == G_ARRAY) {
4339 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4340 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4341 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4345 DIE(aTHX_ "times not implemented");
4347 #endif /* HAS_TIMES */
4350 #ifdef LOCALTIME_EDGECASE_BROKEN
4351 static struct tm *S_my_localtime (pTHX_ Time_t *tp)
4356 /* No workarounds in the valid range */
4357 if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4358 return (localtime (tp));
4360 /* This edge case is to workaround the undefined behaviour, where the
4361 * TIMEZONE makes the time go beyond the defined range.
4362 * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4363 * If there is a negative offset in TZ, like MET-1METDST, some broken
4364 * implementations of localtime () (like AIX 5.2) barf with bogus
4366 * 0x7fffffff gmtime 2038-01-19 03:14:07
4367 * 0x7fffffff localtime 1901-12-13 21:45:51
4368 * 0x7fffffff mylocaltime 2038-01-19 04:14:07
4369 * 0x3c19137f gmtime 2001-12-13 20:45:51
4370 * 0x3c19137f localtime 2001-12-13 21:45:51
4371 * 0x3c19137f mylocaltime 2001-12-13 21:45:51
4372 * Given that legal timezones are typically between GMT-12 and GMT+12
4373 * we turn back the clock 23 hours before calling the localtime
4374 * function, and add those to the return value. This will never cause
4375 * day wrapping problems, since the edge case is Tue Jan *19*
4377 T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4380 if (P->tm_hour >= 24) {
4382 P->tm_mday++; /* 18 -> 19 */
4383 P->tm_wday++; /* Mon -> Tue */
4384 P->tm_yday++; /* 18 -> 19 */
4387 } /* S_my_localtime */
4395 const struct tm *tmbuf;
4396 static const char * const dayname[] =
4397 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4398 static const char * const monname[] =
4399 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4400 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4406 when = (Time_t)SvNVx(POPs);
4408 when = (Time_t)SvIVx(POPs);
4411 if (PL_op->op_type == OP_LOCALTIME)
4412 #ifdef LOCALTIME_EDGECASE_BROKEN
4413 tmbuf = S_my_localtime(aTHX_ &when);
4415 tmbuf = localtime(&when);
4418 tmbuf = gmtime(&when);
4420 if (GIMME != G_ARRAY) {
4426 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4427 dayname[tmbuf->tm_wday],
4428 monname[tmbuf->tm_mon],
4433 tmbuf->tm_year + 1900);
4434 PUSHs(sv_2mortal(tsv));
4439 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4440 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4441 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4442 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4443 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4444 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4445 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4446 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4447 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4458 anum = alarm((unsigned int)anum);
4465 DIE(aTHX_ PL_no_func, "alarm");
4476 (void)time(&lasttime);
4481 PerlProc_sleep((unsigned int)duration);
4484 XPUSHi(when - lasttime);
4488 /* Shared memory. */
4489 /* Merged with some message passing. */
4493 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4494 dVAR; dSP; dMARK; dTARGET;
4495 const int op_type = PL_op->op_type;
4500 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4503 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4506 value = (I32)(do_semop(MARK, SP) >= 0);
4509 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4525 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4526 dVAR; dSP; dMARK; dTARGET;
4527 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4534 DIE(aTHX_ "System V IPC is not implemented on this machine");
4540 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4541 dVAR; dSP; dMARK; dTARGET;
4542 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4550 PUSHp(zero_but_true, ZBTLEN);
4558 /* I can't const this further without getting warnings about the types of
4559 various arrays passed in from structures. */
4561 S_space_join_names_mortal(pTHX_ char *const *array)
4565 if (array && *array) {
4566 target = sv_2mortal(newSVpvs(""));
4568 sv_catpv(target, *array);
4571 sv_catpvs(target, " ");
4574 target = sv_mortalcopy(&PL_sv_no);
4579 /* Get system info. */
4583 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4585 I32 which = PL_op->op_type;
4586 register char **elem;
4588 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4589 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4590 struct hostent *gethostbyname(Netdb_name_t);
4591 struct hostent *gethostent(void);
4593 struct hostent *hent;
4597 if (which == OP_GHBYNAME) {
4598 #ifdef HAS_GETHOSTBYNAME
4599 const char* const name = POPpbytex;
4600 hent = PerlSock_gethostbyname(name);
4602 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4605 else if (which == OP_GHBYADDR) {
4606 #ifdef HAS_GETHOSTBYADDR
4607 const int addrtype = POPi;
4608 SV * const addrsv = POPs;
4610 Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4612 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4614 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4618 #ifdef HAS_GETHOSTENT
4619 hent = PerlSock_gethostent();
4621 DIE(aTHX_ PL_no_sock_func, "gethostent");
4624 #ifdef HOST_NOT_FOUND
4626 #ifdef USE_REENTRANT_API
4627 # ifdef USE_GETHOSTENT_ERRNO
4628 h_errno = PL_reentrant_buffer->_gethostent_errno;
4631 STATUS_UNIX_SET(h_errno);
4635 if (GIMME != G_ARRAY) {
4636 PUSHs(sv = sv_newmortal());
4638 if (which == OP_GHBYNAME) {
4640 sv_setpvn(sv, hent->h_addr, hent->h_length);
4643 sv_setpv(sv, (char*)hent->h_name);
4649 PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
4650 PUSHs(space_join_names_mortal(hent->h_aliases));
4651 PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
4652 len = hent->h_length;
4653 PUSHs(sv_2mortal(newSViv((IV)len)));
4655 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4656 XPUSHs(sv_2mortal(newSVpvn(*elem, len)));
4660 PUSHs(newSVpvn(hent->h_addr, len));
4662 PUSHs(sv_mortalcopy(&PL_sv_no));
4667 DIE(aTHX_ PL_no_sock_func, "gethostent");
4673 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4675 I32 which = PL_op->op_type;
4677 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4678 struct netent *getnetbyaddr(Netdb_net_t, int);
4679 struct netent *getnetbyname(Netdb_name_t);
4680 struct netent *getnetent(void);
4682 struct netent *nent;
4684 if (which == OP_GNBYNAME){
4685 #ifdef HAS_GETNETBYNAME
4686 const char * const name = POPpbytex;
4687 nent = PerlSock_getnetbyname(name);
4689 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4692 else if (which == OP_GNBYADDR) {
4693 #ifdef HAS_GETNETBYADDR
4694 const int addrtype = POPi;
4695 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4696 nent = PerlSock_getnetbyaddr(addr, addrtype);
4698 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4702 #ifdef HAS_GETNETENT
4703 nent = PerlSock_getnetent();
4705 DIE(aTHX_ PL_no_sock_func, "getnetent");
4708 #ifdef HOST_NOT_FOUND
4710 #ifdef USE_REENTRANT_API
4711 # ifdef USE_GETNETENT_ERRNO
4712 h_errno = PL_reentrant_buffer->_getnetent_errno;
4715 STATUS_UNIX_SET(h_errno);
4720 if (GIMME != G_ARRAY) {
4721 PUSHs(sv = sv_newmortal());
4723 if (which == OP_GNBYNAME)
4724 sv_setiv(sv, (IV)nent->n_net);
4726 sv_setpv(sv, nent->n_name);
4732 PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
4733 PUSHs(space_join_names_mortal(nent->n_aliases));
4734 PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
4735 PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
4740 DIE(aTHX_ PL_no_sock_func, "getnetent");
4746 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4748 I32 which = PL_op->op_type;
4750 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4751 struct protoent *getprotobyname(Netdb_name_t);
4752 struct protoent *getprotobynumber(int);
4753 struct protoent *getprotoent(void);
4755 struct protoent *pent;
4757 if (which == OP_GPBYNAME) {
4758 #ifdef HAS_GETPROTOBYNAME
4759 const char* const name = POPpbytex;
4760 pent = PerlSock_getprotobyname(name);
4762 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4765 else if (which == OP_GPBYNUMBER) {
4766 #ifdef HAS_GETPROTOBYNUMBER
4767 const int number = POPi;
4768 pent = PerlSock_getprotobynumber(number);
4770 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4774 #ifdef HAS_GETPROTOENT
4775 pent = PerlSock_getprotoent();
4777 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4781 if (GIMME != G_ARRAY) {
4782 PUSHs(sv = sv_newmortal());
4784 if (which == OP_GPBYNAME)
4785 sv_setiv(sv, (IV)pent->p_proto);
4787 sv_setpv(sv, pent->p_name);
4793 PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
4794 PUSHs(space_join_names_mortal(pent->p_aliases));
4795 PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
4800 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4806 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4808 I32 which = PL_op->op_type;
4810 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4811 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4812 struct servent *getservbyport(int, Netdb_name_t);
4813 struct servent *getservent(void);
4815 struct servent *sent;
4817 if (which == OP_GSBYNAME) {
4818 #ifdef HAS_GETSERVBYNAME
4819 const char * const proto = POPpbytex;
4820 const char * const name = POPpbytex;
4821 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4823 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4826 else if (which == OP_GSBYPORT) {
4827 #ifdef HAS_GETSERVBYPORT
4828 const char * const proto = POPpbytex;
4829 unsigned short port = (unsigned short)POPu;
4831 port = PerlSock_htons(port);
4833 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4835 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4839 #ifdef HAS_GETSERVENT
4840 sent = PerlSock_getservent();
4842 DIE(aTHX_ PL_no_sock_func, "getservent");
4846 if (GIMME != G_ARRAY) {
4847 PUSHs(sv = sv_newmortal());
4849 if (which == OP_GSBYNAME) {
4851 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4853 sv_setiv(sv, (IV)(sent->s_port));
4857 sv_setpv(sv, sent->s_name);
4863 PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
4864 PUSHs(space_join_names_mortal(sent->s_aliases));
4866 PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
4868 PUSHs(sv_2mortal(newSViv((IV)(sent->s_port))));
4870 PUSHs(sv_2mortal(newSVpv(sent->s_proto, 0)));
4875 DIE(aTHX_ PL_no_sock_func, "getservent");
4881 #ifdef HAS_SETHOSTENT
4883 PerlSock_sethostent(TOPi);
4886 DIE(aTHX_ PL_no_sock_func, "sethostent");
4892 #ifdef HAS_SETNETENT
4894 PerlSock_setnetent(TOPi);
4897 DIE(aTHX_ PL_no_sock_func, "setnetent");
4903 #ifdef HAS_SETPROTOENT
4905 PerlSock_setprotoent(TOPi);
4908 DIE(aTHX_ PL_no_sock_func, "setprotoent");
4914 #ifdef HAS_SETSERVENT
4916 PerlSock_setservent(TOPi);
4919 DIE(aTHX_ PL_no_sock_func, "setservent");
4925 #ifdef HAS_ENDHOSTENT
4927 PerlSock_endhostent();
4931 DIE(aTHX_ PL_no_sock_func, "endhostent");
4937 #ifdef HAS_ENDNETENT
4939 PerlSock_endnetent();
4943 DIE(aTHX_ PL_no_sock_func, "endnetent");
4949 #ifdef HAS_ENDPROTOENT
4951 PerlSock_endprotoent();
4955 DIE(aTHX_ PL_no_sock_func, "endprotoent");
4961 #ifdef HAS_ENDSERVENT
4963 PerlSock_endservent();
4967 DIE(aTHX_ PL_no_sock_func, "endservent");
4975 I32 which = PL_op->op_type;
4977 struct passwd *pwent = NULL;
4979 * We currently support only the SysV getsp* shadow password interface.
4980 * The interface is declared in <shadow.h> and often one needs to link
4981 * with -lsecurity or some such.
4982 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
4985 * AIX getpwnam() is clever enough to return the encrypted password
4986 * only if the caller (euid?) is root.
4988 * There are at least three other shadow password APIs. Many platforms
4989 * seem to contain more than one interface for accessing the shadow
4990 * password databases, possibly for compatibility reasons.
4991 * The getsp*() is by far he simplest one, the other two interfaces
4992 * are much more complicated, but also very similar to each other.
4997 * struct pr_passwd *getprpw*();
4998 * The password is in
4999 * char getprpw*(...).ufld.fd_encrypt[]
5000 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5005 * struct es_passwd *getespw*();
5006 * The password is in
5007 * char *(getespw*(...).ufld.fd_encrypt)
5008 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5011 * struct userpw *getuserpw();
5012 * The password is in
5013 * char *(getuserpw(...)).spw_upw_passwd
5014 * (but the de facto standard getpwnam() should work okay)
5016 * Mention I_PROT here so that Configure probes for it.
5018 * In HP-UX for getprpw*() the manual page claims that one should include
5019 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5020 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5021 * and pp_sys.c already includes <shadow.h> if there is such.
5023 * Note that <sys/security.h> is already probed for, but currently
5024 * it is only included in special cases.
5026 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5027 * be preferred interface, even though also the getprpw*() interface
5028 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5029 * One also needs to call set_auth_parameters() in main() before
5030 * doing anything else, whether one is using getespw*() or getprpw*().
5032 * Note that accessing the shadow databases can be magnitudes
5033 * slower than accessing the standard databases.
5038 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5039 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5040 * the pw_comment is left uninitialized. */
5041 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5047 const char* const name = POPpbytex;
5048 pwent = getpwnam(name);
5054 pwent = getpwuid(uid);
5058 # ifdef HAS_GETPWENT
5060 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5061 if (pwent) pwent = getpwnam(pwent->pw_name);
5064 DIE(aTHX_ PL_no_func, "getpwent");
5070 if (GIMME != G_ARRAY) {
5071 PUSHs(sv = sv_newmortal());
5073 if (which == OP_GPWNAM)
5074 # if Uid_t_sign <= 0
5075 sv_setiv(sv, (IV)pwent->pw_uid);
5077 sv_setuv(sv, (UV)pwent->pw_uid);
5080 sv_setpv(sv, pwent->pw_name);
5086 PUSHs(sv_2mortal(newSVpv(pwent->pw_name, 0)));
5088 PUSHs(sv = sv_2mortal(newSViv(0)));
5089 /* If we have getspnam(), we try to dig up the shadow
5090 * password. If we are underprivileged, the shadow
5091 * interface will set the errno to EACCES or similar,
5092 * and return a null pointer. If this happens, we will
5093 * use the dummy password (usually "*" or "x") from the
5094 * standard password database.
5096 * In theory we could skip the shadow call completely
5097 * if euid != 0 but in practice we cannot know which
5098 * security measures are guarding the shadow databases
5099 * on a random platform.
5101 * Resist the urge to use additional shadow interfaces.
5102 * Divert the urge to writing an extension instead.
5105 /* Some AIX setups falsely(?) detect some getspnam(), which
5106 * has a different API than the Solaris/IRIX one. */
5107 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5109 const int saverrno = errno;
5110 const struct spwd * const spwent = getspnam(pwent->pw_name);
5111 /* Save and restore errno so that
5112 * underprivileged attempts seem
5113 * to have never made the unsccessful
5114 * attempt to retrieve the shadow password. */
5116 if (spwent && spwent->sp_pwdp)
5117 sv_setpv(sv, spwent->sp_pwdp);
5121 if (!SvPOK(sv)) /* Use the standard password, then. */
5122 sv_setpv(sv, pwent->pw_passwd);
5125 # ifndef INCOMPLETE_TAINTS
5126 /* passwd is tainted because user himself can diddle with it.
5127 * admittedly not much and in a very limited way, but nevertheless. */
5131 # if Uid_t_sign <= 0
5132 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_uid)));
5134 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_uid)));
5137 # if Uid_t_sign <= 0
5138 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_gid)));
5140 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_gid)));
5142 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5143 * because of the poor interface of the Perl getpw*(),
5144 * not because there's some standard/convention saying so.
5145 * A better interface would have been to return a hash,
5146 * but we are accursed by our history, alas. --jhi. */
5148 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_change)));
5151 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_quota)));
5154 PUSHs(sv_2mortal(newSVpv(pwent->pw_age, 0)));
5156 /* I think that you can never get this compiled, but just in case. */
5157 PUSHs(sv_mortalcopy(&PL_sv_no));
5162 /* pw_class and pw_comment are mutually exclusive--.
5163 * see the above note for pw_change, pw_quota, and pw_age. */
5165 PUSHs(sv_2mortal(newSVpv(pwent->pw_class, 0)));
5168 PUSHs(sv_2mortal(newSVpv(pwent->pw_comment, 0)));
5170 /* I think that you can never get this compiled, but just in case. */
5171 PUSHs(sv_mortalcopy(&PL_sv_no));
5176 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5178 PUSHs(sv_mortalcopy(&PL_sv_no));
5180 # ifndef INCOMPLETE_TAINTS
5181 /* pw_gecos is tainted because user himself can diddle with it. */
5185 PUSHs(sv_2mortal(newSVpv(pwent->pw_dir, 0)));
5187 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5188 # ifndef INCOMPLETE_TAINTS
5189 /* pw_shell is tainted because user himself can diddle with it. */
5194 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_expire)));
5199 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5205 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5210 DIE(aTHX_ PL_no_func, "setpwent");
5216 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5221 DIE(aTHX_ PL_no_func, "endpwent");
5229 const I32 which = PL_op->op_type;
5230 const struct group *grent;
5232 if (which == OP_GGRNAM) {
5233 const char* const name = POPpbytex;
5234 grent = (const struct group *)getgrnam(name);
5236 else if (which == OP_GGRGID) {
5237 const Gid_t gid = POPi;
5238 grent = (const struct group *)getgrgid(gid);
5242 grent = (struct group *)getgrent();
5244 DIE(aTHX_ PL_no_func, "getgrent");
5248 if (GIMME != G_ARRAY) {
5249 SV * const sv = sv_newmortal();
5253 if (which == OP_GGRNAM)
5254 sv_setiv(sv, (IV)grent->gr_gid);
5256 sv_setpv(sv, grent->gr_name);
5262 PUSHs(sv_2mortal(newSVpv(grent->gr_name, 0)));
5265 PUSHs(sv_2mortal(newSVpv(grent->gr_passwd, 0)));
5267 PUSHs(sv_mortalcopy(&PL_sv_no));
5270 PUSHs(sv_2mortal(newSViv((IV)grent->gr_gid)));
5272 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5273 /* In UNICOS/mk (_CRAYMPP) the multithreading
5274 * versions (getgrnam_r, getgrgid_r)
5275 * seem to return an illegal pointer
5276 * as the group members list, gr_mem.
5277 * getgrent() doesn't even have a _r version
5278 * but the gr_mem is poisonous anyway.
5279 * So yes, you cannot get the list of group
5280 * members if building multithreaded in UNICOS/mk. */
5281 PUSHs(space_join_names_mortal(grent->gr_mem));
5287 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5293 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5298 DIE(aTHX_ PL_no_func, "setgrent");
5304 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5309 DIE(aTHX_ PL_no_func, "endgrent");
5319 if (!(tmps = PerlProc_getlogin()))
5321 PUSHp(tmps, strlen(tmps));
5324 DIE(aTHX_ PL_no_func, "getlogin");
5328 /* Miscellaneous. */
5333 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5334 register I32 items = SP - MARK;
5335 unsigned long a[20];
5340 while (++MARK <= SP) {
5341 if (SvTAINTED(*MARK)) {
5347 TAINT_PROPER("syscall");
5350 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5351 * or where sizeof(long) != sizeof(char*). But such machines will
5352 * not likely have syscall implemented either, so who cares?
5354 while (++MARK <= SP) {
5355 if (SvNIOK(*MARK) || !i)
5356 a[i++] = SvIV(*MARK);
5357 else if (*MARK == &PL_sv_undef)
5360 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5366 DIE(aTHX_ "Too many args to syscall");
5368 DIE(aTHX_ "Too few args to syscall");
5370 retval = syscall(a[0]);
5373 retval = syscall(a[0],a[1]);
5376 retval = syscall(a[0],a[1],a[2]);
5379 retval = syscall(a[0],a[1],a[2],a[3]);
5382 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5385 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5388 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5391 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5395 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5398 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5401 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5405 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5409 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5413 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5414 a[10],a[11],a[12],a[13]);
5416 #endif /* atarist */
5422 DIE(aTHX_ PL_no_func, "syscall");
5426 #ifdef FCNTL_EMULATE_FLOCK
5428 /* XXX Emulate flock() with fcntl().
5429 What's really needed is a good file locking module.
5433 fcntl_emulate_flock(int fd, int operation)
5437 switch (operation & ~LOCK_NB) {
5439 flock.l_type = F_RDLCK;
5442 flock.l_type = F_WRLCK;
5445 flock.l_type = F_UNLCK;
5451 flock.l_whence = SEEK_SET;
5452 flock.l_start = flock.l_len = (Off_t)0;
5454 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5457 #endif /* FCNTL_EMULATE_FLOCK */
5459 #ifdef LOCKF_EMULATE_FLOCK
5461 /* XXX Emulate flock() with lockf(). This is just to increase
5462 portability of scripts. The calls are not completely
5463 interchangeable. What's really needed is a good file
5467 /* The lockf() constants might have been defined in <unistd.h>.
5468 Unfortunately, <unistd.h> causes troubles on some mixed
5469 (BSD/POSIX) systems, such as SunOS 4.1.3.
5471 Further, the lockf() constants aren't POSIX, so they might not be
5472 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5473 just stick in the SVID values and be done with it. Sigh.
5477 # define F_ULOCK 0 /* Unlock a previously locked region */
5480 # define F_LOCK 1 /* Lock a region for exclusive use */
5483 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5486 # define F_TEST 3 /* Test a region for other processes locks */
5490 lockf_emulate_flock(int fd, int operation)
5493 const int save_errno = errno;
5496 /* flock locks entire file so for lockf we need to do the same */
5497 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5498 if (pos > 0) /* is seekable and needs to be repositioned */
5499 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5500 pos = -1; /* seek failed, so don't seek back afterwards */
5503 switch (operation) {
5505 /* LOCK_SH - get a shared lock */
5507 /* LOCK_EX - get an exclusive lock */
5509 i = lockf (fd, F_LOCK, 0);
5512 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5513 case LOCK_SH|LOCK_NB:
5514 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5515 case LOCK_EX|LOCK_NB:
5516 i = lockf (fd, F_TLOCK, 0);
5518 if ((errno == EAGAIN) || (errno == EACCES))
5519 errno = EWOULDBLOCK;
5522 /* LOCK_UN - unlock (non-blocking is a no-op) */
5524 case LOCK_UN|LOCK_NB:
5525 i = lockf (fd, F_ULOCK, 0);
5528 /* Default - can't decipher operation */
5535 if (pos > 0) /* need to restore position of the handle */
5536 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5541 #endif /* LOCKF_EMULATE_FLOCK */
5545 * c-indentation-style: bsd
5547 * indent-tabs-mode: t
5550 * ex: set ts=8 sts=4 sw=4 noet: