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 = Perl_PerlIO_context_layers(aTHX_ NULL);
335 PerlIO_apply_layers(aTHX_ fp,mode,type);
337 if (gimme == G_VOID) {
339 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
342 else if (gimme == G_SCALAR) {
345 PL_rs = &PL_sv_undef;
346 sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */
347 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
355 SV * const sv = newSV(79);
356 if (sv_gets(sv, fp, 0) == NULL) {
360 XPUSHs(sv_2mortal(sv));
361 if (SvLEN(sv) - SvCUR(sv) > 20) {
362 SvPV_shrink_to_cur(sv);
367 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
368 TAINT; /* "I believe that this is not gratuitous!" */
371 STATUS_NATIVE_CHILD_SET(-1);
372 if (gimme == G_SCALAR)
383 tryAMAGICunTARGET(iter, -1);
385 /* Note that we only ever get here if File::Glob fails to load
386 * without at the same time croaking, for some reason, or if
387 * perl was built with PERL_EXTERNAL_GLOB */
394 * The external globbing program may use things we can't control,
395 * so for security reasons we must assume the worst.
398 taint_proper(PL_no_security, "glob");
402 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
403 PL_last_in_gv = (GV*)*PL_stack_sp--;
405 SAVESPTR(PL_rs); /* This is not permanent, either. */
406 PL_rs = sv_2mortal(newSVpvs("\000"));
409 *SvPVX(PL_rs) = '\n';
413 result = do_readline();
421 PL_last_in_gv = cGVOP_gv;
422 return do_readline();
433 do_join(TARG, &PL_sv_no, MARK, SP);
437 else if (SP == MARK) {
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))) {
542 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
544 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 */
581 GV * const gv = (MAXARG == 0) ? PL_defoutgv : (GV*)POPs;
584 IO * const io = GvIO(gv);
586 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
589 XPUSHs(SvTIED_obj((SV*)io, mg));
592 call_method("CLOSE", G_SCALAR);
600 PUSHs(boolSV(do_close(gv, TRUE)));
613 GV * const wgv = (GV*)POPs;
614 GV * const rgv = (GV*)POPs;
619 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
620 DIE(aTHX_ PL_no_usym, "filehandle");
625 do_close(rgv, FALSE);
627 do_close(wgv, FALSE);
629 if (PerlProc_pipe(fd) < 0)
632 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
633 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
634 IoOFP(rstio) = IoIFP(rstio);
635 IoIFP(wstio) = IoOFP(wstio);
636 IoTYPE(rstio) = IoTYPE_RDONLY;
637 IoTYPE(wstio) = IoTYPE_WRONLY;
639 if (!IoIFP(rstio) || !IoOFP(wstio)) {
641 PerlIO_close(IoIFP(rstio));
643 PerlLIO_close(fd[0]);
645 PerlIO_close(IoOFP(wstio));
647 PerlLIO_close(fd[1]);
650 #if defined(HAS_FCNTL) && defined(F_SETFD)
651 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
652 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
659 DIE(aTHX_ PL_no_func, "pipe");
675 if (gv && (io = GvIO(gv))
676 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
679 XPUSHs(SvTIED_obj((SV*)io, mg));
682 call_method("FILENO", G_SCALAR);
688 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
689 /* Can't do this because people seem to do things like
690 defined(fileno($foo)) to check whether $foo is a valid fh.
691 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
692 report_evil_fh(gv, io, PL_op->op_type);
697 PUSHi(PerlIO_fileno(fp));
710 anum = PerlLIO_umask(0);
711 (void)PerlLIO_umask(anum);
714 anum = PerlLIO_umask(POPi);
715 TAINT_PROPER("umask");
718 /* Only DIE if trying to restrict permissions on "user" (self).
719 * Otherwise it's harmless and more useful to just return undef
720 * since 'group' and 'other' concepts probably don't exist here. */
721 if (MAXARG >= 1 && (POPi & 0700))
722 DIE(aTHX_ "umask not implemented");
723 XPUSHs(&PL_sv_undef);
744 if (gv && (io = GvIO(gv))) {
745 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
748 XPUSHs(SvTIED_obj((SV*)io, mg));
753 call_method("BINMODE", G_SCALAR);
761 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
762 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
763 report_evil_fh(gv, io, PL_op->op_type);
764 SETERRNO(EBADF,RMS_IFI);
769 if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
770 (discp) ? SvPV_nolen_const(discp) : NULL)) {
771 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
772 if (!PerlIO_binmode(aTHX_ IoOFP(io),IoTYPE(io),
773 mode_from_discipline(discp),
774 (discp) ? SvPV_nolen_const(discp) : NULL)) {
794 const I32 markoff = MARK - PL_stack_base;
795 const char *methname;
796 int how = PERL_MAGIC_tied;
800 switch(SvTYPE(varsv)) {
802 methname = "TIEHASH";
803 HvEITER_set((HV *)varsv, 0);
806 methname = "TIEARRAY";
809 #ifdef GV_UNIQUE_CHECK
810 if (GvUNIQUE((GV*)varsv)) {
811 Perl_croak(aTHX_ "Attempt to tie unique GV");
814 methname = "TIEHANDLE";
815 how = PERL_MAGIC_tiedscalar;
816 /* For tied filehandles, we apply tiedscalar magic to the IO
817 slot of the GP rather than the GV itself. AMS 20010812 */
819 GvIOp(varsv) = newIO();
820 varsv = (SV *)GvIOp(varsv);
823 methname = "TIESCALAR";
824 how = PERL_MAGIC_tiedscalar;
828 if (sv_isobject(*MARK)) {
830 PUSHSTACKi(PERLSI_MAGIC);
832 EXTEND(SP,(I32)items);
836 call_method(methname, G_SCALAR);
839 /* Not clear why we don't call call_method here too.
840 * perhaps to get different error message ?
842 stash = gv_stashsv(*MARK, FALSE);
843 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
844 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
845 methname, (void*)*MARK);
848 PUSHSTACKi(PERLSI_MAGIC);
850 EXTEND(SP,(I32)items);
854 call_sv((SV*)GvCV(gv), G_SCALAR);
860 if (sv_isobject(sv)) {
861 sv_unmagic(varsv, how);
862 /* Croak if a self-tie on an aggregate is attempted. */
863 if (varsv == SvRV(sv) &&
864 (SvTYPE(varsv) == SVt_PVAV ||
865 SvTYPE(varsv) == SVt_PVHV))
867 "Self-ties of arrays and hashes are not supported");
868 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
871 SP = PL_stack_base + markoff;
881 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
882 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
884 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
887 if ((mg = SvTIED_mg(sv, how))) {
888 SV * const obj = SvRV(SvTIED_obj(sv, mg));
890 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
892 if (gv && isGV(gv) && (cv = GvCV(gv))) {
894 XPUSHs(SvTIED_obj((SV*)gv, mg));
895 XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
898 call_sv((SV *)cv, G_VOID);
902 else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
903 Perl_warner(aTHX_ packWARN(WARN_UNTIE),
904 "untie attempted while %"UVuf" inner references still exist",
905 (UV)SvREFCNT(obj) - 1 ) ;
909 sv_unmagic(sv, how) ;
919 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
920 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
922 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
925 if ((mg = SvTIED_mg(sv, how))) {
926 SV *osv = SvTIED_obj(sv, mg);
927 if (osv == mg->mg_obj)
928 osv = sv_mortalcopy(osv);
942 HV * const hv = (HV*)POPs;
943 SV * const sv = sv_2mortal(newSVpvs("AnyDBM_File"));
944 stash = gv_stashsv(sv, FALSE);
945 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
947 require_pv("AnyDBM_File.pm");
949 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
950 DIE(aTHX_ "No dbm on this machine");
960 PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
962 PUSHs(sv_2mortal(newSVuv(O_RDWR)));
965 call_sv((SV*)GvCV(gv), G_SCALAR);
968 if (!sv_isobject(TOPs)) {
973 PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
976 call_sv((SV*)GvCV(gv), G_SCALAR);
980 if (sv_isobject(TOPs)) {
981 sv_unmagic((SV *) hv, PERL_MAGIC_tied);
982 sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, NULL, 0);
999 struct timeval timebuf;
1000 struct timeval *tbuf = &timebuf;
1003 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1008 # if BYTEORDER & 0xf0000
1009 # define ORDERBYTE (0x88888888 - BYTEORDER)
1011 # define ORDERBYTE (0x4444 - BYTEORDER)
1017 for (i = 1; i <= 3; i++) {
1018 SV * const sv = SP[i];
1021 if (SvREADONLY(sv)) {
1023 sv_force_normal_flags(sv, 0);
1024 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1025 DIE(aTHX_ PL_no_modify);
1028 if (ckWARN(WARN_MISC))
1029 Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1030 SvPV_force_nolen(sv); /* force string conversion */
1037 /* little endians can use vecs directly */
1038 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1045 masksize = NFDBITS / NBBY;
1047 masksize = sizeof(long); /* documented int, everyone seems to use long */
1049 Zero(&fd_sets[0], 4, char*);
1052 # if SELECT_MIN_BITS == 1
1053 growsize = sizeof(fd_set);
1055 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1056 # undef SELECT_MIN_BITS
1057 # define SELECT_MIN_BITS __FD_SETSIZE
1059 /* If SELECT_MIN_BITS is greater than one we most probably will want
1060 * to align the sizes with SELECT_MIN_BITS/8 because for example
1061 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1062 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1063 * on (sets/tests/clears bits) is 32 bits. */
1064 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1072 timebuf.tv_sec = (long)value;
1073 value -= (NV)timebuf.tv_sec;
1074 timebuf.tv_usec = (long)(value * 1000000.0);
1079 for (i = 1; i <= 3; i++) {
1081 if (!SvOK(sv) || SvCUR(sv) == 0) {
1088 Sv_Grow(sv, growsize);
1092 while (++j <= growsize) {
1096 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1098 Newx(fd_sets[i], growsize, char);
1099 for (offset = 0; offset < growsize; offset += masksize) {
1100 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1101 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1104 fd_sets[i] = SvPVX(sv);
1108 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1109 /* Can't make just the (void*) conditional because that would be
1110 * cpp #if within cpp macro, and not all compilers like that. */
1111 nfound = PerlSock_select(
1113 (Select_fd_set_t) fd_sets[1],
1114 (Select_fd_set_t) fd_sets[2],
1115 (Select_fd_set_t) fd_sets[3],
1116 (void*) tbuf); /* Workaround for compiler bug. */
1118 nfound = PerlSock_select(
1120 (Select_fd_set_t) fd_sets[1],
1121 (Select_fd_set_t) fd_sets[2],
1122 (Select_fd_set_t) fd_sets[3],
1125 for (i = 1; i <= 3; i++) {
1128 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1130 for (offset = 0; offset < growsize; offset += masksize) {
1131 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1132 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1134 Safefree(fd_sets[i]);
1141 if (GIMME == G_ARRAY && tbuf) {
1142 value = (NV)(timebuf.tv_sec) +
1143 (NV)(timebuf.tv_usec) / 1000000.0;
1144 PUSHs(sv_2mortal(newSVnv(value)));
1148 DIE(aTHX_ "select not implemented");
1153 Perl_setdefout(pTHX_ GV *gv)
1156 SvREFCNT_inc_simple_void(gv);
1158 SvREFCNT_dec(PL_defoutgv);
1166 GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : NULL;
1167 GV * egv = GvEGV(PL_defoutgv);
1173 XPUSHs(&PL_sv_undef);
1175 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1176 if (gvp && *gvp == egv) {
1177 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1181 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1186 if (!GvIO(newdefout))
1187 gv_IOadd(newdefout);
1188 setdefout(newdefout);
1198 GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs;
1200 if (gv && (io = GvIO(gv))) {
1201 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1203 const I32 gimme = GIMME_V;
1205 XPUSHs(SvTIED_obj((SV*)io, mg));
1208 call_method("GETC", gimme);
1211 if (gimme == G_SCALAR)
1212 SvSetMagicSV_nosteal(TARG, TOPs);
1216 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1217 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1218 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1219 report_evil_fh(gv, io, PL_op->op_type);
1220 SETERRNO(EBADF,RMS_IFI);
1224 sv_setpvn(TARG, " ", 1);
1225 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1226 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1227 /* Find out how many bytes the char needs */
1228 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1231 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1232 SvCUR_set(TARG,1+len);
1241 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1244 register PERL_CONTEXT *cx;
1245 const I32 gimme = GIMME_V;
1250 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1252 cx->blk_sub.retop = retop;
1254 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1256 setdefout(gv); /* locally select filehandle so $% et al work */
1287 goto not_a_format_reference;
1291 SV * const tmpsv = sv_newmortal();
1293 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1294 name = SvPV_nolen_const(tmpsv);
1296 DIE(aTHX_ "Undefined format \"%s\" called", name);
1298 not_a_format_reference:
1299 DIE(aTHX_ "Not a format reference");
1302 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1304 IoFLAGS(io) &= ~IOf_DIDTOP;
1305 return doform(cv,gv,PL_op->op_next);
1311 GV * const gv = cxstack[cxstack_ix].blk_sub.gv;
1312 register IO * const io = GvIOp(gv);
1317 register PERL_CONTEXT *cx;
1319 if (!io || !(ofp = IoOFP(io)))
1322 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1323 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1325 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1326 PL_formtarget != PL_toptarget)
1330 if (!IoTOP_GV(io)) {
1333 if (!IoTOP_NAME(io)) {
1335 if (!IoFMT_NAME(io))
1336 IoFMT_NAME(io) = savepv(GvNAME(gv));
1337 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1338 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1339 if ((topgv && GvFORM(topgv)) ||
1340 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1341 IoTOP_NAME(io) = savesvpv(topname);
1343 IoTOP_NAME(io) = savepvs("top");
1345 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1346 if (!topgv || !GvFORM(topgv)) {
1347 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1350 IoTOP_GV(io) = topgv;
1352 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1353 I32 lines = IoLINES_LEFT(io);
1354 const char *s = SvPVX_const(PL_formtarget);
1355 if (lines <= 0) /* Yow, header didn't even fit!!! */
1357 while (lines-- > 0) {
1358 s = strchr(s, '\n');
1364 const STRLEN save = SvCUR(PL_formtarget);
1365 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1366 do_print(PL_formtarget, ofp);
1367 SvCUR_set(PL_formtarget, save);
1368 sv_chop(PL_formtarget, s);
1369 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1372 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1373 do_print(PL_formfeed, ofp);
1374 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1376 PL_formtarget = PL_toptarget;
1377 IoFLAGS(io) |= IOf_DIDTOP;
1380 DIE(aTHX_ "bad top format reference");
1383 SV * const sv = sv_newmortal();
1385 gv_efullname4(sv, fgv, NULL, FALSE);
1386 name = SvPV_nolen_const(sv);
1388 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1390 DIE(aTHX_ "Undefined top format called");
1392 if (cv && CvCLONE(cv))
1393 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1394 return doform(cv, gv, PL_op);
1398 POPBLOCK(cx,PL_curpm);
1404 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1406 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1407 else if (ckWARN(WARN_CLOSED))
1408 report_evil_fh(gv, io, PL_op->op_type);
1413 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1414 if (ckWARN(WARN_IO))
1415 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1417 if (!do_print(PL_formtarget, fp))
1420 FmLINES(PL_formtarget) = 0;
1421 SvCUR_set(PL_formtarget, 0);
1422 *SvEND(PL_formtarget) = '\0';
1423 if (IoFLAGS(io) & IOf_FLUSH)
1424 (void)PerlIO_flush(fp);
1429 PL_formtarget = PL_bodytarget;
1431 PERL_UNUSED_VAR(newsp);
1432 PERL_UNUSED_VAR(gimme);
1433 return cx->blk_sub.retop;
1438 dVAR; dSP; dMARK; dORIGMARK;
1443 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
1445 if (gv && (io = GvIO(gv))) {
1446 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1448 if (MARK == ORIGMARK) {
1451 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1455 *MARK = SvTIED_obj((SV*)io, mg);
1458 call_method("PRINTF", G_SCALAR);
1461 MARK = ORIGMARK + 1;
1469 if (!(io = GvIO(gv))) {
1470 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1471 report_evil_fh(gv, io, PL_op->op_type);
1472 SETERRNO(EBADF,RMS_IFI);
1475 else if (!(fp = IoOFP(io))) {
1476 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1478 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1479 else if (ckWARN(WARN_CLOSED))
1480 report_evil_fh(gv, io, PL_op->op_type);
1482 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1486 do_sprintf(sv, SP - MARK, MARK + 1);
1487 if (!do_print(sv, fp))
1490 if (IoFLAGS(io) & IOf_FLUSH)
1491 if (PerlIO_flush(fp) == EOF)
1502 PUSHs(&PL_sv_undef);
1510 const int perm = (MAXARG > 3) ? POPi : 0666;
1511 const int mode = POPi;
1512 SV * const sv = POPs;
1513 GV * const gv = (GV *)POPs;
1516 /* Need TIEHANDLE method ? */
1517 const char * const tmps = SvPV_const(sv, len);
1518 /* FIXME? do_open should do const */
1519 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1520 IoLINES(GvIOp(gv)) = 0;
1524 PUSHs(&PL_sv_undef);
1531 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1537 Sock_size_t bufsize;
1545 bool charstart = FALSE;
1546 STRLEN charskip = 0;
1549 GV * const gv = (GV*)*++MARK;
1550 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1551 && gv && (io = GvIO(gv)) )
1553 const MAGIC * mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1557 *MARK = SvTIED_obj((SV*)io, mg);
1559 call_method("READ", G_SCALAR);
1573 sv_setpvn(bufsv, "", 0);
1574 length = SvIVx(*++MARK);
1577 offset = SvIVx(*++MARK);
1581 if (!io || !IoIFP(io)) {
1582 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1583 report_evil_fh(gv, io, PL_op->op_type);
1584 SETERRNO(EBADF,RMS_IFI);
1587 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1588 buffer = SvPVutf8_force(bufsv, blen);
1589 /* UTF-8 may not have been set if they are all low bytes */
1594 buffer = SvPV_force(bufsv, blen);
1595 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1598 DIE(aTHX_ "Negative length");
1606 if (PL_op->op_type == OP_RECV) {
1607 char namebuf[MAXPATHLEN];
1608 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1609 bufsize = sizeof (struct sockaddr_in);
1611 bufsize = sizeof namebuf;
1613 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1617 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1618 /* 'offset' means 'flags' here */
1619 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1620 (struct sockaddr *)namebuf, &bufsize);
1624 /* Bogus return without padding */
1625 bufsize = sizeof (struct sockaddr_in);
1627 SvCUR_set(bufsv, count);
1628 *SvEND(bufsv) = '\0';
1629 (void)SvPOK_only(bufsv);
1633 /* This should not be marked tainted if the fp is marked clean */
1634 if (!(IoFLAGS(io) & IOf_UNTAINT))
1635 SvTAINTED_on(bufsv);
1637 sv_setpvn(TARG, namebuf, bufsize);
1642 if (PL_op->op_type == OP_RECV)
1643 DIE(aTHX_ PL_no_sock_func, "recv");
1645 if (DO_UTF8(bufsv)) {
1646 /* offset adjust in characters not bytes */
1647 blen = sv_len_utf8(bufsv);
1650 if (-offset > (int)blen)
1651 DIE(aTHX_ "Offset outside string");
1654 if (DO_UTF8(bufsv)) {
1655 /* convert offset-as-chars to offset-as-bytes */
1656 if (offset >= (int)blen)
1657 offset += SvCUR(bufsv) - blen;
1659 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1662 bufsize = SvCUR(bufsv);
1663 /* Allocating length + offset + 1 isn't perfect in the case of reading
1664 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1666 (should be 2 * length + offset + 1, or possibly something longer if
1667 PL_encoding is true) */
1668 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1669 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1670 Zero(buffer+bufsize, offset-bufsize, char);
1672 buffer = buffer + offset;
1674 read_target = bufsv;
1676 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1677 concatenate it to the current buffer. */
1679 /* Truncate the existing buffer to the start of where we will be
1681 SvCUR_set(bufsv, offset);
1683 read_target = sv_newmortal();
1684 SvUPGRADE(read_target, SVt_PV);
1685 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1688 if (PL_op->op_type == OP_SYSREAD) {
1689 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1690 if (IoTYPE(io) == IoTYPE_SOCKET) {
1691 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1697 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1702 #ifdef HAS_SOCKET__bad_code_maybe
1703 if (IoTYPE(io) == IoTYPE_SOCKET) {
1704 char namebuf[MAXPATHLEN];
1705 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1706 bufsize = sizeof (struct sockaddr_in);
1708 bufsize = sizeof namebuf;
1710 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1711 (struct sockaddr *)namebuf, &bufsize);
1716 count = PerlIO_read(IoIFP(io), buffer, length);
1717 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1718 if (count == 0 && PerlIO_error(IoIFP(io)))
1722 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1723 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1726 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1727 *SvEND(read_target) = '\0';
1728 (void)SvPOK_only(read_target);
1729 if (fp_utf8 && !IN_BYTES) {
1730 /* Look at utf8 we got back and count the characters */
1731 const char *bend = buffer + count;
1732 while (buffer < bend) {
1734 skip = UTF8SKIP(buffer);
1737 if (buffer - charskip + skip > bend) {
1738 /* partial character - try for rest of it */
1739 length = skip - (bend-buffer);
1740 offset = bend - SvPVX_const(bufsv);
1752 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1753 provided amount read (count) was what was requested (length)
1755 if (got < wanted && count == length) {
1756 length = wanted - got;
1757 offset = bend - SvPVX_const(bufsv);
1760 /* return value is character count */
1764 else if (buffer_utf8) {
1765 /* Let svcatsv upgrade the bytes we read in to utf8.
1766 The buffer is a mortal so will be freed soon. */
1767 sv_catsv_nomg(bufsv, read_target);
1770 /* This should not be marked tainted if the fp is marked clean */
1771 if (!(IoFLAGS(io) & IOf_UNTAINT))
1772 SvTAINTED_on(bufsv);
1784 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1790 STRLEN orig_blen_bytes;
1791 const int op_type = PL_op->op_type;
1795 GV *const gv = (GV*)*++MARK;
1796 if (PL_op->op_type == OP_SYSWRITE
1797 && gv && (io = GvIO(gv))) {
1798 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1802 if (MARK == SP - 1) {
1804 sv = sv_2mortal(newSViv(sv_len(*SP)));
1810 *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg);
1812 call_method("WRITE", G_SCALAR);
1828 if (!io || !IoIFP(io)) {
1830 if (ckWARN(WARN_CLOSED))
1831 report_evil_fh(gv, io, PL_op->op_type);
1832 SETERRNO(EBADF,RMS_IFI);
1836 /* Do this first to trigger any overloading. */
1837 buffer = SvPV_const(bufsv, blen);
1838 orig_blen_bytes = blen;
1839 doing_utf8 = DO_UTF8(bufsv);
1841 if (PerlIO_isutf8(IoIFP(io))) {
1842 if (!SvUTF8(bufsv)) {
1843 /* We don't modify the original scalar. */
1844 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1845 buffer = (char *) tmpbuf;
1849 else if (doing_utf8) {
1850 STRLEN tmplen = blen;
1851 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1854 buffer = (char *) tmpbuf;
1858 assert((char *)result == buffer);
1859 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1863 if (op_type == OP_SYSWRITE) {
1864 Size_t length = 0; /* This length is in characters. */
1870 /* The SV is bytes, and we've had to upgrade it. */
1871 blen_chars = orig_blen_bytes;
1873 /* The SV really is UTF-8. */
1874 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1875 /* Don't call sv_len_utf8 again because it will call magic
1876 or overloading a second time, and we might get back a
1877 different result. */
1878 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1880 /* It's safe, and it may well be cached. */
1881 blen_chars = sv_len_utf8(bufsv);
1889 length = blen_chars;
1891 #if Size_t_size > IVSIZE
1892 length = (Size_t)SvNVx(*++MARK);
1894 length = (Size_t)SvIVx(*++MARK);
1896 if ((SSize_t)length < 0) {
1898 DIE(aTHX_ "Negative length");
1903 offset = SvIVx(*++MARK);
1905 if (-offset > (IV)blen_chars) {
1907 DIE(aTHX_ "Offset outside string");
1909 offset += blen_chars;
1910 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1912 DIE(aTHX_ "Offset outside string");
1916 if (length > blen_chars - offset)
1917 length = blen_chars - offset;
1919 /* Here we convert length from characters to bytes. */
1920 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1921 /* Either we had to convert the SV, or the SV is magical, or
1922 the SV has overloading, in which case we can't or mustn't
1923 or mustn't call it again. */
1925 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1926 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1928 /* It's a real UTF-8 SV, and it's not going to change under
1929 us. Take advantage of any cache. */
1931 I32 len_I32 = length;
1933 /* Convert the start and end character positions to bytes.
1934 Remember that the second argument to sv_pos_u2b is relative
1936 sv_pos_u2b(bufsv, &start, &len_I32);
1943 buffer = buffer+offset;
1945 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1946 if (IoTYPE(io) == IoTYPE_SOCKET) {
1947 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1953 /* See the note at doio.c:do_print about filesize limits. --jhi */
1954 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1960 const int flags = SvIVx(*++MARK);
1963 char * const sockbuf = SvPVx(*++MARK, mlen);
1964 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1965 flags, (struct sockaddr *)sockbuf, mlen);
1969 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1974 DIE(aTHX_ PL_no_sock_func, "send");
1981 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
1984 #if Size_t_size > IVSIZE
2003 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
2005 gv = PL_last_in_gv = GvEGV(PL_argvgv);
2007 if (io && !IoIFP(io)) {
2008 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2010 IoFLAGS(io) &= ~IOf_START;
2011 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2012 sv_setpvn(GvSV(gv), "-", 1);
2013 SvSETMAGIC(GvSV(gv));
2015 else if (!nextargv(gv))
2020 gv = PL_last_in_gv; /* eof */
2023 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
2026 IO * const io = GvIO(gv);
2028 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
2030 XPUSHs(SvTIED_obj((SV*)io, mg));
2033 call_method("EOF", G_SCALAR);
2040 PUSHs(boolSV(!gv || do_eof(gv)));
2051 PL_last_in_gv = (GV*)POPs;
2054 if (gv && (io = GvIO(gv))) {
2055 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2058 XPUSHs(SvTIED_obj((SV*)io, mg));
2061 call_method("TELL", G_SCALAR);
2068 #if LSEEKSIZE > IVSIZE
2069 PUSHn( do_tell(gv) );
2071 PUSHi( do_tell(gv) );
2079 const int whence = POPi;
2080 #if LSEEKSIZE > IVSIZE
2081 const Off_t offset = (Off_t)SvNVx(POPs);
2083 const Off_t offset = (Off_t)SvIVx(POPs);
2086 GV * const gv = PL_last_in_gv = (GV*)POPs;
2089 if (gv && (io = GvIO(gv))) {
2090 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2093 XPUSHs(SvTIED_obj((SV*)io, mg));
2094 #if LSEEKSIZE > IVSIZE
2095 XPUSHs(sv_2mortal(newSVnv((NV) offset)));
2097 XPUSHs(sv_2mortal(newSViv(offset)));
2099 XPUSHs(sv_2mortal(newSViv(whence)));
2102 call_method("SEEK", G_SCALAR);
2109 if (PL_op->op_type == OP_SEEK)
2110 PUSHs(boolSV(do_seek(gv, offset, whence)));
2112 const Off_t sought = do_sysseek(gv, offset, whence);
2114 PUSHs(&PL_sv_undef);
2116 SV* const sv = sought ?
2117 #if LSEEKSIZE > IVSIZE
2122 : newSVpvn(zero_but_true, ZBTLEN);
2123 PUSHs(sv_2mortal(sv));
2133 /* There seems to be no consensus on the length type of truncate()
2134 * and ftruncate(), both off_t and size_t have supporters. In
2135 * general one would think that when using large files, off_t is
2136 * at least as wide as size_t, so using an off_t should be okay. */
2137 /* XXX Configure probe for the length type of *truncate() needed XXX */
2140 #if Off_t_size > IVSIZE
2145 /* Checking for length < 0 is problematic as the type might or
2146 * might not be signed: if it is not, clever compilers will moan. */
2147 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2154 if (PL_op->op_flags & OPf_SPECIAL) {
2155 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2164 TAINT_PROPER("truncate");
2165 if (!(fp = IoIFP(io))) {
2171 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2173 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2180 SV * const sv = POPs;
2183 if (SvTYPE(sv) == SVt_PVGV) {
2184 tmpgv = (GV*)sv; /* *main::FRED for example */
2185 goto do_ftruncate_gv;
2187 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2188 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
2189 goto do_ftruncate_gv;
2191 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2192 io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
2193 goto do_ftruncate_io;
2196 name = SvPV_nolen_const(sv);
2197 TAINT_PROPER("truncate");
2199 if (truncate(name, len) < 0)
2203 const int tmpfd = PerlLIO_open(name, O_RDWR);
2208 if (my_chsize(tmpfd, len) < 0)
2210 PerlLIO_close(tmpfd);
2219 SETERRNO(EBADF,RMS_IFI);
2227 SV * const argsv = POPs;
2228 const unsigned int func = POPu;
2229 const int optype = PL_op->op_type;
2230 GV * const gv = (GV*)POPs;
2231 IO * const io = gv ? GvIOn(gv) : NULL;
2235 if (!io || !argsv || !IoIFP(io)) {
2236 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2237 report_evil_fh(gv, io, PL_op->op_type);
2238 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2242 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2245 s = SvPV_force(argsv, len);
2246 need = IOCPARM_LEN(func);
2248 s = Sv_Grow(argsv, need + 1);
2249 SvCUR_set(argsv, need);
2252 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2255 retval = SvIV(argsv);
2256 s = INT2PTR(char*,retval); /* ouch */
2259 TAINT_PROPER(PL_op_desc[optype]);
2261 if (optype == OP_IOCTL)
2263 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2265 DIE(aTHX_ "ioctl is not implemented");
2269 DIE(aTHX_ "fcntl is not implemented");
2271 #if defined(OS2) && defined(__EMX__)
2272 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2274 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2278 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2280 if (s[SvCUR(argsv)] != 17)
2281 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2283 s[SvCUR(argsv)] = 0; /* put our null back */
2284 SvSETMAGIC(argsv); /* Assume it has changed */
2293 PUSHp(zero_but_true, ZBTLEN);
2306 const int argtype = POPi;
2307 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
2309 if (gv && (io = GvIO(gv)))
2315 /* XXX Looks to me like io is always NULL at this point */
2317 (void)PerlIO_flush(fp);
2318 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2321 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2322 report_evil_fh(gv, io, PL_op->op_type);
2324 SETERRNO(EBADF,RMS_IFI);
2329 DIE(aTHX_ PL_no_func, "flock()");
2339 const int protocol = POPi;
2340 const int type = POPi;
2341 const int domain = POPi;
2342 GV * const gv = (GV*)POPs;
2343 register IO * const io = gv ? GvIOn(gv) : NULL;
2347 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2348 report_evil_fh(gv, io, PL_op->op_type);
2349 if (io && IoIFP(io))
2350 do_close(gv, FALSE);
2351 SETERRNO(EBADF,LIB_INVARG);
2356 do_close(gv, FALSE);
2358 TAINT_PROPER("socket");
2359 fd = PerlSock_socket(domain, type, protocol);
2362 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2363 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2364 IoTYPE(io) = IoTYPE_SOCKET;
2365 if (!IoIFP(io) || !IoOFP(io)) {
2366 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2367 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2368 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2371 #if defined(HAS_FCNTL) && defined(F_SETFD)
2372 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2376 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2381 DIE(aTHX_ PL_no_sock_func, "socket");
2387 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2389 const int protocol = POPi;
2390 const int type = POPi;
2391 const int domain = POPi;
2392 GV * const gv2 = (GV*)POPs;
2393 GV * const gv1 = (GV*)POPs;
2394 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2395 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2398 if (!gv1 || !gv2 || !io1 || !io2) {
2399 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2401 report_evil_fh(gv1, io1, PL_op->op_type);
2403 report_evil_fh(gv1, io2, PL_op->op_type);
2405 if (io1 && IoIFP(io1))
2406 do_close(gv1, FALSE);
2407 if (io2 && IoIFP(io2))
2408 do_close(gv2, FALSE);
2413 do_close(gv1, FALSE);
2415 do_close(gv2, FALSE);
2417 TAINT_PROPER("socketpair");
2418 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2420 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2421 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2422 IoTYPE(io1) = IoTYPE_SOCKET;
2423 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2424 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2425 IoTYPE(io2) = IoTYPE_SOCKET;
2426 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2427 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2428 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2429 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2430 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2431 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2432 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2435 #if defined(HAS_FCNTL) && defined(F_SETFD)
2436 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2437 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2442 DIE(aTHX_ PL_no_sock_func, "socketpair");
2450 SV * const addrsv = POPs;
2451 /* OK, so on what platform does bind modify addr? */
2453 GV * const gv = (GV*)POPs;
2454 register IO * const io = GvIOn(gv);
2457 if (!io || !IoIFP(io))
2460 addr = SvPV_const(addrsv, len);
2461 TAINT_PROPER("bind");
2462 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (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);
2562 /* Some platforms indicate zero length when an AF_UNIX client is
2563 * not bound. Simulate a non-zero-length sockaddr structure in
2565 namebuf[0] = 0; /* sun_len */
2566 namebuf[1] = AF_UNIX; /* sun_family */
2574 do_close(ngv, FALSE);
2575 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2576 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2577 IoTYPE(nstio) = IoTYPE_SOCKET;
2578 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2579 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2580 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2581 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2584 #if defined(HAS_FCNTL) && defined(F_SETFD)
2585 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2589 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2590 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2592 #ifdef __SCO_VERSION__
2593 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2596 PUSHp(namebuf, len);
2600 if (ckWARN(WARN_CLOSED))
2601 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2602 SETERRNO(EBADF,SS_IVCHAN);
2608 DIE(aTHX_ PL_no_sock_func, "accept");
2616 const int how = POPi;
2617 GV * const gv = (GV*)POPs;
2618 register IO * const io = GvIOn(gv);
2620 if (!io || !IoIFP(io))
2623 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2627 if (ckWARN(WARN_CLOSED))
2628 report_evil_fh(gv, io, PL_op->op_type);
2629 SETERRNO(EBADF,SS_IVCHAN);
2632 DIE(aTHX_ PL_no_sock_func, "shutdown");
2640 const int optype = PL_op->op_type;
2641 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2642 const unsigned int optname = (unsigned int) POPi;
2643 const unsigned int lvl = (unsigned int) POPi;
2644 GV * const gv = (GV*)POPs;
2645 register IO * const io = GvIOn(gv);
2649 if (!io || !IoIFP(io))
2652 fd = PerlIO_fileno(IoIFP(io));
2656 (void)SvPOK_only(sv);
2660 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2667 #if defined(__SYMBIAN32__)
2668 # define SETSOCKOPT_OPTION_VALUE_T void *
2670 # define SETSOCKOPT_OPTION_VALUE_T const char *
2672 /* XXX TODO: We need to have a proper type (a Configure probe,
2673 * etc.) for what the C headers think of the third argument of
2674 * setsockopt(), the option_value read-only buffer: is it
2675 * a "char *", or a "void *", const or not. Some compilers
2676 * don't take kindly to e.g. assuming that "char *" implicitly
2677 * promotes to a "void *", or to explicitly promoting/demoting
2678 * consts to non/vice versa. The "const void *" is the SUS
2679 * definition, but that does not fly everywhere for the above
2681 SETSOCKOPT_OPTION_VALUE_T buf;
2685 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2689 aint = (int)SvIV(sv);
2690 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2693 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2702 if (ckWARN(WARN_CLOSED))
2703 report_evil_fh(gv, io, optype);
2704 SETERRNO(EBADF,SS_IVCHAN);
2709 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2717 const int optype = PL_op->op_type;
2718 GV * const gv = (GV*)POPs;
2719 register IO * const io = GvIOn(gv);
2724 if (!io || !IoIFP(io))
2727 sv = sv_2mortal(newSV(257));
2728 (void)SvPOK_only(sv);
2732 fd = PerlIO_fileno(IoIFP(io));
2734 case OP_GETSOCKNAME:
2735 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2738 case OP_GETPEERNAME:
2739 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2741 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2743 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";
2744 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2745 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2746 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2747 sizeof(u_short) + sizeof(struct in_addr))) {
2754 #ifdef BOGUS_GETNAME_RETURN
2755 /* Interactive Unix, getpeername() and getsockname()
2756 does not return valid namelen */
2757 if (len == BOGUS_GETNAME_RETURN)
2758 len = sizeof(struct sockaddr);
2766 if (ckWARN(WARN_CLOSED))
2767 report_evil_fh(gv, io, optype);
2768 SETERRNO(EBADF,SS_IVCHAN);
2773 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2788 if (PL_op->op_flags & OPf_REF) {
2790 if (PL_op->op_type == OP_LSTAT) {
2791 if (gv != PL_defgv) {
2792 do_fstat_warning_check:
2793 if (ckWARN(WARN_IO))
2794 Perl_warner(aTHX_ packWARN(WARN_IO),
2795 "lstat() on filehandle %s", GvENAME(gv));
2796 } else if (PL_laststype != OP_LSTAT)
2797 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2801 if (gv != PL_defgv) {
2802 PL_laststype = OP_STAT;
2804 sv_setpvn(PL_statname, "", 0);
2811 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2812 } else if (IoDIRP(io)) {
2815 PerlLIO_fstat(dirfd(IoDIRP(io)), &PL_statcache);
2817 DIE(aTHX_ PL_no_func, "dirfd");
2820 PL_laststatval = -1;
2826 if (PL_laststatval < 0) {
2827 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2828 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2833 SV* const sv = POPs;
2834 if (SvTYPE(sv) == SVt_PVGV) {
2837 } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2839 if (PL_op->op_type == OP_LSTAT)
2840 goto do_fstat_warning_check;
2842 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2844 if (PL_op->op_type == OP_LSTAT)
2845 goto do_fstat_warning_check;
2846 goto do_fstat_have_io;
2849 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2851 PL_laststype = PL_op->op_type;
2852 if (PL_op->op_type == OP_LSTAT)
2853 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2855 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2856 if (PL_laststatval < 0) {
2857 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2858 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2864 if (gimme != G_ARRAY) {
2865 if (gimme != G_VOID)
2866 XPUSHs(boolSV(max));
2872 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2873 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2874 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2875 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2876 #if Uid_t_size > IVSIZE
2877 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2879 # if Uid_t_sign <= 0
2880 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2882 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2885 #if Gid_t_size > IVSIZE
2886 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2888 # if Gid_t_sign <= 0
2889 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2891 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2894 #ifdef USE_STAT_RDEV
2895 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2897 PUSHs(sv_2mortal(newSVpvs("")));
2899 #if Off_t_size > IVSIZE
2900 PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
2902 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2905 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2906 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2907 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2909 PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2910 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2911 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
2913 #ifdef USE_STAT_BLOCKS
2914 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2915 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2917 PUSHs(sv_2mortal(newSVpvs("")));
2918 PUSHs(sv_2mortal(newSVpvs("")));
2924 /* This macro is used by the stacked filetest operators :
2925 * if the previous filetest failed, short-circuit and pass its value.
2926 * Else, discard it from the stack and continue. --rgs
2928 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2929 if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
2930 else { (void)POPs; PUTBACK; } \
2937 /* Not const, because things tweak this below. Not bool, because there's
2938 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2939 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2940 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2941 /* Giving some sort of initial value silences compilers. */
2943 int access_mode = R_OK;
2945 int access_mode = 0;
2948 /* access_mode is never used, but leaving use_access in makes the
2949 conditional compiling below much clearer. */
2952 int stat_mode = S_IRUSR;
2954 bool effective = FALSE;
2957 STACKED_FTEST_CHECK;
2959 switch (PL_op->op_type) {
2961 #if !(defined(HAS_ACCESS) && defined(R_OK))
2967 #if defined(HAS_ACCESS) && defined(W_OK)
2972 stat_mode = S_IWUSR;
2976 #if defined(HAS_ACCESS) && defined(X_OK)
2981 stat_mode = S_IXUSR;
2985 #ifdef PERL_EFF_ACCESS
2988 stat_mode = S_IWUSR;
2992 #ifndef PERL_EFF_ACCESS
3000 #ifdef PERL_EFF_ACCESS
3005 stat_mode = S_IXUSR;
3011 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3012 const char *const name = POPpx;
3014 # ifdef PERL_EFF_ACCESS
3015 result = PERL_EFF_ACCESS(name, access_mode);
3017 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3023 result = access(name, access_mode);
3025 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3040 if (cando(stat_mode, effective, &PL_statcache))
3049 const int op_type = PL_op->op_type;
3051 STACKED_FTEST_CHECK;
3056 if (op_type == OP_FTIS)
3059 /* You can't dTARGET inside OP_FTIS, because you'll get
3060 "panic: pad_sv po" - the op is not flagged to have a target. */
3064 #if Off_t_size > IVSIZE
3065 PUSHn(PL_statcache.st_size);
3067 PUSHi(PL_statcache.st_size);
3071 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3074 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3077 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3090 /* I believe that all these three are likely to be defined on most every
3091 system these days. */
3093 if(PL_op->op_type == OP_FTSUID)
3097 if(PL_op->op_type == OP_FTSGID)
3101 if(PL_op->op_type == OP_FTSVTX)
3105 STACKED_FTEST_CHECK;
3110 switch (PL_op->op_type) {
3112 if (PL_statcache.st_uid == PL_uid)
3116 if (PL_statcache.st_uid == PL_euid)
3120 if (PL_statcache.st_size == 0)
3124 if (S_ISSOCK(PL_statcache.st_mode))
3128 if (S_ISCHR(PL_statcache.st_mode))
3132 if (S_ISBLK(PL_statcache.st_mode))
3136 if (S_ISREG(PL_statcache.st_mode))
3140 if (S_ISDIR(PL_statcache.st_mode))
3144 if (S_ISFIFO(PL_statcache.st_mode))
3149 if (PL_statcache.st_mode & S_ISUID)
3155 if (PL_statcache.st_mode & S_ISGID)
3161 if (PL_statcache.st_mode & S_ISVTX)
3172 I32 result = my_lstat();
3176 if (S_ISLNK(PL_statcache.st_mode))
3189 STACKED_FTEST_CHECK;
3191 if (PL_op->op_flags & OPf_REF)
3193 else if (isGV(TOPs))
3195 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3196 gv = (GV*)SvRV(POPs);
3198 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3200 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3201 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3202 else if (tmpsv && SvOK(tmpsv)) {
3203 const char *tmps = SvPV_nolen_const(tmpsv);
3211 if (PerlLIO_isatty(fd))
3216 #if defined(atarist) /* this will work with atariST. Configure will
3217 make guesses for other systems. */
3218 # define FILE_base(f) ((f)->_base)
3219 # define FILE_ptr(f) ((f)->_ptr)
3220 # define FILE_cnt(f) ((f)->_cnt)
3221 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3232 register STDCHAR *s;
3238 STACKED_FTEST_CHECK;
3240 if (PL_op->op_flags & OPf_REF)
3242 else if (isGV(TOPs))
3244 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3245 gv = (GV*)SvRV(POPs);
3251 if (gv == PL_defgv) {
3253 io = GvIO(PL_statgv);
3256 goto really_filename;
3261 PL_laststatval = -1;
3262 sv_setpvn(PL_statname, "", 0);
3263 io = GvIO(PL_statgv);
3265 if (io && IoIFP(io)) {
3266 if (! PerlIO_has_base(IoIFP(io)))
3267 DIE(aTHX_ "-T and -B not implemented on filehandles");
3268 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3269 if (PL_laststatval < 0)
3271 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3272 if (PL_op->op_type == OP_FTTEXT)
3277 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3278 i = PerlIO_getc(IoIFP(io));
3280 (void)PerlIO_ungetc(IoIFP(io),i);
3282 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3284 len = PerlIO_get_bufsiz(IoIFP(io));
3285 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3286 /* sfio can have large buffers - limit to 512 */
3291 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3293 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3295 SETERRNO(EBADF,RMS_IFI);
3303 PL_laststype = OP_STAT;
3304 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3305 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3306 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3308 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3311 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3312 if (PL_laststatval < 0) {
3313 (void)PerlIO_close(fp);
3316 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3317 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3318 (void)PerlIO_close(fp);
3320 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3321 RETPUSHNO; /* special case NFS directories */
3322 RETPUSHYES; /* null file is anything */
3327 /* now scan s to look for textiness */
3328 /* XXX ASCII dependent code */
3330 #if defined(DOSISH) || defined(USEMYBINMODE)
3331 /* ignore trailing ^Z on short files */
3332 if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3336 for (i = 0; i < len; i++, s++) {
3337 if (!*s) { /* null never allowed in text */
3342 else if (!(isPRINT(*s) || isSPACE(*s)))
3345 else if (*s & 128) {
3347 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3350 /* utf8 characters don't count as odd */
3351 if (UTF8_IS_START(*s)) {
3352 int ulen = UTF8SKIP(s);
3353 if (ulen < len - i) {
3355 for (j = 1; j < ulen; j++) {
3356 if (!UTF8_IS_CONTINUATION(s[j]))
3359 --ulen; /* loop does extra increment */
3369 *s != '\n' && *s != '\r' && *s != '\b' &&
3370 *s != '\t' && *s != '\f' && *s != 27)
3375 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3386 const char *tmps = NULL;
3390 SV * const sv = POPs;
3391 if (PL_op->op_flags & OPf_SPECIAL) {
3392 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3394 else if (SvTYPE(sv) == SVt_PVGV) {
3397 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
3401 tmps = SvPVx_nolen_const(sv);
3405 if( !gv && (!tmps || !*tmps) ) {
3406 HV * const table = GvHVn(PL_envgv);
3409 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3410 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3412 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3417 deprecate("chdir('') or chdir(undef) as chdir()");
3418 tmps = SvPV_nolen_const(*svp);
3422 TAINT_PROPER("chdir");
3427 TAINT_PROPER("chdir");
3430 IO* const io = GvIO(gv);
3433 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3435 else if (IoDIRP(io)) {
3437 PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0);
3439 DIE(aTHX_ PL_no_func, "dirfd");
3443 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3444 report_evil_fh(gv, io, PL_op->op_type);
3445 SETERRNO(EBADF, RMS_IFI);
3450 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3451 report_evil_fh(gv, io, PL_op->op_type);
3452 SETERRNO(EBADF,RMS_IFI);
3456 DIE(aTHX_ PL_no_func, "fchdir");
3460 PUSHi( PerlDir_chdir(tmps) >= 0 );
3462 /* Clear the DEFAULT element of ENV so we'll get the new value
3464 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3471 dVAR; dSP; dMARK; dTARGET;
3472 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3483 char * const tmps = POPpx;
3484 TAINT_PROPER("chroot");
3485 PUSHi( chroot(tmps) >= 0 );
3488 DIE(aTHX_ PL_no_func, "chroot");
3496 const char * const tmps2 = POPpconstx;
3497 const char * const tmps = SvPV_nolen_const(TOPs);
3498 TAINT_PROPER("rename");
3500 anum = PerlLIO_rename(tmps, tmps2);
3502 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3503 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3506 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3507 (void)UNLINK(tmps2);
3508 if (!(anum = link(tmps, tmps2)))
3509 anum = UNLINK(tmps);
3517 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3521 const int op_type = PL_op->op_type;
3525 if (op_type == OP_LINK)
3526 DIE(aTHX_ PL_no_func, "link");
3528 # ifndef HAS_SYMLINK
3529 if (op_type == OP_SYMLINK)
3530 DIE(aTHX_ PL_no_func, "symlink");
3534 const char * const tmps2 = POPpconstx;
3535 const char * const tmps = SvPV_nolen_const(TOPs);
3536 TAINT_PROPER(PL_op_desc[op_type]);
3538 # if defined(HAS_LINK)
3539 # if defined(HAS_SYMLINK)
3540 /* Both present - need to choose which. */
3541 (op_type == OP_LINK) ?
3542 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3544 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3545 PerlLIO_link(tmps, tmps2);
3548 # if defined(HAS_SYMLINK)
3549 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3550 symlink(tmps, tmps2);
3555 SETi( result >= 0 );
3562 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3573 char buf[MAXPATHLEN];
3576 #ifndef INCOMPLETE_TAINTS
3580 len = readlink(tmps, buf, sizeof(buf) - 1);
3588 RETSETUNDEF; /* just pretend it's a normal file */
3592 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3594 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3596 char * const save_filename = filename;
3601 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3603 Newx(cmdline, size, char);
3604 my_strlcpy(cmdline, cmd, size);
3605 my_strlcat(cmdline, " ", size);
3606 for (s = cmdline + strlen(cmdline); *filename; ) {
3610 if (s - cmdline < size)
3611 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3612 myfp = PerlProc_popen(cmdline, "r");
3616 SV * const tmpsv = sv_newmortal();
3617 /* Need to save/restore 'PL_rs' ?? */
3618 s = sv_gets(tmpsv, myfp, 0);
3619 (void)PerlProc_pclose(myfp);
3623 #ifdef HAS_SYS_ERRLIST
3628 /* you don't see this */
3629 const char * const errmsg =
3630 #ifdef HAS_SYS_ERRLIST
3638 if (instr(s, errmsg)) {
3645 #define EACCES EPERM
3647 if (instr(s, "cannot make"))
3648 SETERRNO(EEXIST,RMS_FEX);
3649 else if (instr(s, "existing file"))
3650 SETERRNO(EEXIST,RMS_FEX);
3651 else if (instr(s, "ile exists"))
3652 SETERRNO(EEXIST,RMS_FEX);
3653 else if (instr(s, "non-exist"))
3654 SETERRNO(ENOENT,RMS_FNF);
3655 else if (instr(s, "does not exist"))
3656 SETERRNO(ENOENT,RMS_FNF);
3657 else if (instr(s, "not empty"))
3658 SETERRNO(EBUSY,SS_DEVOFFLINE);
3659 else if (instr(s, "cannot access"))
3660 SETERRNO(EACCES,RMS_PRV);
3662 SETERRNO(EPERM,RMS_PRV);
3665 else { /* some mkdirs return no failure indication */
3666 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3667 if (PL_op->op_type == OP_RMDIR)
3672 SETERRNO(EACCES,RMS_PRV); /* a guess */
3681 /* This macro removes trailing slashes from a directory name.
3682 * Different operating and file systems take differently to
3683 * trailing slashes. According to POSIX 1003.1 1996 Edition
3684 * any number of trailing slashes should be allowed.
3685 * Thusly we snip them away so that even non-conforming
3686 * systems are happy.
3687 * We should probably do this "filtering" for all
3688 * the functions that expect (potentially) directory names:
3689 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3690 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3692 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3693 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3696 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3697 (tmps) = savepvn((tmps), (len)); \
3707 const int mode = (MAXARG > 1) ? POPi : 0777;
3709 TRIMSLASHES(tmps,len,copy);
3711 TAINT_PROPER("mkdir");
3713 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3717 SETi( dooneliner("mkdir", tmps) );
3718 oldumask = PerlLIO_umask(0);
3719 PerlLIO_umask(oldumask);
3720 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3735 TRIMSLASHES(tmps,len,copy);
3736 TAINT_PROPER("rmdir");
3738 SETi( PerlDir_rmdir(tmps) >= 0 );
3740 SETi( dooneliner("rmdir", tmps) );
3747 /* Directory calls. */
3751 #if defined(Direntry_t) && defined(HAS_READDIR)
3753 const char * const dirname = POPpconstx;
3754 GV * const gv = (GV*)POPs;
3755 register IO * const io = GvIOn(gv);
3761 PerlDir_close(IoDIRP(io));
3762 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3768 SETERRNO(EBADF,RMS_DIR);
3771 DIE(aTHX_ PL_no_dir_func, "opendir");
3777 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3778 DIE(aTHX_ PL_no_dir_func, "readdir");
3780 #if !defined(I_DIRENT) && !defined(VMS)
3781 Direntry_t *readdir (DIR *);
3787 const I32 gimme = GIMME;
3788 GV * const gv = (GV *)POPs;
3789 register const Direntry_t *dp;
3790 register IO * const io = GvIOn(gv);
3792 if (!io || !IoDIRP(io)) {
3793 if(ckWARN(WARN_IO)) {
3794 Perl_warner(aTHX_ packWARN(WARN_IO),
3795 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3801 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3805 sv = newSVpvn(dp->d_name, dp->d_namlen);
3807 sv = newSVpv(dp->d_name, 0);
3809 #ifndef INCOMPLETE_TAINTS
3810 if (!(IoFLAGS(io) & IOf_UNTAINT))
3813 XPUSHs(sv_2mortal(sv));
3814 } while (gimme == G_ARRAY);
3816 if (!dp && gimme != G_ARRAY)
3823 SETERRNO(EBADF,RMS_ISI);
3824 if (GIMME == G_ARRAY)
3833 #if defined(HAS_TELLDIR) || defined(telldir)
3835 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3836 /* XXX netbsd still seemed to.
3837 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3838 --JHI 1999-Feb-02 */
3839 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3840 long telldir (DIR *);
3842 GV * const gv = (GV*)POPs;
3843 register IO * const io = GvIOn(gv);
3845 if (!io || !IoDIRP(io)) {
3846 if(ckWARN(WARN_IO)) {
3847 Perl_warner(aTHX_ packWARN(WARN_IO),
3848 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3853 PUSHi( PerlDir_tell(IoDIRP(io)) );
3857 SETERRNO(EBADF,RMS_ISI);
3860 DIE(aTHX_ PL_no_dir_func, "telldir");
3866 #if defined(HAS_SEEKDIR) || defined(seekdir)
3868 const long along = POPl;
3869 GV * const gv = (GV*)POPs;
3870 register IO * const io = GvIOn(gv);
3872 if (!io || !IoDIRP(io)) {
3873 if(ckWARN(WARN_IO)) {
3874 Perl_warner(aTHX_ packWARN(WARN_IO),
3875 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3879 (void)PerlDir_seek(IoDIRP(io), along);
3884 SETERRNO(EBADF,RMS_ISI);
3887 DIE(aTHX_ PL_no_dir_func, "seekdir");
3893 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3895 GV * const gv = (GV*)POPs;
3896 register IO * const io = GvIOn(gv);
3898 if (!io || !IoDIRP(io)) {
3899 if(ckWARN(WARN_IO)) {
3900 Perl_warner(aTHX_ packWARN(WARN_IO),
3901 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3905 (void)PerlDir_rewind(IoDIRP(io));
3909 SETERRNO(EBADF,RMS_ISI);
3912 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3918 #if defined(Direntry_t) && defined(HAS_READDIR)
3920 GV * const gv = (GV*)POPs;
3921 register IO * const io = GvIOn(gv);
3923 if (!io || !IoDIRP(io)) {
3924 if(ckWARN(WARN_IO)) {
3925 Perl_warner(aTHX_ packWARN(WARN_IO),
3926 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3930 #ifdef VOID_CLOSEDIR
3931 PerlDir_close(IoDIRP(io));
3933 if (PerlDir_close(IoDIRP(io)) < 0) {
3934 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3943 SETERRNO(EBADF,RMS_IFI);
3946 DIE(aTHX_ PL_no_dir_func, "closedir");
3950 /* Process control. */
3959 PERL_FLUSHALL_FOR_CHILD;
3960 childpid = PerlProc_fork();
3964 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3966 SvREADONLY_off(GvSV(tmpgv));
3967 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3968 SvREADONLY_on(GvSV(tmpgv));
3970 #ifdef THREADS_HAVE_PIDS
3971 PL_ppid = (IV)getppid();
3973 #ifdef PERL_USES_PL_PIDSTATUS
3974 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3980 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3985 PERL_FLUSHALL_FOR_CHILD;
3986 childpid = PerlProc_fork();
3992 DIE(aTHX_ PL_no_func, "fork");
3999 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4004 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4005 childpid = wait4pid(-1, &argflags, 0);
4007 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4012 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4013 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4014 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4016 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4021 DIE(aTHX_ PL_no_func, "wait");
4027 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4029 const int optype = POPi;
4030 const Pid_t pid = TOPi;
4034 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4035 result = wait4pid(pid, &argflags, optype);
4037 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4042 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4043 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4044 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4046 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4051 DIE(aTHX_ PL_no_func, "waitpid");
4057 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4063 while (++MARK <= SP) {
4064 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4069 TAINT_PROPER("system");
4071 PERL_FLUSHALL_FOR_CHILD;
4072 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4078 if (PerlProc_pipe(pp) >= 0)
4080 while ((childpid = PerlProc_fork()) == -1) {
4081 if (errno != EAGAIN) {
4086 PerlLIO_close(pp[0]);
4087 PerlLIO_close(pp[1]);
4094 Sigsave_t ihand,qhand; /* place to save signals during system() */
4098 PerlLIO_close(pp[1]);
4100 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4101 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4104 result = wait4pid(childpid, &status, 0);
4105 } while (result == -1 && errno == EINTR);
4107 (void)rsignal_restore(SIGINT, &ihand);
4108 (void)rsignal_restore(SIGQUIT, &qhand);
4110 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4111 do_execfree(); /* free any memory child malloced on fork */
4118 while (n < sizeof(int)) {
4119 n1 = PerlLIO_read(pp[0],
4120 (void*)(((char*)&errkid)+n),
4126 PerlLIO_close(pp[0]);
4127 if (n) { /* Error */
4128 if (n != sizeof(int))
4129 DIE(aTHX_ "panic: kid popen errno read");
4130 errno = errkid; /* Propagate errno from kid */
4131 STATUS_NATIVE_CHILD_SET(-1);
4134 XPUSHi(STATUS_CURRENT);
4138 PerlLIO_close(pp[0]);
4139 #if defined(HAS_FCNTL) && defined(F_SETFD)
4140 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4143 if (PL_op->op_flags & OPf_STACKED) {
4144 SV * const really = *++MARK;
4145 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4147 else if (SP - MARK != 1)
4148 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4150 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4154 #else /* ! FORK or VMS or OS/2 */
4157 if (PL_op->op_flags & OPf_STACKED) {
4158 SV * const really = *++MARK;
4159 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4160 value = (I32)do_aspawn(really, MARK, SP);
4162 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4165 else if (SP - MARK != 1) {
4166 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4167 value = (I32)do_aspawn(NULL, MARK, SP);
4169 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4173 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4175 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4177 STATUS_NATIVE_CHILD_SET(value);
4180 XPUSHi(result ? value : STATUS_CURRENT);
4181 #endif /* !FORK or VMS */
4187 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4192 while (++MARK <= SP) {
4193 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4198 TAINT_PROPER("exec");
4200 PERL_FLUSHALL_FOR_CHILD;
4201 if (PL_op->op_flags & OPf_STACKED) {
4202 SV * const really = *++MARK;
4203 value = (I32)do_aexec(really, MARK, SP);
4205 else if (SP - MARK != 1)
4207 value = (I32)vms_do_aexec(NULL, MARK, SP);
4211 (void ) do_aspawn(NULL, MARK, SP);
4215 value = (I32)do_aexec(NULL, MARK, SP);
4220 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4223 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4226 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4240 # ifdef THREADS_HAVE_PIDS
4241 if (PL_ppid != 1 && getppid() == 1)
4242 /* maybe the parent process has died. Refresh ppid cache */
4246 XPUSHi( getppid() );
4250 DIE(aTHX_ PL_no_func, "getppid");
4259 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4262 pgrp = (I32)BSD_GETPGRP(pid);
4264 if (pid != 0 && pid != PerlProc_getpid())
4265 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4271 DIE(aTHX_ PL_no_func, "getpgrp()");
4290 TAINT_PROPER("setpgrp");
4292 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4294 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4295 || (pid != 0 && pid != PerlProc_getpid()))
4297 DIE(aTHX_ "setpgrp can't take arguments");
4299 SETi( setpgrp() >= 0 );
4300 #endif /* USE_BSDPGRP */
4303 DIE(aTHX_ PL_no_func, "setpgrp()");
4309 #ifdef HAS_GETPRIORITY
4311 const int who = POPi;
4312 const int which = TOPi;
4313 SETi( getpriority(which, who) );
4316 DIE(aTHX_ PL_no_func, "getpriority()");
4322 #ifdef HAS_SETPRIORITY
4324 const int niceval = POPi;
4325 const int who = POPi;
4326 const int which = TOPi;
4327 TAINT_PROPER("setpriority");
4328 SETi( setpriority(which, who, niceval) >= 0 );
4331 DIE(aTHX_ PL_no_func, "setpriority()");
4341 XPUSHn( time(NULL) );
4343 XPUSHi( time(NULL) );
4355 (void)PerlProc_times(&PL_timesbuf);
4357 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4358 /* struct tms, though same data */
4362 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
4363 if (GIMME == G_ARRAY) {
4364 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
4365 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
4366 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
4372 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4374 if (GIMME == G_ARRAY) {
4375 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4376 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4377 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4381 DIE(aTHX_ "times not implemented");
4383 #endif /* HAS_TIMES */
4386 #ifdef LOCALTIME_EDGECASE_BROKEN
4387 static struct tm *S_my_localtime (pTHX_ Time_t *tp)
4392 /* No workarounds in the valid range */
4393 if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4394 return (localtime (tp));
4396 /* This edge case is to workaround the undefined behaviour, where the
4397 * TIMEZONE makes the time go beyond the defined range.
4398 * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4399 * If there is a negative offset in TZ, like MET-1METDST, some broken
4400 * implementations of localtime () (like AIX 5.2) barf with bogus
4402 * 0x7fffffff gmtime 2038-01-19 03:14:07
4403 * 0x7fffffff localtime 1901-12-13 21:45:51
4404 * 0x7fffffff mylocaltime 2038-01-19 04:14:07
4405 * 0x3c19137f gmtime 2001-12-13 20:45:51
4406 * 0x3c19137f localtime 2001-12-13 21:45:51
4407 * 0x3c19137f mylocaltime 2001-12-13 21:45:51
4408 * Given that legal timezones are typically between GMT-12 and GMT+12
4409 * we turn back the clock 23 hours before calling the localtime
4410 * function, and add those to the return value. This will never cause
4411 * day wrapping problems, since the edge case is Tue Jan *19*
4413 T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4416 if (P->tm_hour >= 24) {
4418 P->tm_mday++; /* 18 -> 19 */
4419 P->tm_wday++; /* Mon -> Tue */
4420 P->tm_yday++; /* 18 -> 19 */
4423 } /* S_my_localtime */
4431 const struct tm *tmbuf;
4432 static const char * const dayname[] =
4433 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4434 static const char * const monname[] =
4435 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4436 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4442 when = (Time_t)SvNVx(POPs);
4444 when = (Time_t)SvIVx(POPs);
4447 if (PL_op->op_type == OP_LOCALTIME)
4448 #ifdef LOCALTIME_EDGECASE_BROKEN
4449 tmbuf = S_my_localtime(aTHX_ &when);
4451 tmbuf = localtime(&when);
4454 tmbuf = gmtime(&when);
4456 if (GIMME != G_ARRAY) {
4462 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4463 dayname[tmbuf->tm_wday],
4464 monname[tmbuf->tm_mon],
4469 tmbuf->tm_year + 1900);
4470 PUSHs(sv_2mortal(tsv));
4475 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4476 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4477 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4478 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4479 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4480 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4481 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4482 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4483 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4494 anum = alarm((unsigned int)anum);
4501 DIE(aTHX_ PL_no_func, "alarm");
4512 (void)time(&lasttime);
4517 PerlProc_sleep((unsigned int)duration);
4520 XPUSHi(when - lasttime);
4524 /* Shared memory. */
4525 /* Merged with some message passing. */
4529 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4530 dVAR; dSP; dMARK; dTARGET;
4531 const int op_type = PL_op->op_type;
4536 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4539 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4542 value = (I32)(do_semop(MARK, SP) >= 0);
4545 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4561 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4562 dVAR; dSP; dMARK; dTARGET;
4563 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4570 DIE(aTHX_ "System V IPC is not implemented on this machine");
4576 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4577 dVAR; dSP; dMARK; dTARGET;
4578 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4586 PUSHp(zero_but_true, ZBTLEN);
4594 /* I can't const this further without getting warnings about the types of
4595 various arrays passed in from structures. */
4597 S_space_join_names_mortal(pTHX_ char *const *array)
4601 if (array && *array) {
4602 target = sv_2mortal(newSVpvs(""));
4604 sv_catpv(target, *array);
4607 sv_catpvs(target, " ");
4610 target = sv_mortalcopy(&PL_sv_no);
4615 /* Get system info. */
4619 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4621 I32 which = PL_op->op_type;
4622 register char **elem;
4624 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4625 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4626 struct hostent *gethostbyname(Netdb_name_t);
4627 struct hostent *gethostent(void);
4629 struct hostent *hent;
4633 if (which == OP_GHBYNAME) {
4634 #ifdef HAS_GETHOSTBYNAME
4635 const char* const name = POPpbytex;
4636 hent = PerlSock_gethostbyname(name);
4638 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4641 else if (which == OP_GHBYADDR) {
4642 #ifdef HAS_GETHOSTBYADDR
4643 const int addrtype = POPi;
4644 SV * const addrsv = POPs;
4646 Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4648 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4650 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4654 #ifdef HAS_GETHOSTENT
4655 hent = PerlSock_gethostent();
4657 DIE(aTHX_ PL_no_sock_func, "gethostent");
4660 #ifdef HOST_NOT_FOUND
4662 #ifdef USE_REENTRANT_API
4663 # ifdef USE_GETHOSTENT_ERRNO
4664 h_errno = PL_reentrant_buffer->_gethostent_errno;
4667 STATUS_UNIX_SET(h_errno);
4671 if (GIMME != G_ARRAY) {
4672 PUSHs(sv = sv_newmortal());
4674 if (which == OP_GHBYNAME) {
4676 sv_setpvn(sv, hent->h_addr, hent->h_length);
4679 sv_setpv(sv, (char*)hent->h_name);
4685 PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
4686 PUSHs(space_join_names_mortal(hent->h_aliases));
4687 PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
4688 len = hent->h_length;
4689 PUSHs(sv_2mortal(newSViv((IV)len)));
4691 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4692 XPUSHs(sv_2mortal(newSVpvn(*elem, len)));
4696 PUSHs(newSVpvn(hent->h_addr, len));
4698 PUSHs(sv_mortalcopy(&PL_sv_no));
4703 DIE(aTHX_ PL_no_sock_func, "gethostent");
4709 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4711 I32 which = PL_op->op_type;
4713 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4714 struct netent *getnetbyaddr(Netdb_net_t, int);
4715 struct netent *getnetbyname(Netdb_name_t);
4716 struct netent *getnetent(void);
4718 struct netent *nent;
4720 if (which == OP_GNBYNAME){
4721 #ifdef HAS_GETNETBYNAME
4722 const char * const name = POPpbytex;
4723 nent = PerlSock_getnetbyname(name);
4725 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4728 else if (which == OP_GNBYADDR) {
4729 #ifdef HAS_GETNETBYADDR
4730 const int addrtype = POPi;
4731 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4732 nent = PerlSock_getnetbyaddr(addr, addrtype);
4734 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4738 #ifdef HAS_GETNETENT
4739 nent = PerlSock_getnetent();
4741 DIE(aTHX_ PL_no_sock_func, "getnetent");
4744 #ifdef HOST_NOT_FOUND
4746 #ifdef USE_REENTRANT_API
4747 # ifdef USE_GETNETENT_ERRNO
4748 h_errno = PL_reentrant_buffer->_getnetent_errno;
4751 STATUS_UNIX_SET(h_errno);
4756 if (GIMME != G_ARRAY) {
4757 PUSHs(sv = sv_newmortal());
4759 if (which == OP_GNBYNAME)
4760 sv_setiv(sv, (IV)nent->n_net);
4762 sv_setpv(sv, nent->n_name);
4768 PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
4769 PUSHs(space_join_names_mortal(nent->n_aliases));
4770 PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
4771 PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
4776 DIE(aTHX_ PL_no_sock_func, "getnetent");
4782 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4784 I32 which = PL_op->op_type;
4786 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4787 struct protoent *getprotobyname(Netdb_name_t);
4788 struct protoent *getprotobynumber(int);
4789 struct protoent *getprotoent(void);
4791 struct protoent *pent;
4793 if (which == OP_GPBYNAME) {
4794 #ifdef HAS_GETPROTOBYNAME
4795 const char* const name = POPpbytex;
4796 pent = PerlSock_getprotobyname(name);
4798 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4801 else if (which == OP_GPBYNUMBER) {
4802 #ifdef HAS_GETPROTOBYNUMBER
4803 const int number = POPi;
4804 pent = PerlSock_getprotobynumber(number);
4806 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4810 #ifdef HAS_GETPROTOENT
4811 pent = PerlSock_getprotoent();
4813 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4817 if (GIMME != G_ARRAY) {
4818 PUSHs(sv = sv_newmortal());
4820 if (which == OP_GPBYNAME)
4821 sv_setiv(sv, (IV)pent->p_proto);
4823 sv_setpv(sv, pent->p_name);
4829 PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
4830 PUSHs(space_join_names_mortal(pent->p_aliases));
4831 PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
4836 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4842 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4844 I32 which = PL_op->op_type;
4846 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4847 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4848 struct servent *getservbyport(int, Netdb_name_t);
4849 struct servent *getservent(void);
4851 struct servent *sent;
4853 if (which == OP_GSBYNAME) {
4854 #ifdef HAS_GETSERVBYNAME
4855 const char * const proto = POPpbytex;
4856 const char * const name = POPpbytex;
4857 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4859 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4862 else if (which == OP_GSBYPORT) {
4863 #ifdef HAS_GETSERVBYPORT
4864 const char * const proto = POPpbytex;
4865 unsigned short port = (unsigned short)POPu;
4867 port = PerlSock_htons(port);
4869 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4871 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4875 #ifdef HAS_GETSERVENT
4876 sent = PerlSock_getservent();
4878 DIE(aTHX_ PL_no_sock_func, "getservent");
4882 if (GIMME != G_ARRAY) {
4883 PUSHs(sv = sv_newmortal());
4885 if (which == OP_GSBYNAME) {
4887 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4889 sv_setiv(sv, (IV)(sent->s_port));
4893 sv_setpv(sv, sent->s_name);
4899 PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
4900 PUSHs(space_join_names_mortal(sent->s_aliases));
4902 PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
4904 PUSHs(sv_2mortal(newSViv((IV)(sent->s_port))));
4906 PUSHs(sv_2mortal(newSVpv(sent->s_proto, 0)));
4911 DIE(aTHX_ PL_no_sock_func, "getservent");
4917 #ifdef HAS_SETHOSTENT
4919 PerlSock_sethostent(TOPi);
4922 DIE(aTHX_ PL_no_sock_func, "sethostent");
4928 #ifdef HAS_SETNETENT
4930 PerlSock_setnetent(TOPi);
4933 DIE(aTHX_ PL_no_sock_func, "setnetent");
4939 #ifdef HAS_SETPROTOENT
4941 PerlSock_setprotoent(TOPi);
4944 DIE(aTHX_ PL_no_sock_func, "setprotoent");
4950 #ifdef HAS_SETSERVENT
4952 PerlSock_setservent(TOPi);
4955 DIE(aTHX_ PL_no_sock_func, "setservent");
4961 #ifdef HAS_ENDHOSTENT
4963 PerlSock_endhostent();
4967 DIE(aTHX_ PL_no_sock_func, "endhostent");
4973 #ifdef HAS_ENDNETENT
4975 PerlSock_endnetent();
4979 DIE(aTHX_ PL_no_sock_func, "endnetent");
4985 #ifdef HAS_ENDPROTOENT
4987 PerlSock_endprotoent();
4991 DIE(aTHX_ PL_no_sock_func, "endprotoent");
4997 #ifdef HAS_ENDSERVENT
4999 PerlSock_endservent();
5003 DIE(aTHX_ PL_no_sock_func, "endservent");
5011 I32 which = PL_op->op_type;
5013 struct passwd *pwent = NULL;
5015 * We currently support only the SysV getsp* shadow password interface.
5016 * The interface is declared in <shadow.h> and often one needs to link
5017 * with -lsecurity or some such.
5018 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5021 * AIX getpwnam() is clever enough to return the encrypted password
5022 * only if the caller (euid?) is root.
5024 * There are at least three other shadow password APIs. Many platforms
5025 * seem to contain more than one interface for accessing the shadow
5026 * password databases, possibly for compatibility reasons.
5027 * The getsp*() is by far he simplest one, the other two interfaces
5028 * are much more complicated, but also very similar to each other.
5033 * struct pr_passwd *getprpw*();
5034 * The password is in
5035 * char getprpw*(...).ufld.fd_encrypt[]
5036 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5041 * struct es_passwd *getespw*();
5042 * The password is in
5043 * char *(getespw*(...).ufld.fd_encrypt)
5044 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5047 * struct userpw *getuserpw();
5048 * The password is in
5049 * char *(getuserpw(...)).spw_upw_passwd
5050 * (but the de facto standard getpwnam() should work okay)
5052 * Mention I_PROT here so that Configure probes for it.
5054 * In HP-UX for getprpw*() the manual page claims that one should include
5055 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5056 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5057 * and pp_sys.c already includes <shadow.h> if there is such.
5059 * Note that <sys/security.h> is already probed for, but currently
5060 * it is only included in special cases.
5062 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5063 * be preferred interface, even though also the getprpw*() interface
5064 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5065 * One also needs to call set_auth_parameters() in main() before
5066 * doing anything else, whether one is using getespw*() or getprpw*().
5068 * Note that accessing the shadow databases can be magnitudes
5069 * slower than accessing the standard databases.
5074 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5075 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5076 * the pw_comment is left uninitialized. */
5077 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5083 const char* const name = POPpbytex;
5084 pwent = getpwnam(name);
5090 pwent = getpwuid(uid);
5094 # ifdef HAS_GETPWENT
5096 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5097 if (pwent) pwent = getpwnam(pwent->pw_name);
5100 DIE(aTHX_ PL_no_func, "getpwent");
5106 if (GIMME != G_ARRAY) {
5107 PUSHs(sv = sv_newmortal());
5109 if (which == OP_GPWNAM)
5110 # if Uid_t_sign <= 0
5111 sv_setiv(sv, (IV)pwent->pw_uid);
5113 sv_setuv(sv, (UV)pwent->pw_uid);
5116 sv_setpv(sv, pwent->pw_name);
5122 PUSHs(sv_2mortal(newSVpv(pwent->pw_name, 0)));
5124 PUSHs(sv = sv_2mortal(newSViv(0)));
5125 /* If we have getspnam(), we try to dig up the shadow
5126 * password. If we are underprivileged, the shadow
5127 * interface will set the errno to EACCES or similar,
5128 * and return a null pointer. If this happens, we will
5129 * use the dummy password (usually "*" or "x") from the
5130 * standard password database.
5132 * In theory we could skip the shadow call completely
5133 * if euid != 0 but in practice we cannot know which
5134 * security measures are guarding the shadow databases
5135 * on a random platform.
5137 * Resist the urge to use additional shadow interfaces.
5138 * Divert the urge to writing an extension instead.
5141 /* Some AIX setups falsely(?) detect some getspnam(), which
5142 * has a different API than the Solaris/IRIX one. */
5143 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5145 const int saverrno = errno;
5146 const struct spwd * const spwent = getspnam(pwent->pw_name);
5147 /* Save and restore errno so that
5148 * underprivileged attempts seem
5149 * to have never made the unsccessful
5150 * attempt to retrieve the shadow password. */
5152 if (spwent && spwent->sp_pwdp)
5153 sv_setpv(sv, spwent->sp_pwdp);
5157 if (!SvPOK(sv)) /* Use the standard password, then. */
5158 sv_setpv(sv, pwent->pw_passwd);
5161 # ifndef INCOMPLETE_TAINTS
5162 /* passwd is tainted because user himself can diddle with it.
5163 * admittedly not much and in a very limited way, but nevertheless. */
5167 # if Uid_t_sign <= 0
5168 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_uid)));
5170 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_uid)));
5173 # if Uid_t_sign <= 0
5174 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_gid)));
5176 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_gid)));
5178 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5179 * because of the poor interface of the Perl getpw*(),
5180 * not because there's some standard/convention saying so.
5181 * A better interface would have been to return a hash,
5182 * but we are accursed by our history, alas. --jhi. */
5184 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_change)));
5187 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_quota)));
5190 PUSHs(sv_2mortal(newSVpv(pwent->pw_age, 0)));
5192 /* I think that you can never get this compiled, but just in case. */
5193 PUSHs(sv_mortalcopy(&PL_sv_no));
5198 /* pw_class and pw_comment are mutually exclusive--.
5199 * see the above note for pw_change, pw_quota, and pw_age. */
5201 PUSHs(sv_2mortal(newSVpv(pwent->pw_class, 0)));
5204 PUSHs(sv_2mortal(newSVpv(pwent->pw_comment, 0)));
5206 /* I think that you can never get this compiled, but just in case. */
5207 PUSHs(sv_mortalcopy(&PL_sv_no));
5212 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5214 PUSHs(sv_mortalcopy(&PL_sv_no));
5216 # ifndef INCOMPLETE_TAINTS
5217 /* pw_gecos is tainted because user himself can diddle with it. */
5221 PUSHs(sv_2mortal(newSVpv(pwent->pw_dir, 0)));
5223 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5224 # ifndef INCOMPLETE_TAINTS
5225 /* pw_shell is tainted because user himself can diddle with it. */
5230 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_expire)));
5235 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5241 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5246 DIE(aTHX_ PL_no_func, "setpwent");
5252 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5257 DIE(aTHX_ PL_no_func, "endpwent");
5265 const I32 which = PL_op->op_type;
5266 const struct group *grent;
5268 if (which == OP_GGRNAM) {
5269 const char* const name = POPpbytex;
5270 grent = (const struct group *)getgrnam(name);
5272 else if (which == OP_GGRGID) {
5273 const Gid_t gid = POPi;
5274 grent = (const struct group *)getgrgid(gid);
5278 grent = (struct group *)getgrent();
5280 DIE(aTHX_ PL_no_func, "getgrent");
5284 if (GIMME != G_ARRAY) {
5285 SV * const sv = sv_newmortal();
5289 if (which == OP_GGRNAM)
5290 sv_setiv(sv, (IV)grent->gr_gid);
5292 sv_setpv(sv, grent->gr_name);
5298 PUSHs(sv_2mortal(newSVpv(grent->gr_name, 0)));
5301 PUSHs(sv_2mortal(newSVpv(grent->gr_passwd, 0)));
5303 PUSHs(sv_mortalcopy(&PL_sv_no));
5306 PUSHs(sv_2mortal(newSViv((IV)grent->gr_gid)));
5308 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5309 /* In UNICOS/mk (_CRAYMPP) the multithreading
5310 * versions (getgrnam_r, getgrgid_r)
5311 * seem to return an illegal pointer
5312 * as the group members list, gr_mem.
5313 * getgrent() doesn't even have a _r version
5314 * but the gr_mem is poisonous anyway.
5315 * So yes, you cannot get the list of group
5316 * members if building multithreaded in UNICOS/mk. */
5317 PUSHs(space_join_names_mortal(grent->gr_mem));
5323 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5329 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5334 DIE(aTHX_ PL_no_func, "setgrent");
5340 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5345 DIE(aTHX_ PL_no_func, "endgrent");
5355 if (!(tmps = PerlProc_getlogin()))
5357 PUSHp(tmps, strlen(tmps));
5360 DIE(aTHX_ PL_no_func, "getlogin");
5364 /* Miscellaneous. */
5369 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5370 register I32 items = SP - MARK;
5371 unsigned long a[20];
5376 while (++MARK <= SP) {
5377 if (SvTAINTED(*MARK)) {
5383 TAINT_PROPER("syscall");
5386 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5387 * or where sizeof(long) != sizeof(char*). But such machines will
5388 * not likely have syscall implemented either, so who cares?
5390 while (++MARK <= SP) {
5391 if (SvNIOK(*MARK) || !i)
5392 a[i++] = SvIV(*MARK);
5393 else if (*MARK == &PL_sv_undef)
5396 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5402 DIE(aTHX_ "Too many args to syscall");
5404 DIE(aTHX_ "Too few args to syscall");
5406 retval = syscall(a[0]);
5409 retval = syscall(a[0],a[1]);
5412 retval = syscall(a[0],a[1],a[2]);
5415 retval = syscall(a[0],a[1],a[2],a[3]);
5418 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5421 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5424 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5427 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5431 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5434 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5437 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5441 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5445 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5449 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5450 a[10],a[11],a[12],a[13]);
5452 #endif /* atarist */
5458 DIE(aTHX_ PL_no_func, "syscall");
5462 #ifdef FCNTL_EMULATE_FLOCK
5464 /* XXX Emulate flock() with fcntl().
5465 What's really needed is a good file locking module.
5469 fcntl_emulate_flock(int fd, int operation)
5473 switch (operation & ~LOCK_NB) {
5475 flock.l_type = F_RDLCK;
5478 flock.l_type = F_WRLCK;
5481 flock.l_type = F_UNLCK;
5487 flock.l_whence = SEEK_SET;
5488 flock.l_start = flock.l_len = (Off_t)0;
5490 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5493 #endif /* FCNTL_EMULATE_FLOCK */
5495 #ifdef LOCKF_EMULATE_FLOCK
5497 /* XXX Emulate flock() with lockf(). This is just to increase
5498 portability of scripts. The calls are not completely
5499 interchangeable. What's really needed is a good file
5503 /* The lockf() constants might have been defined in <unistd.h>.
5504 Unfortunately, <unistd.h> causes troubles on some mixed
5505 (BSD/POSIX) systems, such as SunOS 4.1.3.
5507 Further, the lockf() constants aren't POSIX, so they might not be
5508 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5509 just stick in the SVID values and be done with it. Sigh.
5513 # define F_ULOCK 0 /* Unlock a previously locked region */
5516 # define F_LOCK 1 /* Lock a region for exclusive use */
5519 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5522 # define F_TEST 3 /* Test a region for other processes locks */
5526 lockf_emulate_flock(int fd, int operation)
5529 const int save_errno = errno;
5532 /* flock locks entire file so for lockf we need to do the same */
5533 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5534 if (pos > 0) /* is seekable and needs to be repositioned */
5535 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5536 pos = -1; /* seek failed, so don't seek back afterwards */
5539 switch (operation) {
5541 /* LOCK_SH - get a shared lock */
5543 /* LOCK_EX - get an exclusive lock */
5545 i = lockf (fd, F_LOCK, 0);
5548 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5549 case LOCK_SH|LOCK_NB:
5550 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5551 case LOCK_EX|LOCK_NB:
5552 i = lockf (fd, F_TLOCK, 0);
5554 if ((errno == EAGAIN) || (errno == EACCES))
5555 errno = EWOULDBLOCK;
5558 /* LOCK_UN - unlock (non-blocking is a no-op) */
5560 case LOCK_UN|LOCK_NB:
5561 i = lockf (fd, F_ULOCK, 0);
5564 /* Default - can't decipher operation */
5571 if (pos > 0) /* need to restore position of the handle */
5572 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5577 #endif /* LOCKF_EMULATE_FLOCK */
5581 * c-indentation-style: bsd
5583 * indent-tabs-mode: t
5586 * ex: set ts=8 sts=4 sw=4 noet: