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);
770 const int mode = mode_from_discipline(discp);
771 const char *const d = (discp ? SvPV_nolen_const(discp) : NULL);
772 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
773 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
774 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
795 const I32 markoff = MARK - PL_stack_base;
796 const char *methname;
797 int how = PERL_MAGIC_tied;
801 switch(SvTYPE(varsv)) {
803 methname = "TIEHASH";
804 HvEITER_set((HV *)varsv, 0);
807 methname = "TIEARRAY";
810 #ifdef GV_UNIQUE_CHECK
811 if (GvUNIQUE((GV*)varsv)) {
812 Perl_croak(aTHX_ "Attempt to tie unique GV");
815 methname = "TIEHANDLE";
816 how = PERL_MAGIC_tiedscalar;
817 /* For tied filehandles, we apply tiedscalar magic to the IO
818 slot of the GP rather than the GV itself. AMS 20010812 */
820 GvIOp(varsv) = newIO();
821 varsv = (SV *)GvIOp(varsv);
824 methname = "TIESCALAR";
825 how = PERL_MAGIC_tiedscalar;
829 if (sv_isobject(*MARK)) {
831 PUSHSTACKi(PERLSI_MAGIC);
833 EXTEND(SP,(I32)items);
837 call_method(methname, G_SCALAR);
840 /* Not clear why we don't call call_method here too.
841 * perhaps to get different error message ?
843 stash = gv_stashsv(*MARK, FALSE);
844 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
845 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
846 methname, (void*)*MARK);
849 PUSHSTACKi(PERLSI_MAGIC);
851 EXTEND(SP,(I32)items);
855 call_sv((SV*)GvCV(gv), G_SCALAR);
861 if (sv_isobject(sv)) {
862 sv_unmagic(varsv, how);
863 /* Croak if a self-tie on an aggregate is attempted. */
864 if (varsv == SvRV(sv) &&
865 (SvTYPE(varsv) == SVt_PVAV ||
866 SvTYPE(varsv) == SVt_PVHV))
868 "Self-ties of arrays and hashes are not supported");
869 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
872 SP = PL_stack_base + markoff;
882 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
883 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
885 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
888 if ((mg = SvTIED_mg(sv, how))) {
889 SV * const obj = SvRV(SvTIED_obj(sv, mg));
891 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
893 if (gv && isGV(gv) && (cv = GvCV(gv))) {
895 XPUSHs(SvTIED_obj((SV*)gv, mg));
896 XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
899 call_sv((SV *)cv, G_VOID);
903 else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
904 Perl_warner(aTHX_ packWARN(WARN_UNTIE),
905 "untie attempted while %"UVuf" inner references still exist",
906 (UV)SvREFCNT(obj) - 1 ) ;
910 sv_unmagic(sv, how) ;
920 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
921 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
923 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
926 if ((mg = SvTIED_mg(sv, how))) {
927 SV *osv = SvTIED_obj(sv, mg);
928 if (osv == mg->mg_obj)
929 osv = sv_mortalcopy(osv);
943 HV * const hv = (HV*)POPs;
944 SV * const sv = sv_2mortal(newSVpvs("AnyDBM_File"));
945 stash = gv_stashsv(sv, FALSE);
946 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
948 require_pv("AnyDBM_File.pm");
950 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
951 DIE(aTHX_ "No dbm on this machine");
961 PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
963 PUSHs(sv_2mortal(newSVuv(O_RDWR)));
966 call_sv((SV*)GvCV(gv), G_SCALAR);
969 if (!sv_isobject(TOPs)) {
974 PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
977 call_sv((SV*)GvCV(gv), G_SCALAR);
981 if (sv_isobject(TOPs)) {
982 sv_unmagic((SV *) hv, PERL_MAGIC_tied);
983 sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, NULL, 0);
1000 struct timeval timebuf;
1001 struct timeval *tbuf = &timebuf;
1004 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1009 # if BYTEORDER & 0xf0000
1010 # define ORDERBYTE (0x88888888 - BYTEORDER)
1012 # define ORDERBYTE (0x4444 - BYTEORDER)
1018 for (i = 1; i <= 3; i++) {
1019 SV * const sv = SP[i];
1022 if (SvREADONLY(sv)) {
1024 sv_force_normal_flags(sv, 0);
1025 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1026 DIE(aTHX_ PL_no_modify);
1029 if (ckWARN(WARN_MISC))
1030 Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1031 SvPV_force_nolen(sv); /* force string conversion */
1038 /* little endians can use vecs directly */
1039 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1046 masksize = NFDBITS / NBBY;
1048 masksize = sizeof(long); /* documented int, everyone seems to use long */
1050 Zero(&fd_sets[0], 4, char*);
1053 # if SELECT_MIN_BITS == 1
1054 growsize = sizeof(fd_set);
1056 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1057 # undef SELECT_MIN_BITS
1058 # define SELECT_MIN_BITS __FD_SETSIZE
1060 /* If SELECT_MIN_BITS is greater than one we most probably will want
1061 * to align the sizes with SELECT_MIN_BITS/8 because for example
1062 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1063 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1064 * on (sets/tests/clears bits) is 32 bits. */
1065 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1073 timebuf.tv_sec = (long)value;
1074 value -= (NV)timebuf.tv_sec;
1075 timebuf.tv_usec = (long)(value * 1000000.0);
1080 for (i = 1; i <= 3; i++) {
1082 if (!SvOK(sv) || SvCUR(sv) == 0) {
1089 Sv_Grow(sv, growsize);
1093 while (++j <= growsize) {
1097 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1099 Newx(fd_sets[i], growsize, char);
1100 for (offset = 0; offset < growsize; offset += masksize) {
1101 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1102 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1105 fd_sets[i] = SvPVX(sv);
1109 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1110 /* Can't make just the (void*) conditional because that would be
1111 * cpp #if within cpp macro, and not all compilers like that. */
1112 nfound = PerlSock_select(
1114 (Select_fd_set_t) fd_sets[1],
1115 (Select_fd_set_t) fd_sets[2],
1116 (Select_fd_set_t) fd_sets[3],
1117 (void*) tbuf); /* Workaround for compiler bug. */
1119 nfound = PerlSock_select(
1121 (Select_fd_set_t) fd_sets[1],
1122 (Select_fd_set_t) fd_sets[2],
1123 (Select_fd_set_t) fd_sets[3],
1126 for (i = 1; i <= 3; i++) {
1129 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1131 for (offset = 0; offset < growsize; offset += masksize) {
1132 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1133 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1135 Safefree(fd_sets[i]);
1142 if (GIMME == G_ARRAY && tbuf) {
1143 value = (NV)(timebuf.tv_sec) +
1144 (NV)(timebuf.tv_usec) / 1000000.0;
1145 PUSHs(sv_2mortal(newSVnv(value)));
1149 DIE(aTHX_ "select not implemented");
1154 Perl_setdefout(pTHX_ GV *gv)
1157 SvREFCNT_inc_simple_void(gv);
1159 SvREFCNT_dec(PL_defoutgv);
1167 GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : NULL;
1168 GV * egv = GvEGV(PL_defoutgv);
1174 XPUSHs(&PL_sv_undef);
1176 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1177 if (gvp && *gvp == egv) {
1178 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1182 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1187 if (!GvIO(newdefout))
1188 gv_IOadd(newdefout);
1189 setdefout(newdefout);
1199 GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs;
1201 if (gv && (io = GvIO(gv))) {
1202 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1204 const I32 gimme = GIMME_V;
1206 XPUSHs(SvTIED_obj((SV*)io, mg));
1209 call_method("GETC", gimme);
1212 if (gimme == G_SCALAR)
1213 SvSetMagicSV_nosteal(TARG, TOPs);
1217 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1218 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1219 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1220 report_evil_fh(gv, io, PL_op->op_type);
1221 SETERRNO(EBADF,RMS_IFI);
1225 sv_setpvn(TARG, " ", 1);
1226 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1227 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1228 /* Find out how many bytes the char needs */
1229 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1232 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1233 SvCUR_set(TARG,1+len);
1242 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1245 register PERL_CONTEXT *cx;
1246 const I32 gimme = GIMME_V;
1251 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1253 cx->blk_sub.retop = retop;
1255 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1257 setdefout(gv); /* locally select filehandle so $% et al work */
1289 goto not_a_format_reference;
1294 tmpsv = sv_newmortal();
1295 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1296 name = SvPV_nolen_const(tmpsv);
1298 DIE(aTHX_ "Undefined format \"%s\" called", name);
1300 not_a_format_reference:
1301 DIE(aTHX_ "Not a format reference");
1304 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1306 IoFLAGS(io) &= ~IOf_DIDTOP;
1307 return doform(cv,gv,PL_op->op_next);
1313 GV * const gv = cxstack[cxstack_ix].blk_sub.gv;
1314 register IO * const io = GvIOp(gv);
1319 register PERL_CONTEXT *cx;
1321 if (!io || !(ofp = IoOFP(io)))
1324 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1325 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1327 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1328 PL_formtarget != PL_toptarget)
1332 if (!IoTOP_GV(io)) {
1335 if (!IoTOP_NAME(io)) {
1337 if (!IoFMT_NAME(io))
1338 IoFMT_NAME(io) = savepv(GvNAME(gv));
1339 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1340 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1341 if ((topgv && GvFORM(topgv)) ||
1342 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1343 IoTOP_NAME(io) = savesvpv(topname);
1345 IoTOP_NAME(io) = savepvs("top");
1347 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1348 if (!topgv || !GvFORM(topgv)) {
1349 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1352 IoTOP_GV(io) = topgv;
1354 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1355 I32 lines = IoLINES_LEFT(io);
1356 const char *s = SvPVX_const(PL_formtarget);
1357 if (lines <= 0) /* Yow, header didn't even fit!!! */
1359 while (lines-- > 0) {
1360 s = strchr(s, '\n');
1366 const STRLEN save = SvCUR(PL_formtarget);
1367 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1368 do_print(PL_formtarget, ofp);
1369 SvCUR_set(PL_formtarget, save);
1370 sv_chop(PL_formtarget, s);
1371 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1374 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1375 do_print(PL_formfeed, ofp);
1376 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1378 PL_formtarget = PL_toptarget;
1379 IoFLAGS(io) |= IOf_DIDTOP;
1382 DIE(aTHX_ "bad top format reference");
1385 SV * const sv = sv_newmortal();
1387 gv_efullname4(sv, fgv, NULL, FALSE);
1388 name = SvPV_nolen_const(sv);
1390 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1392 DIE(aTHX_ "Undefined top format called");
1394 if (cv && CvCLONE(cv))
1395 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1396 return doform(cv, gv, PL_op);
1400 POPBLOCK(cx,PL_curpm);
1406 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1408 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1409 else if (ckWARN(WARN_CLOSED))
1410 report_evil_fh(gv, io, PL_op->op_type);
1415 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1416 if (ckWARN(WARN_IO))
1417 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1419 if (!do_print(PL_formtarget, fp))
1422 FmLINES(PL_formtarget) = 0;
1423 SvCUR_set(PL_formtarget, 0);
1424 *SvEND(PL_formtarget) = '\0';
1425 if (IoFLAGS(io) & IOf_FLUSH)
1426 (void)PerlIO_flush(fp);
1431 PL_formtarget = PL_bodytarget;
1433 PERL_UNUSED_VAR(newsp);
1434 PERL_UNUSED_VAR(gimme);
1435 return cx->blk_sub.retop;
1440 dVAR; dSP; dMARK; dORIGMARK;
1445 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
1447 if (gv && (io = GvIO(gv))) {
1448 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1450 if (MARK == ORIGMARK) {
1453 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1457 *MARK = SvTIED_obj((SV*)io, mg);
1460 call_method("PRINTF", G_SCALAR);
1463 MARK = ORIGMARK + 1;
1471 if (!(io = GvIO(gv))) {
1472 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1473 report_evil_fh(gv, io, PL_op->op_type);
1474 SETERRNO(EBADF,RMS_IFI);
1477 else if (!(fp = IoOFP(io))) {
1478 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1480 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1481 else if (ckWARN(WARN_CLOSED))
1482 report_evil_fh(gv, io, PL_op->op_type);
1484 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1488 if (SvTAINTED(MARK[1]))
1489 TAINT_PROPER("printf");
1490 do_sprintf(sv, SP - MARK, MARK + 1);
1491 if (!do_print(sv, fp))
1494 if (IoFLAGS(io) & IOf_FLUSH)
1495 if (PerlIO_flush(fp) == EOF)
1506 PUSHs(&PL_sv_undef);
1514 const int perm = (MAXARG > 3) ? POPi : 0666;
1515 const int mode = POPi;
1516 SV * const sv = POPs;
1517 GV * const gv = (GV *)POPs;
1520 /* Need TIEHANDLE method ? */
1521 const char * const tmps = SvPV_const(sv, len);
1522 /* FIXME? do_open should do const */
1523 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1524 IoLINES(GvIOp(gv)) = 0;
1528 PUSHs(&PL_sv_undef);
1535 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1541 Sock_size_t bufsize;
1549 bool charstart = FALSE;
1550 STRLEN charskip = 0;
1553 GV * const gv = (GV*)*++MARK;
1554 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1555 && gv && (io = GvIO(gv)) )
1557 const MAGIC * mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1561 *MARK = SvTIED_obj((SV*)io, mg);
1563 call_method("READ", G_SCALAR);
1577 sv_setpvn(bufsv, "", 0);
1578 length = SvIVx(*++MARK);
1581 offset = SvIVx(*++MARK);
1585 if (!io || !IoIFP(io)) {
1586 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1587 report_evil_fh(gv, io, PL_op->op_type);
1588 SETERRNO(EBADF,RMS_IFI);
1591 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1592 buffer = SvPVutf8_force(bufsv, blen);
1593 /* UTF-8 may not have been set if they are all low bytes */
1598 buffer = SvPV_force(bufsv, blen);
1599 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1602 DIE(aTHX_ "Negative length");
1610 if (PL_op->op_type == OP_RECV) {
1611 char namebuf[MAXPATHLEN];
1612 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1613 bufsize = sizeof (struct sockaddr_in);
1615 bufsize = sizeof namebuf;
1617 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1621 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1622 /* 'offset' means 'flags' here */
1623 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1624 (struct sockaddr *)namebuf, &bufsize);
1628 /* Bogus return without padding */
1629 bufsize = sizeof (struct sockaddr_in);
1631 SvCUR_set(bufsv, count);
1632 *SvEND(bufsv) = '\0';
1633 (void)SvPOK_only(bufsv);
1637 /* This should not be marked tainted if the fp is marked clean */
1638 if (!(IoFLAGS(io) & IOf_UNTAINT))
1639 SvTAINTED_on(bufsv);
1641 sv_setpvn(TARG, namebuf, bufsize);
1646 if (PL_op->op_type == OP_RECV)
1647 DIE(aTHX_ PL_no_sock_func, "recv");
1649 if (DO_UTF8(bufsv)) {
1650 /* offset adjust in characters not bytes */
1651 blen = sv_len_utf8(bufsv);
1654 if (-offset > (int)blen)
1655 DIE(aTHX_ "Offset outside string");
1658 if (DO_UTF8(bufsv)) {
1659 /* convert offset-as-chars to offset-as-bytes */
1660 if (offset >= (int)blen)
1661 offset += SvCUR(bufsv) - blen;
1663 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1666 bufsize = SvCUR(bufsv);
1667 /* Allocating length + offset + 1 isn't perfect in the case of reading
1668 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1670 (should be 2 * length + offset + 1, or possibly something longer if
1671 PL_encoding is true) */
1672 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1673 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1674 Zero(buffer+bufsize, offset-bufsize, char);
1676 buffer = buffer + offset;
1678 read_target = bufsv;
1680 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1681 concatenate it to the current buffer. */
1683 /* Truncate the existing buffer to the start of where we will be
1685 SvCUR_set(bufsv, offset);
1687 read_target = sv_newmortal();
1688 SvUPGRADE(read_target, SVt_PV);
1689 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1692 if (PL_op->op_type == OP_SYSREAD) {
1693 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1694 if (IoTYPE(io) == IoTYPE_SOCKET) {
1695 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1701 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1706 #ifdef HAS_SOCKET__bad_code_maybe
1707 if (IoTYPE(io) == IoTYPE_SOCKET) {
1708 char namebuf[MAXPATHLEN];
1709 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1710 bufsize = sizeof (struct sockaddr_in);
1712 bufsize = sizeof namebuf;
1714 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1715 (struct sockaddr *)namebuf, &bufsize);
1720 count = PerlIO_read(IoIFP(io), buffer, length);
1721 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1722 if (count == 0 && PerlIO_error(IoIFP(io)))
1726 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1727 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1730 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1731 *SvEND(read_target) = '\0';
1732 (void)SvPOK_only(read_target);
1733 if (fp_utf8 && !IN_BYTES) {
1734 /* Look at utf8 we got back and count the characters */
1735 const char *bend = buffer + count;
1736 while (buffer < bend) {
1738 skip = UTF8SKIP(buffer);
1741 if (buffer - charskip + skip > bend) {
1742 /* partial character - try for rest of it */
1743 length = skip - (bend-buffer);
1744 offset = bend - SvPVX_const(bufsv);
1756 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1757 provided amount read (count) was what was requested (length)
1759 if (got < wanted && count == length) {
1760 length = wanted - got;
1761 offset = bend - SvPVX_const(bufsv);
1764 /* return value is character count */
1768 else if (buffer_utf8) {
1769 /* Let svcatsv upgrade the bytes we read in to utf8.
1770 The buffer is a mortal so will be freed soon. */
1771 sv_catsv_nomg(bufsv, read_target);
1774 /* This should not be marked tainted if the fp is marked clean */
1775 if (!(IoFLAGS(io) & IOf_UNTAINT))
1776 SvTAINTED_on(bufsv);
1788 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1794 STRLEN orig_blen_bytes;
1795 const int op_type = PL_op->op_type;
1799 GV *const gv = (GV*)*++MARK;
1800 if (PL_op->op_type == OP_SYSWRITE
1801 && gv && (io = GvIO(gv))) {
1802 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1806 if (MARK == SP - 1) {
1808 sv = sv_2mortal(newSViv(sv_len(*SP)));
1814 *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg);
1816 call_method("WRITE", G_SCALAR);
1832 if (!io || !IoIFP(io)) {
1834 if (ckWARN(WARN_CLOSED))
1835 report_evil_fh(gv, io, PL_op->op_type);
1836 SETERRNO(EBADF,RMS_IFI);
1840 /* Do this first to trigger any overloading. */
1841 buffer = SvPV_const(bufsv, blen);
1842 orig_blen_bytes = blen;
1843 doing_utf8 = DO_UTF8(bufsv);
1845 if (PerlIO_isutf8(IoIFP(io))) {
1846 if (!SvUTF8(bufsv)) {
1847 /* We don't modify the original scalar. */
1848 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1849 buffer = (char *) tmpbuf;
1853 else if (doing_utf8) {
1854 STRLEN tmplen = blen;
1855 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1858 buffer = (char *) tmpbuf;
1862 assert((char *)result == buffer);
1863 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1867 if (op_type == OP_SYSWRITE) {
1868 Size_t length = 0; /* This length is in characters. */
1874 /* The SV is bytes, and we've had to upgrade it. */
1875 blen_chars = orig_blen_bytes;
1877 /* The SV really is UTF-8. */
1878 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1879 /* Don't call sv_len_utf8 again because it will call magic
1880 or overloading a second time, and we might get back a
1881 different result. */
1882 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1884 /* It's safe, and it may well be cached. */
1885 blen_chars = sv_len_utf8(bufsv);
1893 length = blen_chars;
1895 #if Size_t_size > IVSIZE
1896 length = (Size_t)SvNVx(*++MARK);
1898 length = (Size_t)SvIVx(*++MARK);
1900 if ((SSize_t)length < 0) {
1902 DIE(aTHX_ "Negative length");
1907 offset = SvIVx(*++MARK);
1909 if (-offset > (IV)blen_chars) {
1911 DIE(aTHX_ "Offset outside string");
1913 offset += blen_chars;
1914 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1916 DIE(aTHX_ "Offset outside string");
1920 if (length > blen_chars - offset)
1921 length = blen_chars - offset;
1923 /* Here we convert length from characters to bytes. */
1924 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1925 /* Either we had to convert the SV, or the SV is magical, or
1926 the SV has overloading, in which case we can't or mustn't
1927 or mustn't call it again. */
1929 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1930 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1932 /* It's a real UTF-8 SV, and it's not going to change under
1933 us. Take advantage of any cache. */
1935 I32 len_I32 = length;
1937 /* Convert the start and end character positions to bytes.
1938 Remember that the second argument to sv_pos_u2b is relative
1940 sv_pos_u2b(bufsv, &start, &len_I32);
1947 buffer = buffer+offset;
1949 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1950 if (IoTYPE(io) == IoTYPE_SOCKET) {
1951 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1957 /* See the note at doio.c:do_print about filesize limits. --jhi */
1958 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1964 const int flags = SvIVx(*++MARK);
1967 char * const sockbuf = SvPVx(*++MARK, mlen);
1968 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1969 flags, (struct sockaddr *)sockbuf, mlen);
1973 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1978 DIE(aTHX_ PL_no_sock_func, "send");
1985 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
1988 #if Size_t_size > IVSIZE
2007 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
2009 gv = PL_last_in_gv = GvEGV(PL_argvgv);
2011 if (io && !IoIFP(io)) {
2012 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2014 IoFLAGS(io) &= ~IOf_START;
2015 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2016 sv_setpvn(GvSV(gv), "-", 1);
2017 SvSETMAGIC(GvSV(gv));
2019 else if (!nextargv(gv))
2024 gv = PL_last_in_gv; /* eof */
2027 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
2030 IO * const io = GvIO(gv);
2032 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
2034 XPUSHs(SvTIED_obj((SV*)io, mg));
2037 call_method("EOF", G_SCALAR);
2044 PUSHs(boolSV(!gv || do_eof(gv)));
2055 PL_last_in_gv = (GV*)POPs;
2058 if (gv && (io = GvIO(gv))) {
2059 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2062 XPUSHs(SvTIED_obj((SV*)io, mg));
2065 call_method("TELL", G_SCALAR);
2072 #if LSEEKSIZE > IVSIZE
2073 PUSHn( do_tell(gv) );
2075 PUSHi( do_tell(gv) );
2083 const int whence = POPi;
2084 #if LSEEKSIZE > IVSIZE
2085 const Off_t offset = (Off_t)SvNVx(POPs);
2087 const Off_t offset = (Off_t)SvIVx(POPs);
2090 GV * const gv = PL_last_in_gv = (GV*)POPs;
2093 if (gv && (io = GvIO(gv))) {
2094 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2097 XPUSHs(SvTIED_obj((SV*)io, mg));
2098 #if LSEEKSIZE > IVSIZE
2099 XPUSHs(sv_2mortal(newSVnv((NV) offset)));
2101 XPUSHs(sv_2mortal(newSViv(offset)));
2103 XPUSHs(sv_2mortal(newSViv(whence)));
2106 call_method("SEEK", G_SCALAR);
2113 if (PL_op->op_type == OP_SEEK)
2114 PUSHs(boolSV(do_seek(gv, offset, whence)));
2116 const Off_t sought = do_sysseek(gv, offset, whence);
2118 PUSHs(&PL_sv_undef);
2120 SV* const sv = sought ?
2121 #if LSEEKSIZE > IVSIZE
2126 : newSVpvn(zero_but_true, ZBTLEN);
2127 PUSHs(sv_2mortal(sv));
2137 /* There seems to be no consensus on the length type of truncate()
2138 * and ftruncate(), both off_t and size_t have supporters. In
2139 * general one would think that when using large files, off_t is
2140 * at least as wide as size_t, so using an off_t should be okay. */
2141 /* XXX Configure probe for the length type of *truncate() needed XXX */
2144 #if Off_t_size > IVSIZE
2149 /* Checking for length < 0 is problematic as the type might or
2150 * might not be signed: if it is not, clever compilers will moan. */
2151 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2158 if (PL_op->op_flags & OPf_SPECIAL) {
2159 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2168 TAINT_PROPER("truncate");
2169 if (!(fp = IoIFP(io))) {
2175 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2177 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2184 SV * const sv = POPs;
2187 if (SvTYPE(sv) == SVt_PVGV) {
2188 tmpgv = (GV*)sv; /* *main::FRED for example */
2189 goto do_ftruncate_gv;
2191 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2192 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
2193 goto do_ftruncate_gv;
2195 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2196 io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
2197 goto do_ftruncate_io;
2200 name = SvPV_nolen_const(sv);
2201 TAINT_PROPER("truncate");
2203 if (truncate(name, len) < 0)
2207 const int tmpfd = PerlLIO_open(name, O_RDWR);
2212 if (my_chsize(tmpfd, len) < 0)
2214 PerlLIO_close(tmpfd);
2223 SETERRNO(EBADF,RMS_IFI);
2231 SV * const argsv = POPs;
2232 const unsigned int func = POPu;
2233 const int optype = PL_op->op_type;
2234 GV * const gv = (GV*)POPs;
2235 IO * const io = gv ? GvIOn(gv) : NULL;
2239 if (!io || !argsv || !IoIFP(io)) {
2240 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2241 report_evil_fh(gv, io, PL_op->op_type);
2242 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2246 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2249 s = SvPV_force(argsv, len);
2250 need = IOCPARM_LEN(func);
2252 s = Sv_Grow(argsv, need + 1);
2253 SvCUR_set(argsv, need);
2256 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2259 retval = SvIV(argsv);
2260 s = INT2PTR(char*,retval); /* ouch */
2263 TAINT_PROPER(PL_op_desc[optype]);
2265 if (optype == OP_IOCTL)
2267 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2269 DIE(aTHX_ "ioctl is not implemented");
2273 DIE(aTHX_ "fcntl is not implemented");
2275 #if defined(OS2) && defined(__EMX__)
2276 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2278 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2282 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2284 if (s[SvCUR(argsv)] != 17)
2285 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2287 s[SvCUR(argsv)] = 0; /* put our null back */
2288 SvSETMAGIC(argsv); /* Assume it has changed */
2297 PUSHp(zero_but_true, ZBTLEN);
2310 const int argtype = POPi;
2311 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
2313 if (gv && (io = GvIO(gv)))
2319 /* XXX Looks to me like io is always NULL at this point */
2321 (void)PerlIO_flush(fp);
2322 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2325 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2326 report_evil_fh(gv, io, PL_op->op_type);
2328 SETERRNO(EBADF,RMS_IFI);
2333 DIE(aTHX_ PL_no_func, "flock()");
2343 const int protocol = POPi;
2344 const int type = POPi;
2345 const int domain = POPi;
2346 GV * const gv = (GV*)POPs;
2347 register IO * const io = gv ? GvIOn(gv) : NULL;
2351 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2352 report_evil_fh(gv, io, PL_op->op_type);
2353 if (io && IoIFP(io))
2354 do_close(gv, FALSE);
2355 SETERRNO(EBADF,LIB_INVARG);
2360 do_close(gv, FALSE);
2362 TAINT_PROPER("socket");
2363 fd = PerlSock_socket(domain, type, protocol);
2366 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2367 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2368 IoTYPE(io) = IoTYPE_SOCKET;
2369 if (!IoIFP(io) || !IoOFP(io)) {
2370 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2371 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2372 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2375 #if defined(HAS_FCNTL) && defined(F_SETFD)
2376 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2380 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2385 DIE(aTHX_ PL_no_sock_func, "socket");
2391 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2393 const int protocol = POPi;
2394 const int type = POPi;
2395 const int domain = POPi;
2396 GV * const gv2 = (GV*)POPs;
2397 GV * const gv1 = (GV*)POPs;
2398 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2399 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2402 if (!gv1 || !gv2 || !io1 || !io2) {
2403 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2405 report_evil_fh(gv1, io1, PL_op->op_type);
2407 report_evil_fh(gv1, io2, PL_op->op_type);
2409 if (io1 && IoIFP(io1))
2410 do_close(gv1, FALSE);
2411 if (io2 && IoIFP(io2))
2412 do_close(gv2, FALSE);
2417 do_close(gv1, FALSE);
2419 do_close(gv2, FALSE);
2421 TAINT_PROPER("socketpair");
2422 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2424 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2425 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2426 IoTYPE(io1) = IoTYPE_SOCKET;
2427 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2428 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2429 IoTYPE(io2) = IoTYPE_SOCKET;
2430 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2431 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2432 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2433 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2434 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2435 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2436 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2439 #if defined(HAS_FCNTL) && defined(F_SETFD)
2440 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2441 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2446 DIE(aTHX_ PL_no_sock_func, "socketpair");
2454 SV * const addrsv = POPs;
2455 /* OK, so on what platform does bind modify addr? */
2457 GV * const gv = (GV*)POPs;
2458 register IO * const io = GvIOn(gv);
2461 if (!io || !IoIFP(io))
2464 addr = SvPV_const(addrsv, len);
2465 TAINT_PROPER("bind");
2466 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2472 if (ckWARN(WARN_CLOSED))
2473 report_evil_fh(gv, io, PL_op->op_type);
2474 SETERRNO(EBADF,SS_IVCHAN);
2477 DIE(aTHX_ PL_no_sock_func, "bind");
2485 SV * const addrsv = POPs;
2486 GV * const gv = (GV*)POPs;
2487 register IO * const io = GvIOn(gv);
2491 if (!io || !IoIFP(io))
2494 addr = SvPV_const(addrsv, len);
2495 TAINT_PROPER("connect");
2496 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2502 if (ckWARN(WARN_CLOSED))
2503 report_evil_fh(gv, io, PL_op->op_type);
2504 SETERRNO(EBADF,SS_IVCHAN);
2507 DIE(aTHX_ PL_no_sock_func, "connect");
2515 const int backlog = POPi;
2516 GV * const gv = (GV*)POPs;
2517 register IO * const io = gv ? GvIOn(gv) : NULL;
2519 if (!gv || !io || !IoIFP(io))
2522 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2528 if (ckWARN(WARN_CLOSED))
2529 report_evil_fh(gv, io, PL_op->op_type);
2530 SETERRNO(EBADF,SS_IVCHAN);
2533 DIE(aTHX_ PL_no_sock_func, "listen");
2543 char namebuf[MAXPATHLEN];
2544 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2545 Sock_size_t len = sizeof (struct sockaddr_in);
2547 Sock_size_t len = sizeof namebuf;
2549 GV * const ggv = (GV*)POPs;
2550 GV * const ngv = (GV*)POPs;
2559 if (!gstio || !IoIFP(gstio))
2563 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2566 /* Some platforms indicate zero length when an AF_UNIX client is
2567 * not bound. Simulate a non-zero-length sockaddr structure in
2569 namebuf[0] = 0; /* sun_len */
2570 namebuf[1] = AF_UNIX; /* sun_family */
2578 do_close(ngv, FALSE);
2579 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2580 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2581 IoTYPE(nstio) = IoTYPE_SOCKET;
2582 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2583 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2584 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2585 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2588 #if defined(HAS_FCNTL) && defined(F_SETFD)
2589 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2593 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2594 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2596 #ifdef __SCO_VERSION__
2597 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2600 PUSHp(namebuf, len);
2604 if (ckWARN(WARN_CLOSED))
2605 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2606 SETERRNO(EBADF,SS_IVCHAN);
2612 DIE(aTHX_ PL_no_sock_func, "accept");
2620 const int how = POPi;
2621 GV * const gv = (GV*)POPs;
2622 register IO * const io = GvIOn(gv);
2624 if (!io || !IoIFP(io))
2627 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2631 if (ckWARN(WARN_CLOSED))
2632 report_evil_fh(gv, io, PL_op->op_type);
2633 SETERRNO(EBADF,SS_IVCHAN);
2636 DIE(aTHX_ PL_no_sock_func, "shutdown");
2644 const int optype = PL_op->op_type;
2645 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2646 const unsigned int optname = (unsigned int) POPi;
2647 const unsigned int lvl = (unsigned int) POPi;
2648 GV * const gv = (GV*)POPs;
2649 register IO * const io = GvIOn(gv);
2653 if (!io || !IoIFP(io))
2656 fd = PerlIO_fileno(IoIFP(io));
2660 (void)SvPOK_only(sv);
2664 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2671 #if defined(__SYMBIAN32__)
2672 # define SETSOCKOPT_OPTION_VALUE_T void *
2674 # define SETSOCKOPT_OPTION_VALUE_T const char *
2676 /* XXX TODO: We need to have a proper type (a Configure probe,
2677 * etc.) for what the C headers think of the third argument of
2678 * setsockopt(), the option_value read-only buffer: is it
2679 * a "char *", or a "void *", const or not. Some compilers
2680 * don't take kindly to e.g. assuming that "char *" implicitly
2681 * promotes to a "void *", or to explicitly promoting/demoting
2682 * consts to non/vice versa. The "const void *" is the SUS
2683 * definition, but that does not fly everywhere for the above
2685 SETSOCKOPT_OPTION_VALUE_T buf;
2689 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2693 aint = (int)SvIV(sv);
2694 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2697 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2706 if (ckWARN(WARN_CLOSED))
2707 report_evil_fh(gv, io, optype);
2708 SETERRNO(EBADF,SS_IVCHAN);
2713 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2721 const int optype = PL_op->op_type;
2722 GV * const gv = (GV*)POPs;
2723 register IO * const io = GvIOn(gv);
2728 if (!io || !IoIFP(io))
2731 sv = sv_2mortal(newSV(257));
2732 (void)SvPOK_only(sv);
2736 fd = PerlIO_fileno(IoIFP(io));
2738 case OP_GETSOCKNAME:
2739 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2742 case OP_GETPEERNAME:
2743 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2745 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2747 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";
2748 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2749 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2750 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2751 sizeof(u_short) + sizeof(struct in_addr))) {
2758 #ifdef BOGUS_GETNAME_RETURN
2759 /* Interactive Unix, getpeername() and getsockname()
2760 does not return valid namelen */
2761 if (len == BOGUS_GETNAME_RETURN)
2762 len = sizeof(struct sockaddr);
2770 if (ckWARN(WARN_CLOSED))
2771 report_evil_fh(gv, io, optype);
2772 SETERRNO(EBADF,SS_IVCHAN);
2777 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2792 if (PL_op->op_flags & OPf_REF) {
2794 if (PL_op->op_type == OP_LSTAT) {
2795 if (gv != PL_defgv) {
2796 do_fstat_warning_check:
2797 if (ckWARN(WARN_IO))
2798 Perl_warner(aTHX_ packWARN(WARN_IO),
2799 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2800 } else if (PL_laststype != OP_LSTAT)
2801 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2805 if (gv != PL_defgv) {
2806 PL_laststype = OP_STAT;
2808 sv_setpvn(PL_statname, "", 0);
2815 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2816 } else if (IoDIRP(io)) {
2819 PerlLIO_fstat(dirfd(IoDIRP(io)), &PL_statcache);
2821 DIE(aTHX_ PL_no_func, "dirfd");
2824 PL_laststatval = -1;
2830 if (PL_laststatval < 0) {
2831 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2832 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2837 SV* const sv = POPs;
2838 if (SvTYPE(sv) == SVt_PVGV) {
2841 } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2843 if (PL_op->op_type == OP_LSTAT)
2844 goto do_fstat_warning_check;
2846 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2848 if (PL_op->op_type == OP_LSTAT)
2849 goto do_fstat_warning_check;
2850 goto do_fstat_have_io;
2853 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2855 PL_laststype = PL_op->op_type;
2856 if (PL_op->op_type == OP_LSTAT)
2857 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2859 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2860 if (PL_laststatval < 0) {
2861 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2862 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2868 if (gimme != G_ARRAY) {
2869 if (gimme != G_VOID)
2870 XPUSHs(boolSV(max));
2876 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2877 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2878 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2879 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2880 #if Uid_t_size > IVSIZE
2881 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2883 # if Uid_t_sign <= 0
2884 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2886 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2889 #if Gid_t_size > IVSIZE
2890 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2892 # if Gid_t_sign <= 0
2893 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2895 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2898 #ifdef USE_STAT_RDEV
2899 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2901 PUSHs(sv_2mortal(newSVpvs("")));
2903 #if Off_t_size > IVSIZE
2904 PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
2906 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2909 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2910 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2911 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2913 PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2914 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2915 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
2917 #ifdef USE_STAT_BLOCKS
2918 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2919 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2921 PUSHs(sv_2mortal(newSVpvs("")));
2922 PUSHs(sv_2mortal(newSVpvs("")));
2928 /* This macro is used by the stacked filetest operators :
2929 * if the previous filetest failed, short-circuit and pass its value.
2930 * Else, discard it from the stack and continue. --rgs
2932 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2933 if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
2934 else { (void)POPs; PUTBACK; } \
2941 /* Not const, because things tweak this below. Not bool, because there's
2942 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2943 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2944 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2945 /* Giving some sort of initial value silences compilers. */
2947 int access_mode = R_OK;
2949 int access_mode = 0;
2952 /* access_mode is never used, but leaving use_access in makes the
2953 conditional compiling below much clearer. */
2956 int stat_mode = S_IRUSR;
2958 bool effective = FALSE;
2961 STACKED_FTEST_CHECK;
2963 switch (PL_op->op_type) {
2965 #if !(defined(HAS_ACCESS) && defined(R_OK))
2971 #if defined(HAS_ACCESS) && defined(W_OK)
2976 stat_mode = S_IWUSR;
2980 #if defined(HAS_ACCESS) && defined(X_OK)
2985 stat_mode = S_IXUSR;
2989 #ifdef PERL_EFF_ACCESS
2992 stat_mode = S_IWUSR;
2996 #ifndef PERL_EFF_ACCESS
3004 #ifdef PERL_EFF_ACCESS
3009 stat_mode = S_IXUSR;
3015 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3016 const char *name = POPpx;
3018 # ifdef PERL_EFF_ACCESS
3019 result = PERL_EFF_ACCESS(name, access_mode);
3021 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3027 result = access(name, access_mode);
3029 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3044 if (cando(stat_mode, effective, &PL_statcache))
3053 const int op_type = PL_op->op_type;
3055 STACKED_FTEST_CHECK;
3060 if (op_type == OP_FTIS)
3063 /* You can't dTARGET inside OP_FTIS, because you'll get
3064 "panic: pad_sv po" - the op is not flagged to have a target. */
3068 #if Off_t_size > IVSIZE
3069 PUSHn(PL_statcache.st_size);
3071 PUSHi(PL_statcache.st_size);
3075 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3078 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3081 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3094 /* I believe that all these three are likely to be defined on most every
3095 system these days. */
3097 if(PL_op->op_type == OP_FTSUID)
3101 if(PL_op->op_type == OP_FTSGID)
3105 if(PL_op->op_type == OP_FTSVTX)
3109 STACKED_FTEST_CHECK;
3114 switch (PL_op->op_type) {
3116 if (PL_statcache.st_uid == PL_uid)
3120 if (PL_statcache.st_uid == PL_euid)
3124 if (PL_statcache.st_size == 0)
3128 if (S_ISSOCK(PL_statcache.st_mode))
3132 if (S_ISCHR(PL_statcache.st_mode))
3136 if (S_ISBLK(PL_statcache.st_mode))
3140 if (S_ISREG(PL_statcache.st_mode))
3144 if (S_ISDIR(PL_statcache.st_mode))
3148 if (S_ISFIFO(PL_statcache.st_mode))
3153 if (PL_statcache.st_mode & S_ISUID)
3159 if (PL_statcache.st_mode & S_ISGID)
3165 if (PL_statcache.st_mode & S_ISVTX)
3176 I32 result = my_lstat();
3180 if (S_ISLNK(PL_statcache.st_mode))
3193 STACKED_FTEST_CHECK;
3195 if (PL_op->op_flags & OPf_REF)
3197 else if (isGV(TOPs))
3199 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3200 gv = (GV*)SvRV(POPs);
3202 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3204 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3205 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3206 else if (tmpsv && SvOK(tmpsv)) {
3207 const char *tmps = SvPV_nolen_const(tmpsv);
3215 if (PerlLIO_isatty(fd))
3220 #if defined(atarist) /* this will work with atariST. Configure will
3221 make guesses for other systems. */
3222 # define FILE_base(f) ((f)->_base)
3223 # define FILE_ptr(f) ((f)->_ptr)
3224 # define FILE_cnt(f) ((f)->_cnt)
3225 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3236 register STDCHAR *s;
3242 STACKED_FTEST_CHECK;
3244 if (PL_op->op_flags & OPf_REF)
3246 else if (isGV(TOPs))
3248 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3249 gv = (GV*)SvRV(POPs);
3255 if (gv == PL_defgv) {
3257 io = GvIO(PL_statgv);
3260 goto really_filename;
3265 PL_laststatval = -1;
3266 sv_setpvn(PL_statname, "", 0);
3267 io = GvIO(PL_statgv);
3269 if (io && IoIFP(io)) {
3270 if (! PerlIO_has_base(IoIFP(io)))
3271 DIE(aTHX_ "-T and -B not implemented on filehandles");
3272 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3273 if (PL_laststatval < 0)
3275 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3276 if (PL_op->op_type == OP_FTTEXT)
3281 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3282 i = PerlIO_getc(IoIFP(io));
3284 (void)PerlIO_ungetc(IoIFP(io),i);
3286 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3288 len = PerlIO_get_bufsiz(IoIFP(io));
3289 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3290 /* sfio can have large buffers - limit to 512 */
3295 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3297 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3299 SETERRNO(EBADF,RMS_IFI);
3307 PL_laststype = OP_STAT;
3308 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3309 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3310 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3312 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3315 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3316 if (PL_laststatval < 0) {
3317 (void)PerlIO_close(fp);
3320 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3321 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3322 (void)PerlIO_close(fp);
3324 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3325 RETPUSHNO; /* special case NFS directories */
3326 RETPUSHYES; /* null file is anything */
3331 /* now scan s to look for textiness */
3332 /* XXX ASCII dependent code */
3334 #if defined(DOSISH) || defined(USEMYBINMODE)
3335 /* ignore trailing ^Z on short files */
3336 if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3340 for (i = 0; i < len; i++, s++) {
3341 if (!*s) { /* null never allowed in text */
3346 else if (!(isPRINT(*s) || isSPACE(*s)))
3349 else if (*s & 128) {
3351 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3354 /* utf8 characters don't count as odd */
3355 if (UTF8_IS_START(*s)) {
3356 int ulen = UTF8SKIP(s);
3357 if (ulen < len - i) {
3359 for (j = 1; j < ulen; j++) {
3360 if (!UTF8_IS_CONTINUATION(s[j]))
3363 --ulen; /* loop does extra increment */
3373 *s != '\n' && *s != '\r' && *s != '\b' &&
3374 *s != '\t' && *s != '\f' && *s != 27)
3379 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3390 const char *tmps = NULL;
3394 SV * const sv = POPs;
3395 if (PL_op->op_flags & OPf_SPECIAL) {
3396 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3398 else if (SvTYPE(sv) == SVt_PVGV) {
3401 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
3405 tmps = SvPVx_nolen_const(sv);
3409 if( !gv && (!tmps || !*tmps) ) {
3410 HV * const table = GvHVn(PL_envgv);
3413 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3414 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3416 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3421 deprecate("chdir('') or chdir(undef) as chdir()");
3422 tmps = SvPV_nolen_const(*svp);
3426 TAINT_PROPER("chdir");
3431 TAINT_PROPER("chdir");
3434 IO* const io = GvIO(gv);
3437 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3439 else if (IoDIRP(io)) {
3441 PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0);
3443 DIE(aTHX_ PL_no_func, "dirfd");
3447 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3448 report_evil_fh(gv, io, PL_op->op_type);
3449 SETERRNO(EBADF, RMS_IFI);
3454 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3455 report_evil_fh(gv, io, PL_op->op_type);
3456 SETERRNO(EBADF,RMS_IFI);
3460 DIE(aTHX_ PL_no_func, "fchdir");
3464 PUSHi( PerlDir_chdir(tmps) >= 0 );
3466 /* Clear the DEFAULT element of ENV so we'll get the new value
3468 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3475 dVAR; dSP; dMARK; dTARGET;
3476 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3487 char * const tmps = POPpx;
3488 TAINT_PROPER("chroot");
3489 PUSHi( chroot(tmps) >= 0 );
3492 DIE(aTHX_ PL_no_func, "chroot");
3500 const char * const tmps2 = POPpconstx;
3501 const char * const tmps = SvPV_nolen_const(TOPs);
3502 TAINT_PROPER("rename");
3504 anum = PerlLIO_rename(tmps, tmps2);
3506 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3507 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3510 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3511 (void)UNLINK(tmps2);
3512 if (!(anum = link(tmps, tmps2)))
3513 anum = UNLINK(tmps);
3521 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3525 const int op_type = PL_op->op_type;
3529 if (op_type == OP_LINK)
3530 DIE(aTHX_ PL_no_func, "link");
3532 # ifndef HAS_SYMLINK
3533 if (op_type == OP_SYMLINK)
3534 DIE(aTHX_ PL_no_func, "symlink");
3538 const char * const tmps2 = POPpconstx;
3539 const char * const tmps = SvPV_nolen_const(TOPs);
3540 TAINT_PROPER(PL_op_desc[op_type]);
3542 # if defined(HAS_LINK)
3543 # if defined(HAS_SYMLINK)
3544 /* Both present - need to choose which. */
3545 (op_type == OP_LINK) ?
3546 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3548 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3549 PerlLIO_link(tmps, tmps2);
3552 # if defined(HAS_SYMLINK)
3553 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3554 symlink(tmps, tmps2);
3559 SETi( result >= 0 );
3566 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3577 char buf[MAXPATHLEN];
3580 #ifndef INCOMPLETE_TAINTS
3584 len = readlink(tmps, buf, sizeof(buf) - 1);
3592 RETSETUNDEF; /* just pretend it's a normal file */
3596 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3598 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3600 char * const save_filename = filename;
3605 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3607 Newx(cmdline, size, char);
3608 my_strlcpy(cmdline, cmd, size);
3609 my_strlcat(cmdline, " ", size);
3610 for (s = cmdline + strlen(cmdline); *filename; ) {
3614 if (s - cmdline < size)
3615 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3616 myfp = PerlProc_popen(cmdline, "r");
3620 SV * const tmpsv = sv_newmortal();
3621 /* Need to save/restore 'PL_rs' ?? */
3622 s = sv_gets(tmpsv, myfp, 0);
3623 (void)PerlProc_pclose(myfp);
3627 #ifdef HAS_SYS_ERRLIST
3632 /* you don't see this */
3633 const char * const errmsg =
3634 #ifdef HAS_SYS_ERRLIST
3642 if (instr(s, errmsg)) {
3649 #define EACCES EPERM
3651 if (instr(s, "cannot make"))
3652 SETERRNO(EEXIST,RMS_FEX);
3653 else if (instr(s, "existing file"))
3654 SETERRNO(EEXIST,RMS_FEX);
3655 else if (instr(s, "ile exists"))
3656 SETERRNO(EEXIST,RMS_FEX);
3657 else if (instr(s, "non-exist"))
3658 SETERRNO(ENOENT,RMS_FNF);
3659 else if (instr(s, "does not exist"))
3660 SETERRNO(ENOENT,RMS_FNF);
3661 else if (instr(s, "not empty"))
3662 SETERRNO(EBUSY,SS_DEVOFFLINE);
3663 else if (instr(s, "cannot access"))
3664 SETERRNO(EACCES,RMS_PRV);
3666 SETERRNO(EPERM,RMS_PRV);
3669 else { /* some mkdirs return no failure indication */
3670 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3671 if (PL_op->op_type == OP_RMDIR)
3676 SETERRNO(EACCES,RMS_PRV); /* a guess */
3685 /* This macro removes trailing slashes from a directory name.
3686 * Different operating and file systems take differently to
3687 * trailing slashes. According to POSIX 1003.1 1996 Edition
3688 * any number of trailing slashes should be allowed.
3689 * Thusly we snip them away so that even non-conforming
3690 * systems are happy.
3691 * We should probably do this "filtering" for all
3692 * the functions that expect (potentially) directory names:
3693 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3694 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3696 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3697 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3700 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3701 (tmps) = savepvn((tmps), (len)); \
3711 const int mode = (MAXARG > 1) ? POPi : 0777;
3713 TRIMSLASHES(tmps,len,copy);
3715 TAINT_PROPER("mkdir");
3717 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3721 SETi( dooneliner("mkdir", tmps) );
3722 oldumask = PerlLIO_umask(0);
3723 PerlLIO_umask(oldumask);
3724 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3739 TRIMSLASHES(tmps,len,copy);
3740 TAINT_PROPER("rmdir");
3742 SETi( PerlDir_rmdir(tmps) >= 0 );
3744 SETi( dooneliner("rmdir", tmps) );
3751 /* Directory calls. */
3755 #if defined(Direntry_t) && defined(HAS_READDIR)
3757 const char * const dirname = POPpconstx;
3758 GV * const gv = (GV*)POPs;
3759 register IO * const io = GvIOn(gv);
3765 PerlDir_close(IoDIRP(io));
3766 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3772 SETERRNO(EBADF,RMS_DIR);
3775 DIE(aTHX_ PL_no_dir_func, "opendir");
3781 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3782 DIE(aTHX_ PL_no_dir_func, "readdir");
3784 #if !defined(I_DIRENT) && !defined(VMS)
3785 Direntry_t *readdir (DIR *);
3791 const I32 gimme = GIMME;
3792 GV * const gv = (GV *)POPs;
3793 register const Direntry_t *dp;
3794 register IO * const io = GvIOn(gv);
3796 if (!io || !IoDIRP(io)) {
3797 if(ckWARN(WARN_IO)) {
3798 Perl_warner(aTHX_ packWARN(WARN_IO),
3799 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3805 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3809 sv = newSVpvn(dp->d_name, dp->d_namlen);
3811 sv = newSVpv(dp->d_name, 0);
3813 #ifndef INCOMPLETE_TAINTS
3814 if (!(IoFLAGS(io) & IOf_UNTAINT))
3817 XPUSHs(sv_2mortal(sv));
3818 } while (gimme == G_ARRAY);
3820 if (!dp && gimme != G_ARRAY)
3827 SETERRNO(EBADF,RMS_ISI);
3828 if (GIMME == G_ARRAY)
3837 #if defined(HAS_TELLDIR) || defined(telldir)
3839 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3840 /* XXX netbsd still seemed to.
3841 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3842 --JHI 1999-Feb-02 */
3843 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3844 long telldir (DIR *);
3846 GV * const gv = (GV*)POPs;
3847 register IO * const io = GvIOn(gv);
3849 if (!io || !IoDIRP(io)) {
3850 if(ckWARN(WARN_IO)) {
3851 Perl_warner(aTHX_ packWARN(WARN_IO),
3852 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3857 PUSHi( PerlDir_tell(IoDIRP(io)) );
3861 SETERRNO(EBADF,RMS_ISI);
3864 DIE(aTHX_ PL_no_dir_func, "telldir");
3870 #if defined(HAS_SEEKDIR) || defined(seekdir)
3872 const long along = POPl;
3873 GV * const gv = (GV*)POPs;
3874 register IO * const io = GvIOn(gv);
3876 if (!io || !IoDIRP(io)) {
3877 if(ckWARN(WARN_IO)) {
3878 Perl_warner(aTHX_ packWARN(WARN_IO),
3879 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3883 (void)PerlDir_seek(IoDIRP(io), along);
3888 SETERRNO(EBADF,RMS_ISI);
3891 DIE(aTHX_ PL_no_dir_func, "seekdir");
3897 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3899 GV * const gv = (GV*)POPs;
3900 register IO * const io = GvIOn(gv);
3902 if (!io || !IoDIRP(io)) {
3903 if(ckWARN(WARN_IO)) {
3904 Perl_warner(aTHX_ packWARN(WARN_IO),
3905 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3909 (void)PerlDir_rewind(IoDIRP(io));
3913 SETERRNO(EBADF,RMS_ISI);
3916 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3922 #if defined(Direntry_t) && defined(HAS_READDIR)
3924 GV * const gv = (GV*)POPs;
3925 register IO * const io = GvIOn(gv);
3927 if (!io || !IoDIRP(io)) {
3928 if(ckWARN(WARN_IO)) {
3929 Perl_warner(aTHX_ packWARN(WARN_IO),
3930 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3934 #ifdef VOID_CLOSEDIR
3935 PerlDir_close(IoDIRP(io));
3937 if (PerlDir_close(IoDIRP(io)) < 0) {
3938 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3947 SETERRNO(EBADF,RMS_IFI);
3950 DIE(aTHX_ PL_no_dir_func, "closedir");
3954 /* Process control. */
3963 PERL_FLUSHALL_FOR_CHILD;
3964 childpid = PerlProc_fork();
3968 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3970 SvREADONLY_off(GvSV(tmpgv));
3971 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3972 SvREADONLY_on(GvSV(tmpgv));
3974 #ifdef THREADS_HAVE_PIDS
3975 PL_ppid = (IV)getppid();
3977 #ifdef PERL_USES_PL_PIDSTATUS
3978 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3984 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3989 PERL_FLUSHALL_FOR_CHILD;
3990 childpid = PerlProc_fork();
3996 DIE(aTHX_ PL_no_func, "fork");
4003 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4008 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4009 childpid = wait4pid(-1, &argflags, 0);
4011 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4016 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4017 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4018 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4020 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4025 DIE(aTHX_ PL_no_func, "wait");
4031 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4033 const int optype = POPi;
4034 const Pid_t pid = TOPi;
4038 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4039 result = wait4pid(pid, &argflags, optype);
4041 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4046 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4047 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4048 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4050 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4055 DIE(aTHX_ PL_no_func, "waitpid");
4061 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4067 while (++MARK <= SP) {
4068 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4073 TAINT_PROPER("system");
4075 PERL_FLUSHALL_FOR_CHILD;
4076 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4082 if (PerlProc_pipe(pp) >= 0)
4084 while ((childpid = PerlProc_fork()) == -1) {
4085 if (errno != EAGAIN) {
4090 PerlLIO_close(pp[0]);
4091 PerlLIO_close(pp[1]);
4098 Sigsave_t ihand,qhand; /* place to save signals during system() */
4102 PerlLIO_close(pp[1]);
4104 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4105 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4108 result = wait4pid(childpid, &status, 0);
4109 } while (result == -1 && errno == EINTR);
4111 (void)rsignal_restore(SIGINT, &ihand);
4112 (void)rsignal_restore(SIGQUIT, &qhand);
4114 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4115 do_execfree(); /* free any memory child malloced on fork */
4122 while (n < sizeof(int)) {
4123 n1 = PerlLIO_read(pp[0],
4124 (void*)(((char*)&errkid)+n),
4130 PerlLIO_close(pp[0]);
4131 if (n) { /* Error */
4132 if (n != sizeof(int))
4133 DIE(aTHX_ "panic: kid popen errno read");
4134 errno = errkid; /* Propagate errno from kid */
4135 STATUS_NATIVE_CHILD_SET(-1);
4138 XPUSHi(STATUS_CURRENT);
4142 PerlLIO_close(pp[0]);
4143 #if defined(HAS_FCNTL) && defined(F_SETFD)
4144 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4147 if (PL_op->op_flags & OPf_STACKED) {
4148 SV * const really = *++MARK;
4149 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4151 else if (SP - MARK != 1)
4152 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4154 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4158 #else /* ! FORK or VMS or OS/2 */
4161 if (PL_op->op_flags & OPf_STACKED) {
4162 SV * const really = *++MARK;
4163 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4164 value = (I32)do_aspawn(really, MARK, SP);
4166 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4169 else if (SP - MARK != 1) {
4170 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4171 value = (I32)do_aspawn(NULL, MARK, SP);
4173 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4177 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4179 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4181 STATUS_NATIVE_CHILD_SET(value);
4184 XPUSHi(result ? value : STATUS_CURRENT);
4185 #endif /* !FORK or VMS */
4191 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4196 while (++MARK <= SP) {
4197 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4202 TAINT_PROPER("exec");
4204 PERL_FLUSHALL_FOR_CHILD;
4205 if (PL_op->op_flags & OPf_STACKED) {
4206 SV * const really = *++MARK;
4207 value = (I32)do_aexec(really, MARK, SP);
4209 else if (SP - MARK != 1)
4211 value = (I32)vms_do_aexec(NULL, MARK, SP);
4215 (void ) do_aspawn(NULL, MARK, SP);
4219 value = (I32)do_aexec(NULL, MARK, SP);
4224 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4227 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4230 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4244 # ifdef THREADS_HAVE_PIDS
4245 if (PL_ppid != 1 && getppid() == 1)
4246 /* maybe the parent process has died. Refresh ppid cache */
4250 XPUSHi( getppid() );
4254 DIE(aTHX_ PL_no_func, "getppid");
4263 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4266 pgrp = (I32)BSD_GETPGRP(pid);
4268 if (pid != 0 && pid != PerlProc_getpid())
4269 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4275 DIE(aTHX_ PL_no_func, "getpgrp()");
4294 TAINT_PROPER("setpgrp");
4296 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4298 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4299 || (pid != 0 && pid != PerlProc_getpid()))
4301 DIE(aTHX_ "setpgrp can't take arguments");
4303 SETi( setpgrp() >= 0 );
4304 #endif /* USE_BSDPGRP */
4307 DIE(aTHX_ PL_no_func, "setpgrp()");
4313 #ifdef HAS_GETPRIORITY
4315 const int who = POPi;
4316 const int which = TOPi;
4317 SETi( getpriority(which, who) );
4320 DIE(aTHX_ PL_no_func, "getpriority()");
4326 #ifdef HAS_SETPRIORITY
4328 const int niceval = POPi;
4329 const int who = POPi;
4330 const int which = TOPi;
4331 TAINT_PROPER("setpriority");
4332 SETi( setpriority(which, who, niceval) >= 0 );
4335 DIE(aTHX_ PL_no_func, "setpriority()");
4345 XPUSHn( time(NULL) );
4347 XPUSHi( time(NULL) );
4359 (void)PerlProc_times(&PL_timesbuf);
4361 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4362 /* struct tms, though same data */
4366 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
4367 if (GIMME == G_ARRAY) {
4368 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
4369 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
4370 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
4376 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4378 if (GIMME == G_ARRAY) {
4379 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4380 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4381 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4385 DIE(aTHX_ "times not implemented");
4387 #endif /* HAS_TIMES */
4390 #ifdef LOCALTIME_EDGECASE_BROKEN
4391 static struct tm *S_my_localtime (pTHX_ Time_t *tp)
4396 /* No workarounds in the valid range */
4397 if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4398 return (localtime (tp));
4400 /* This edge case is to workaround the undefined behaviour, where the
4401 * TIMEZONE makes the time go beyond the defined range.
4402 * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4403 * If there is a negative offset in TZ, like MET-1METDST, some broken
4404 * implementations of localtime () (like AIX 5.2) barf with bogus
4406 * 0x7fffffff gmtime 2038-01-19 03:14:07
4407 * 0x7fffffff localtime 1901-12-13 21:45:51
4408 * 0x7fffffff mylocaltime 2038-01-19 04:14:07
4409 * 0x3c19137f gmtime 2001-12-13 20:45:51
4410 * 0x3c19137f localtime 2001-12-13 21:45:51
4411 * 0x3c19137f mylocaltime 2001-12-13 21:45:51
4412 * Given that legal timezones are typically between GMT-12 and GMT+12
4413 * we turn back the clock 23 hours before calling the localtime
4414 * function, and add those to the return value. This will never cause
4415 * day wrapping problems, since the edge case is Tue Jan *19*
4417 T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4420 if (P->tm_hour >= 24) {
4422 P->tm_mday++; /* 18 -> 19 */
4423 P->tm_wday++; /* Mon -> Tue */
4424 P->tm_yday++; /* 18 -> 19 */
4427 } /* S_my_localtime */
4435 const struct tm *tmbuf;
4436 static const char * const dayname[] =
4437 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4438 static const char * const monname[] =
4439 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4440 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4446 when = (Time_t)SvNVx(POPs);
4448 when = (Time_t)SvIVx(POPs);
4451 if (PL_op->op_type == OP_LOCALTIME)
4452 #ifdef LOCALTIME_EDGECASE_BROKEN
4453 tmbuf = S_my_localtime(aTHX_ &when);
4455 tmbuf = localtime(&when);
4458 tmbuf = gmtime(&when);
4460 if (GIMME != G_ARRAY) {
4466 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4467 dayname[tmbuf->tm_wday],
4468 monname[tmbuf->tm_mon],
4473 tmbuf->tm_year + 1900);
4474 PUSHs(sv_2mortal(tsv));
4479 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4480 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4481 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4482 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4483 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4484 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4485 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4486 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4487 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4498 anum = alarm((unsigned int)anum);
4505 DIE(aTHX_ PL_no_func, "alarm");
4516 (void)time(&lasttime);
4521 PerlProc_sleep((unsigned int)duration);
4524 XPUSHi(when - lasttime);
4528 /* Shared memory. */
4529 /* Merged with some message passing. */
4533 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4534 dVAR; dSP; dMARK; dTARGET;
4535 const int op_type = PL_op->op_type;
4540 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4543 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4546 value = (I32)(do_semop(MARK, SP) >= 0);
4549 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4565 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4566 dVAR; dSP; dMARK; dTARGET;
4567 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4574 DIE(aTHX_ "System V IPC is not implemented on this machine");
4580 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4581 dVAR; dSP; dMARK; dTARGET;
4582 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4590 PUSHp(zero_but_true, ZBTLEN);
4598 /* I can't const this further without getting warnings about the types of
4599 various arrays passed in from structures. */
4601 S_space_join_names_mortal(pTHX_ char *const *array)
4605 if (array && *array) {
4606 target = sv_2mortal(newSVpvs(""));
4608 sv_catpv(target, *array);
4611 sv_catpvs(target, " ");
4614 target = sv_mortalcopy(&PL_sv_no);
4619 /* Get system info. */
4623 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4625 I32 which = PL_op->op_type;
4626 register char **elem;
4628 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4629 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4630 struct hostent *gethostbyname(Netdb_name_t);
4631 struct hostent *gethostent(void);
4633 struct hostent *hent;
4637 if (which == OP_GHBYNAME) {
4638 #ifdef HAS_GETHOSTBYNAME
4639 const char* const name = POPpbytex;
4640 hent = PerlSock_gethostbyname(name);
4642 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4645 else if (which == OP_GHBYADDR) {
4646 #ifdef HAS_GETHOSTBYADDR
4647 const int addrtype = POPi;
4648 SV * const addrsv = POPs;
4650 Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4652 hent = PerlSock_gethostbyaddr((const char*)addr, (Netdb_hlen_t) addrlen, addrtype);
4654 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4658 #ifdef HAS_GETHOSTENT
4659 hent = PerlSock_gethostent();
4661 DIE(aTHX_ PL_no_sock_func, "gethostent");
4664 #ifdef HOST_NOT_FOUND
4666 #ifdef USE_REENTRANT_API
4667 # ifdef USE_GETHOSTENT_ERRNO
4668 h_errno = PL_reentrant_buffer->_gethostent_errno;
4671 STATUS_UNIX_SET(h_errno);
4675 if (GIMME != G_ARRAY) {
4676 PUSHs(sv = sv_newmortal());
4678 if (which == OP_GHBYNAME) {
4680 sv_setpvn(sv, hent->h_addr, hent->h_length);
4683 sv_setpv(sv, (char*)hent->h_name);
4689 PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
4690 PUSHs(space_join_names_mortal(hent->h_aliases));
4691 PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
4692 len = hent->h_length;
4693 PUSHs(sv_2mortal(newSViv((IV)len)));
4695 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4696 XPUSHs(sv_2mortal(newSVpvn(*elem, len)));
4700 PUSHs(newSVpvn(hent->h_addr, len));
4702 PUSHs(sv_mortalcopy(&PL_sv_no));
4707 DIE(aTHX_ PL_no_sock_func, "gethostent");
4713 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4715 I32 which = PL_op->op_type;
4717 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4718 struct netent *getnetbyaddr(Netdb_net_t, int);
4719 struct netent *getnetbyname(Netdb_name_t);
4720 struct netent *getnetent(void);
4722 struct netent *nent;
4724 if (which == OP_GNBYNAME){
4725 #ifdef HAS_GETNETBYNAME
4726 const char * const name = POPpbytex;
4727 nent = PerlSock_getnetbyname(name);
4729 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4732 else if (which == OP_GNBYADDR) {
4733 #ifdef HAS_GETNETBYADDR
4734 const int addrtype = POPi;
4735 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4736 nent = PerlSock_getnetbyaddr(addr, addrtype);
4738 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4742 #ifdef HAS_GETNETENT
4743 nent = PerlSock_getnetent();
4745 DIE(aTHX_ PL_no_sock_func, "getnetent");
4748 #ifdef HOST_NOT_FOUND
4750 #ifdef USE_REENTRANT_API
4751 # ifdef USE_GETNETENT_ERRNO
4752 h_errno = PL_reentrant_buffer->_getnetent_errno;
4755 STATUS_UNIX_SET(h_errno);
4760 if (GIMME != G_ARRAY) {
4761 PUSHs(sv = sv_newmortal());
4763 if (which == OP_GNBYNAME)
4764 sv_setiv(sv, (IV)nent->n_net);
4766 sv_setpv(sv, nent->n_name);
4772 PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
4773 PUSHs(space_join_names_mortal(nent->n_aliases));
4774 PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
4775 PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
4780 DIE(aTHX_ PL_no_sock_func, "getnetent");
4786 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4788 I32 which = PL_op->op_type;
4790 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4791 struct protoent *getprotobyname(Netdb_name_t);
4792 struct protoent *getprotobynumber(int);
4793 struct protoent *getprotoent(void);
4795 struct protoent *pent;
4797 if (which == OP_GPBYNAME) {
4798 #ifdef HAS_GETPROTOBYNAME
4799 const char* const name = POPpbytex;
4800 pent = PerlSock_getprotobyname(name);
4802 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4805 else if (which == OP_GPBYNUMBER) {
4806 #ifdef HAS_GETPROTOBYNUMBER
4807 const int number = POPi;
4808 pent = PerlSock_getprotobynumber(number);
4810 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4814 #ifdef HAS_GETPROTOENT
4815 pent = PerlSock_getprotoent();
4817 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4821 if (GIMME != G_ARRAY) {
4822 PUSHs(sv = sv_newmortal());
4824 if (which == OP_GPBYNAME)
4825 sv_setiv(sv, (IV)pent->p_proto);
4827 sv_setpv(sv, pent->p_name);
4833 PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
4834 PUSHs(space_join_names_mortal(pent->p_aliases));
4835 PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
4840 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4846 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4848 I32 which = PL_op->op_type;
4850 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4851 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4852 struct servent *getservbyport(int, Netdb_name_t);
4853 struct servent *getservent(void);
4855 struct servent *sent;
4857 if (which == OP_GSBYNAME) {
4858 #ifdef HAS_GETSERVBYNAME
4859 const char * const proto = POPpbytex;
4860 const char * const name = POPpbytex;
4861 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4863 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4866 else if (which == OP_GSBYPORT) {
4867 #ifdef HAS_GETSERVBYPORT
4868 const char * const proto = POPpbytex;
4869 unsigned short port = (unsigned short)POPu;
4871 port = PerlSock_htons(port);
4873 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4875 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4879 #ifdef HAS_GETSERVENT
4880 sent = PerlSock_getservent();
4882 DIE(aTHX_ PL_no_sock_func, "getservent");
4886 if (GIMME != G_ARRAY) {
4887 PUSHs(sv = sv_newmortal());
4889 if (which == OP_GSBYNAME) {
4891 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4893 sv_setiv(sv, (IV)(sent->s_port));
4897 sv_setpv(sv, sent->s_name);
4903 PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
4904 PUSHs(space_join_names_mortal(sent->s_aliases));
4906 PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
4908 PUSHs(sv_2mortal(newSViv((IV)(sent->s_port))));
4910 PUSHs(sv_2mortal(newSVpv(sent->s_proto, 0)));
4915 DIE(aTHX_ PL_no_sock_func, "getservent");
4921 #ifdef HAS_SETHOSTENT
4923 PerlSock_sethostent(TOPi);
4926 DIE(aTHX_ PL_no_sock_func, "sethostent");
4932 #ifdef HAS_SETNETENT
4934 PerlSock_setnetent(TOPi);
4937 DIE(aTHX_ PL_no_sock_func, "setnetent");
4943 #ifdef HAS_SETPROTOENT
4945 PerlSock_setprotoent(TOPi);
4948 DIE(aTHX_ PL_no_sock_func, "setprotoent");
4954 #ifdef HAS_SETSERVENT
4956 PerlSock_setservent(TOPi);
4959 DIE(aTHX_ PL_no_sock_func, "setservent");
4965 #ifdef HAS_ENDHOSTENT
4967 PerlSock_endhostent();
4971 DIE(aTHX_ PL_no_sock_func, "endhostent");
4977 #ifdef HAS_ENDNETENT
4979 PerlSock_endnetent();
4983 DIE(aTHX_ PL_no_sock_func, "endnetent");
4989 #ifdef HAS_ENDPROTOENT
4991 PerlSock_endprotoent();
4995 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5001 #ifdef HAS_ENDSERVENT
5003 PerlSock_endservent();
5007 DIE(aTHX_ PL_no_sock_func, "endservent");
5015 I32 which = PL_op->op_type;
5017 struct passwd *pwent = NULL;
5019 * We currently support only the SysV getsp* shadow password interface.
5020 * The interface is declared in <shadow.h> and often one needs to link
5021 * with -lsecurity or some such.
5022 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5025 * AIX getpwnam() is clever enough to return the encrypted password
5026 * only if the caller (euid?) is root.
5028 * There are at least three other shadow password APIs. Many platforms
5029 * seem to contain more than one interface for accessing the shadow
5030 * password databases, possibly for compatibility reasons.
5031 * The getsp*() is by far he simplest one, the other two interfaces
5032 * are much more complicated, but also very similar to each other.
5037 * struct pr_passwd *getprpw*();
5038 * The password is in
5039 * char getprpw*(...).ufld.fd_encrypt[]
5040 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5045 * struct es_passwd *getespw*();
5046 * The password is in
5047 * char *(getespw*(...).ufld.fd_encrypt)
5048 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5051 * struct userpw *getuserpw();
5052 * The password is in
5053 * char *(getuserpw(...)).spw_upw_passwd
5054 * (but the de facto standard getpwnam() should work okay)
5056 * Mention I_PROT here so that Configure probes for it.
5058 * In HP-UX for getprpw*() the manual page claims that one should include
5059 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5060 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5061 * and pp_sys.c already includes <shadow.h> if there is such.
5063 * Note that <sys/security.h> is already probed for, but currently
5064 * it is only included in special cases.
5066 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5067 * be preferred interface, even though also the getprpw*() interface
5068 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5069 * One also needs to call set_auth_parameters() in main() before
5070 * doing anything else, whether one is using getespw*() or getprpw*().
5072 * Note that accessing the shadow databases can be magnitudes
5073 * slower than accessing the standard databases.
5078 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5079 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5080 * the pw_comment is left uninitialized. */
5081 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5087 const char* const name = POPpbytex;
5088 pwent = getpwnam(name);
5094 pwent = getpwuid(uid);
5098 # ifdef HAS_GETPWENT
5100 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5101 if (pwent) pwent = getpwnam(pwent->pw_name);
5104 DIE(aTHX_ PL_no_func, "getpwent");
5110 if (GIMME != G_ARRAY) {
5111 PUSHs(sv = sv_newmortal());
5113 if (which == OP_GPWNAM)
5114 # if Uid_t_sign <= 0
5115 sv_setiv(sv, (IV)pwent->pw_uid);
5117 sv_setuv(sv, (UV)pwent->pw_uid);
5120 sv_setpv(sv, pwent->pw_name);
5126 PUSHs(sv_2mortal(newSVpv(pwent->pw_name, 0)));
5128 PUSHs(sv = sv_2mortal(newSViv(0)));
5129 /* If we have getspnam(), we try to dig up the shadow
5130 * password. If we are underprivileged, the shadow
5131 * interface will set the errno to EACCES or similar,
5132 * and return a null pointer. If this happens, we will
5133 * use the dummy password (usually "*" or "x") from the
5134 * standard password database.
5136 * In theory we could skip the shadow call completely
5137 * if euid != 0 but in practice we cannot know which
5138 * security measures are guarding the shadow databases
5139 * on a random platform.
5141 * Resist the urge to use additional shadow interfaces.
5142 * Divert the urge to writing an extension instead.
5145 /* Some AIX setups falsely(?) detect some getspnam(), which
5146 * has a different API than the Solaris/IRIX one. */
5147 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5149 const int saverrno = errno;
5150 const struct spwd * const spwent = getspnam(pwent->pw_name);
5151 /* Save and restore errno so that
5152 * underprivileged attempts seem
5153 * to have never made the unsccessful
5154 * attempt to retrieve the shadow password. */
5156 if (spwent && spwent->sp_pwdp)
5157 sv_setpv(sv, spwent->sp_pwdp);
5161 if (!SvPOK(sv)) /* Use the standard password, then. */
5162 sv_setpv(sv, pwent->pw_passwd);
5165 # ifndef INCOMPLETE_TAINTS
5166 /* passwd is tainted because user himself can diddle with it.
5167 * admittedly not much and in a very limited way, but nevertheless. */
5171 # if Uid_t_sign <= 0
5172 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_uid)));
5174 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_uid)));
5177 # if Uid_t_sign <= 0
5178 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_gid)));
5180 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_gid)));
5182 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5183 * because of the poor interface of the Perl getpw*(),
5184 * not because there's some standard/convention saying so.
5185 * A better interface would have been to return a hash,
5186 * but we are accursed by our history, alas. --jhi. */
5188 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_change)));
5191 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_quota)));
5194 PUSHs(sv_2mortal(newSVpv(pwent->pw_age, 0)));
5196 /* I think that you can never get this compiled, but just in case. */
5197 PUSHs(sv_mortalcopy(&PL_sv_no));
5202 /* pw_class and pw_comment are mutually exclusive--.
5203 * see the above note for pw_change, pw_quota, and pw_age. */
5205 PUSHs(sv_2mortal(newSVpv(pwent->pw_class, 0)));
5208 PUSHs(sv_2mortal(newSVpv(pwent->pw_comment, 0)));
5210 /* I think that you can never get this compiled, but just in case. */
5211 PUSHs(sv_mortalcopy(&PL_sv_no));
5216 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5218 PUSHs(sv_mortalcopy(&PL_sv_no));
5220 # ifndef INCOMPLETE_TAINTS
5221 /* pw_gecos is tainted because user himself can diddle with it. */
5225 PUSHs(sv_2mortal(newSVpv(pwent->pw_dir, 0)));
5227 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5228 # ifndef INCOMPLETE_TAINTS
5229 /* pw_shell is tainted because user himself can diddle with it. */
5234 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_expire)));
5239 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5245 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5250 DIE(aTHX_ PL_no_func, "setpwent");
5256 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5261 DIE(aTHX_ PL_no_func, "endpwent");
5269 const I32 which = PL_op->op_type;
5270 const struct group *grent;
5272 if (which == OP_GGRNAM) {
5273 const char* const name = POPpbytex;
5274 grent = (const struct group *)getgrnam(name);
5276 else if (which == OP_GGRGID) {
5277 const Gid_t gid = POPi;
5278 grent = (const struct group *)getgrgid(gid);
5282 grent = (struct group *)getgrent();
5284 DIE(aTHX_ PL_no_func, "getgrent");
5288 if (GIMME != G_ARRAY) {
5289 SV * const sv = sv_newmortal();
5293 if (which == OP_GGRNAM)
5294 sv_setiv(sv, (IV)grent->gr_gid);
5296 sv_setpv(sv, grent->gr_name);
5302 PUSHs(sv_2mortal(newSVpv(grent->gr_name, 0)));
5305 PUSHs(sv_2mortal(newSVpv(grent->gr_passwd, 0)));
5307 PUSHs(sv_mortalcopy(&PL_sv_no));
5310 PUSHs(sv_2mortal(newSViv((IV)grent->gr_gid)));
5312 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5313 /* In UNICOS/mk (_CRAYMPP) the multithreading
5314 * versions (getgrnam_r, getgrgid_r)
5315 * seem to return an illegal pointer
5316 * as the group members list, gr_mem.
5317 * getgrent() doesn't even have a _r version
5318 * but the gr_mem is poisonous anyway.
5319 * So yes, you cannot get the list of group
5320 * members if building multithreaded in UNICOS/mk. */
5321 PUSHs(space_join_names_mortal(grent->gr_mem));
5327 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5333 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5338 DIE(aTHX_ PL_no_func, "setgrent");
5344 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5349 DIE(aTHX_ PL_no_func, "endgrent");
5359 if (!(tmps = PerlProc_getlogin()))
5361 PUSHp(tmps, strlen(tmps));
5364 DIE(aTHX_ PL_no_func, "getlogin");
5368 /* Miscellaneous. */
5373 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5374 register I32 items = SP - MARK;
5375 unsigned long a[20];
5380 while (++MARK <= SP) {
5381 if (SvTAINTED(*MARK)) {
5387 TAINT_PROPER("syscall");
5390 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5391 * or where sizeof(long) != sizeof(char*). But such machines will
5392 * not likely have syscall implemented either, so who cares?
5394 while (++MARK <= SP) {
5395 if (SvNIOK(*MARK) || !i)
5396 a[i++] = SvIV(*MARK);
5397 else if (*MARK == &PL_sv_undef)
5400 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5406 DIE(aTHX_ "Too many args to syscall");
5408 DIE(aTHX_ "Too few args to syscall");
5410 retval = syscall(a[0]);
5413 retval = syscall(a[0],a[1]);
5416 retval = syscall(a[0],a[1],a[2]);
5419 retval = syscall(a[0],a[1],a[2],a[3]);
5422 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5425 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5428 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5431 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5435 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5438 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],
5453 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5454 a[10],a[11],a[12],a[13]);
5456 #endif /* atarist */
5462 DIE(aTHX_ PL_no_func, "syscall");
5466 #ifdef FCNTL_EMULATE_FLOCK
5468 /* XXX Emulate flock() with fcntl().
5469 What's really needed is a good file locking module.
5473 fcntl_emulate_flock(int fd, int operation)
5477 switch (operation & ~LOCK_NB) {
5479 flock.l_type = F_RDLCK;
5482 flock.l_type = F_WRLCK;
5485 flock.l_type = F_UNLCK;
5491 flock.l_whence = SEEK_SET;
5492 flock.l_start = flock.l_len = (Off_t)0;
5494 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5497 #endif /* FCNTL_EMULATE_FLOCK */
5499 #ifdef LOCKF_EMULATE_FLOCK
5501 /* XXX Emulate flock() with lockf(). This is just to increase
5502 portability of scripts. The calls are not completely
5503 interchangeable. What's really needed is a good file
5507 /* The lockf() constants might have been defined in <unistd.h>.
5508 Unfortunately, <unistd.h> causes troubles on some mixed
5509 (BSD/POSIX) systems, such as SunOS 4.1.3.
5511 Further, the lockf() constants aren't POSIX, so they might not be
5512 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5513 just stick in the SVID values and be done with it. Sigh.
5517 # define F_ULOCK 0 /* Unlock a previously locked region */
5520 # define F_LOCK 1 /* Lock a region for exclusive use */
5523 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5526 # define F_TEST 3 /* Test a region for other processes locks */
5530 lockf_emulate_flock(int fd, int operation)
5533 const int save_errno = errno;
5536 /* flock locks entire file so for lockf we need to do the same */
5537 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5538 if (pos > 0) /* is seekable and needs to be repositioned */
5539 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5540 pos = -1; /* seek failed, so don't seek back afterwards */
5543 switch (operation) {
5545 /* LOCK_SH - get a shared lock */
5547 /* LOCK_EX - get an exclusive lock */
5549 i = lockf (fd, F_LOCK, 0);
5552 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5553 case LOCK_SH|LOCK_NB:
5554 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5555 case LOCK_EX|LOCK_NB:
5556 i = lockf (fd, F_TLOCK, 0);
5558 if ((errno == EAGAIN) || (errno == EACCES))
5559 errno = EWOULDBLOCK;
5562 /* LOCK_UN - unlock (non-blocking is a no-op) */
5564 case LOCK_UN|LOCK_NB:
5565 i = lockf (fd, F_ULOCK, 0);
5568 /* Default - can't decipher operation */
5575 if (pos > 0) /* need to restore position of the handle */
5576 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5581 #endif /* LOCKF_EMULATE_FLOCK */
5585 * c-indentation-style: bsd
5587 * indent-tabs-mode: t
5590 * ex: set ts=8 sts=4 sw=4 noet: