3 * Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 * 2004, 2005, 2006, 2007 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * But only a short way ahead its floor and the walls on either side were
13 * cloven by a great fissure, out of which the red glare came, now leaping
14 * up, now dying down into darkness; and all the while far below there was
15 * a rumour and a trouble as of great engines throbbing and labouring.
18 /* This file contains system pp ("push/pop") functions that
19 * execute the opcodes that make up a perl program. A typical pp function
20 * expects to find its arguments on the stack, and usually pushes its
21 * results onto the stack, hence the 'pp' terminology. Each OP structure
22 * contains a pointer to the relevant pp_foo() function.
24 * By 'system', we mean ops which interact with the OS, such as pp_open().
28 #define PERL_IN_PP_SYS_C
32 /* Shadow password support for solaris - pdo@cs.umd.edu
33 * Not just Solaris: at least HP-UX, IRIX, Linux.
34 * The API is from SysV.
36 * There are at least two more shadow interfaces,
37 * see the comments in pp_gpwent().
41 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
42 * and another MAXINT from "perl.h" <- <sys/param.h>. */
49 # include <sys/wait.h>
53 # include <sys/resource.h>
62 # include <sys/select.h>
66 /* XXX Configure test needed.
67 h_errno might not be a simple 'int', especially for multi-threaded
68 applications, see "extern int errno in perl.h". Creating such
69 a test requires taking into account the differences between
70 compiling multithreaded and singlethreaded ($ccflags et al).
71 HOST_NOT_FOUND is typically defined in <netdb.h>.
73 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
82 struct passwd *getpwnam (char *);
83 struct passwd *getpwuid (Uid_t);
88 struct passwd *getpwent (void);
89 #elif defined (VMS) && defined (my_getpwent)
90 struct passwd *Perl_my_getpwent (pTHX);
99 struct group *getgrnam (char *);
100 struct group *getgrgid (Gid_t);
104 struct group *getgrent (void);
110 # if defined(_MSC_VER) || defined(__MINGW32__)
111 # include <sys/utime.h>
118 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
121 # define my_chsize PerlLIO_chsize
124 # define my_chsize PerlLIO_chsize
126 I32 my_chsize(int fd, Off_t length);
132 #else /* no flock() */
134 /* fcntl.h might not have been included, even if it exists, because
135 the current Configure only sets I_FCNTL if it's needed to pick up
136 the *_OK constants. Make sure it has been included before testing
137 the fcntl() locking constants. */
138 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
142 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
143 # define FLOCK fcntl_emulate_flock
144 # define FCNTL_EMULATE_FLOCK
145 # else /* no flock() or fcntl(F_SETLK,...) */
147 # define FLOCK lockf_emulate_flock
148 # define LOCKF_EMULATE_FLOCK
150 # endif /* no flock() or fcntl(F_SETLK,...) */
153 static int FLOCK (int, int);
156 * These are the flock() constants. Since this sytems doesn't have
157 * flock(), the values of the constants are probably not available.
171 # endif /* emulating flock() */
173 #endif /* no flock() */
176 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
178 #if defined(I_SYS_ACCESS) && !defined(R_OK)
179 # include <sys/access.h>
182 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
183 # define FD_CLOEXEC 1 /* NeXT needs this */
189 /* Missing protos on LynxOS */
190 void sethostent(int);
191 void endhostent(void);
193 void endnetent(void);
194 void setprotoent(int);
195 void endprotoent(void);
196 void setservent(int);
197 void endservent(void);
200 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
202 /* AIX 5.2 and below use mktime for localtime, and defines the edge case
203 * for time 0x7fffffff to be valid only in UTC. AIX 5.3 provides localtime64
204 * available in the 32bit environment, which could warrant Configure
205 * checks in the future.
208 #define LOCALTIME_EDGECASE_BROKEN
211 /* F_OK unused: if stat() cannot find it... */
213 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
214 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
215 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
218 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
219 # ifdef I_SYS_SECURITY
220 # include <sys/security.h>
224 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
227 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
231 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
233 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
237 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
238 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
239 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
242 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
244 const Uid_t ruid = getuid();
245 const Uid_t euid = geteuid();
246 const Gid_t rgid = getgid();
247 const Gid_t egid = getegid();
251 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
252 Perl_croak(aTHX_ "switching effective uid is not implemented");
255 if (setreuid(euid, ruid))
258 if (setresuid(euid, ruid, (Uid_t)-1))
261 Perl_croak(aTHX_ "entering effective uid failed");
264 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
265 Perl_croak(aTHX_ "switching effective gid is not implemented");
268 if (setregid(egid, rgid))
271 if (setresgid(egid, rgid, (Gid_t)-1))
274 Perl_croak(aTHX_ "entering effective gid failed");
277 res = access(path, mode);
280 if (setreuid(ruid, euid))
283 if (setresuid(ruid, euid, (Uid_t)-1))
286 Perl_croak(aTHX_ "leaving effective uid failed");
289 if (setregid(rgid, egid))
292 if (setresgid(rgid, egid, (Gid_t)-1))
295 Perl_croak(aTHX_ "leaving effective gid failed");
300 # define PERL_EFF_ACCESS(p,f) (emulate_eaccess((p), (f)))
303 #if !defined(PERL_EFF_ACCESS)
304 /* With it or without it: anyway you get a warning: either that
305 it is unused, or it is declared static and never defined.
308 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
310 PERL_UNUSED_ARG(path);
311 PERL_UNUSED_ARG(mode);
312 Perl_croak(aTHX_ "switching effective uid is not implemented");
322 const char * const tmps = POPpconstx;
323 const I32 gimme = GIMME_V;
324 const char *mode = "r";
327 if (PL_op->op_private & OPpOPEN_IN_RAW)
329 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
331 fp = PerlProc_popen(tmps, mode);
333 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
335 PerlIO_apply_layers(aTHX_ fp,mode,type);
337 if (gimme == G_VOID) {
339 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
342 else if (gimme == G_SCALAR) {
345 PL_rs = &PL_sv_undef;
346 sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */
347 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
355 SV * const sv = newSV(79);
356 if (sv_gets(sv, fp, 0) == NULL) {
360 XPUSHs(sv_2mortal(sv));
361 if (SvLEN(sv) - SvCUR(sv) > 20) {
362 SvPV_shrink_to_cur(sv);
367 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
368 TAINT; /* "I believe that this is not gratuitous!" */
371 STATUS_NATIVE_CHILD_SET(-1);
372 if (gimme == G_SCALAR)
383 tryAMAGICunTARGET(iter, -1);
385 /* Note that we only ever get here if File::Glob fails to load
386 * without at the same time croaking, for some reason, or if
387 * perl was built with PERL_EXTERNAL_GLOB */
394 * The external globbing program may use things we can't control,
395 * so for security reasons we must assume the worst.
398 taint_proper(PL_no_security, "glob");
402 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
403 PL_last_in_gv = (GV*)*PL_stack_sp--;
405 SAVESPTR(PL_rs); /* This is not permanent, either. */
406 PL_rs = sv_2mortal(newSVpvs("\000"));
409 *SvPVX(PL_rs) = '\n';
413 result = do_readline();
421 PL_last_in_gv = cGVOP_gv;
422 return do_readline();
433 do_join(TARG, &PL_sv_no, MARK, SP);
437 else if (SP == MARK) {
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, SVfARG(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, SVfARG(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(022);
711 /* setting it to 022 between the two calls to umask avoids
712 * to have a window where the umask is set to 0 -- meaning
713 * that another thread could create world-writeable files. */
715 (void)PerlLIO_umask(anum);
718 anum = PerlLIO_umask(POPi);
719 TAINT_PROPER("umask");
722 /* Only DIE if trying to restrict permissions on "user" (self).
723 * Otherwise it's harmless and more useful to just return undef
724 * since 'group' and 'other' concepts probably don't exist here. */
725 if (MAXARG >= 1 && (POPi & 0700))
726 DIE(aTHX_ "umask not implemented");
727 XPUSHs(&PL_sv_undef);
748 if (gv && (io = GvIO(gv))) {
749 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
752 XPUSHs(SvTIED_obj((SV*)io, mg));
757 call_method("BINMODE", G_SCALAR);
765 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
766 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
767 report_evil_fh(gv, io, PL_op->op_type);
768 SETERRNO(EBADF,RMS_IFI);
774 const int mode = mode_from_discipline(discp);
775 const char *const d = (discp ? SvPV_nolen_const(discp) : NULL);
776 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
777 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
778 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
799 const I32 markoff = MARK - PL_stack_base;
800 const char *methname;
801 int how = PERL_MAGIC_tied;
805 switch(SvTYPE(varsv)) {
807 methname = "TIEHASH";
808 HvEITER_set((HV *)varsv, 0);
811 methname = "TIEARRAY";
814 #ifdef GV_UNIQUE_CHECK
815 if (GvUNIQUE((GV*)varsv)) {
816 Perl_croak(aTHX_ "Attempt to tie unique GV");
819 methname = "TIEHANDLE";
820 how = PERL_MAGIC_tiedscalar;
821 /* For tied filehandles, we apply tiedscalar magic to the IO
822 slot of the GP rather than the GV itself. AMS 20010812 */
824 GvIOp(varsv) = newIO();
825 varsv = (SV *)GvIOp(varsv);
828 methname = "TIESCALAR";
829 how = PERL_MAGIC_tiedscalar;
833 if (sv_isobject(*MARK)) {
835 PUSHSTACKi(PERLSI_MAGIC);
837 EXTEND(SP,(I32)items);
841 call_method(methname, G_SCALAR);
844 /* Not clear why we don't call call_method here too.
845 * perhaps to get different error message ?
847 stash = gv_stashsv(*MARK, 0);
848 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
849 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
850 methname, SVfARG(*MARK));
853 PUSHSTACKi(PERLSI_MAGIC);
855 EXTEND(SP,(I32)items);
859 call_sv((SV*)GvCV(gv), G_SCALAR);
865 if (sv_isobject(sv)) {
866 sv_unmagic(varsv, how);
867 /* Croak if a self-tie on an aggregate is attempted. */
868 if (varsv == SvRV(sv) &&
869 (SvTYPE(varsv) == SVt_PVAV ||
870 SvTYPE(varsv) == SVt_PVHV))
872 "Self-ties of arrays and hashes are not supported");
873 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
876 SP = PL_stack_base + markoff;
886 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
887 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
889 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
892 if ((mg = SvTIED_mg(sv, how))) {
893 SV * const obj = SvRV(SvTIED_obj(sv, mg));
895 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
897 if (gv && isGV(gv) && (cv = GvCV(gv))) {
899 XPUSHs(SvTIED_obj((SV*)gv, mg));
900 XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
903 call_sv((SV *)cv, G_VOID);
907 else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
908 Perl_warner(aTHX_ packWARN(WARN_UNTIE),
909 "untie attempted while %"UVuf" inner references still exist",
910 (UV)SvREFCNT(obj) - 1 ) ;
914 sv_unmagic(sv, how) ;
924 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
925 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
927 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
930 if ((mg = SvTIED_mg(sv, how))) {
931 SV *osv = SvTIED_obj(sv, mg);
932 if (osv == mg->mg_obj)
933 osv = sv_mortalcopy(osv);
947 HV * const hv = (HV*)POPs;
948 SV * const sv = sv_2mortal(newSVpvs("AnyDBM_File"));
949 stash = gv_stashsv(sv, 0);
950 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
952 require_pv("AnyDBM_File.pm");
954 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
955 DIE(aTHX_ "No dbm on this machine");
965 PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
967 PUSHs(sv_2mortal(newSVuv(O_RDWR)));
970 call_sv((SV*)GvCV(gv), G_SCALAR);
973 if (!sv_isobject(TOPs)) {
978 PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
981 call_sv((SV*)GvCV(gv), G_SCALAR);
985 if (sv_isobject(TOPs)) {
986 sv_unmagic((SV *) hv, PERL_MAGIC_tied);
987 sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, NULL, 0);
1004 struct timeval timebuf;
1005 struct timeval *tbuf = &timebuf;
1008 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1013 # if BYTEORDER & 0xf0000
1014 # define ORDERBYTE (0x88888888 - BYTEORDER)
1016 # define ORDERBYTE (0x4444 - BYTEORDER)
1022 for (i = 1; i <= 3; i++) {
1023 SV * const sv = SP[i];
1026 if (SvREADONLY(sv)) {
1028 sv_force_normal_flags(sv, 0);
1029 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1030 DIE(aTHX_ PL_no_modify);
1033 if (ckWARN(WARN_MISC))
1034 Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1035 SvPV_force_nolen(sv); /* force string conversion */
1042 /* little endians can use vecs directly */
1043 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1050 masksize = NFDBITS / NBBY;
1052 masksize = sizeof(long); /* documented int, everyone seems to use long */
1054 Zero(&fd_sets[0], 4, char*);
1057 # if SELECT_MIN_BITS == 1
1058 growsize = sizeof(fd_set);
1060 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1061 # undef SELECT_MIN_BITS
1062 # define SELECT_MIN_BITS __FD_SETSIZE
1064 /* If SELECT_MIN_BITS is greater than one we most probably will want
1065 * to align the sizes with SELECT_MIN_BITS/8 because for example
1066 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1067 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1068 * on (sets/tests/clears bits) is 32 bits. */
1069 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1077 timebuf.tv_sec = (long)value;
1078 value -= (NV)timebuf.tv_sec;
1079 timebuf.tv_usec = (long)(value * 1000000.0);
1084 for (i = 1; i <= 3; i++) {
1086 if (!SvOK(sv) || SvCUR(sv) == 0) {
1093 Sv_Grow(sv, growsize);
1097 while (++j <= growsize) {
1101 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1103 Newx(fd_sets[i], growsize, char);
1104 for (offset = 0; offset < growsize; offset += masksize) {
1105 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1106 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1109 fd_sets[i] = SvPVX(sv);
1113 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1114 /* Can't make just the (void*) conditional because that would be
1115 * cpp #if within cpp macro, and not all compilers like that. */
1116 nfound = PerlSock_select(
1118 (Select_fd_set_t) fd_sets[1],
1119 (Select_fd_set_t) fd_sets[2],
1120 (Select_fd_set_t) fd_sets[3],
1121 (void*) tbuf); /* Workaround for compiler bug. */
1123 nfound = PerlSock_select(
1125 (Select_fd_set_t) fd_sets[1],
1126 (Select_fd_set_t) fd_sets[2],
1127 (Select_fd_set_t) fd_sets[3],
1130 for (i = 1; i <= 3; i++) {
1133 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1135 for (offset = 0; offset < growsize; offset += masksize) {
1136 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1137 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1139 Safefree(fd_sets[i]);
1146 if (GIMME == G_ARRAY && tbuf) {
1147 value = (NV)(timebuf.tv_sec) +
1148 (NV)(timebuf.tv_usec) / 1000000.0;
1149 PUSHs(sv_2mortal(newSVnv(value)));
1153 DIE(aTHX_ "select not implemented");
1158 Perl_setdefout(pTHX_ GV *gv)
1161 SvREFCNT_inc_simple_void(gv);
1163 SvREFCNT_dec(PL_defoutgv);
1171 GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : NULL;
1172 GV * egv = GvEGV(PL_defoutgv);
1178 XPUSHs(&PL_sv_undef);
1180 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1181 if (gvp && *gvp == egv) {
1182 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1186 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1191 if (!GvIO(newdefout))
1192 gv_IOadd(newdefout);
1193 setdefout(newdefout);
1203 GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs;
1205 if (gv && (io = GvIO(gv))) {
1206 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1208 const I32 gimme = GIMME_V;
1210 XPUSHs(SvTIED_obj((SV*)io, mg));
1213 call_method("GETC", gimme);
1216 if (gimme == G_SCALAR)
1217 SvSetMagicSV_nosteal(TARG, TOPs);
1221 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1222 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1223 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1224 report_evil_fh(gv, io, PL_op->op_type);
1225 SETERRNO(EBADF,RMS_IFI);
1229 sv_setpvn(TARG, " ", 1);
1230 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1231 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1232 /* Find out how many bytes the char needs */
1233 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1236 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1237 SvCUR_set(TARG,1+len);
1246 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1249 register PERL_CONTEXT *cx;
1250 const I32 gimme = GIMME_V;
1255 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1257 cx->blk_sub.retop = retop;
1259 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1261 setdefout(gv); /* locally select filehandle so $% et al work */
1293 goto not_a_format_reference;
1298 tmpsv = sv_newmortal();
1299 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1300 name = SvPV_nolen_const(tmpsv);
1302 DIE(aTHX_ "Undefined format \"%s\" called", name);
1304 not_a_format_reference:
1305 DIE(aTHX_ "Not a format reference");
1308 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1310 IoFLAGS(io) &= ~IOf_DIDTOP;
1311 return doform(cv,gv,PL_op->op_next);
1317 GV * const gv = cxstack[cxstack_ix].blk_sub.gv;
1318 register IO * const io = GvIOp(gv);
1323 register PERL_CONTEXT *cx;
1325 if (!io || !(ofp = IoOFP(io)))
1328 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1329 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1331 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1332 PL_formtarget != PL_toptarget)
1336 if (!IoTOP_GV(io)) {
1339 if (!IoTOP_NAME(io)) {
1341 if (!IoFMT_NAME(io))
1342 IoFMT_NAME(io) = savepv(GvNAME(gv));
1343 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1344 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1345 if ((topgv && GvFORM(topgv)) ||
1346 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1347 IoTOP_NAME(io) = savesvpv(topname);
1349 IoTOP_NAME(io) = savepvs("top");
1351 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1352 if (!topgv || !GvFORM(topgv)) {
1353 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1356 IoTOP_GV(io) = topgv;
1358 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1359 I32 lines = IoLINES_LEFT(io);
1360 const char *s = SvPVX_const(PL_formtarget);
1361 if (lines <= 0) /* Yow, header didn't even fit!!! */
1363 while (lines-- > 0) {
1364 s = strchr(s, '\n');
1370 const STRLEN save = SvCUR(PL_formtarget);
1371 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1372 do_print(PL_formtarget, ofp);
1373 SvCUR_set(PL_formtarget, save);
1374 sv_chop(PL_formtarget, s);
1375 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1378 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1379 do_print(PL_formfeed, ofp);
1380 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1382 PL_formtarget = PL_toptarget;
1383 IoFLAGS(io) |= IOf_DIDTOP;
1386 DIE(aTHX_ "bad top format reference");
1389 SV * const sv = sv_newmortal();
1391 gv_efullname4(sv, fgv, NULL, FALSE);
1392 name = SvPV_nolen_const(sv);
1394 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1396 DIE(aTHX_ "Undefined top format called");
1398 if (cv && CvCLONE(cv))
1399 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1400 return doform(cv, gv, PL_op);
1404 POPBLOCK(cx,PL_curpm);
1410 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1412 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1413 else if (ckWARN(WARN_CLOSED))
1414 report_evil_fh(gv, io, PL_op->op_type);
1419 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1420 if (ckWARN(WARN_IO))
1421 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1423 if (!do_print(PL_formtarget, fp))
1426 FmLINES(PL_formtarget) = 0;
1427 SvCUR_set(PL_formtarget, 0);
1428 *SvEND(PL_formtarget) = '\0';
1429 if (IoFLAGS(io) & IOf_FLUSH)
1430 (void)PerlIO_flush(fp);
1435 PL_formtarget = PL_bodytarget;
1437 PERL_UNUSED_VAR(newsp);
1438 PERL_UNUSED_VAR(gimme);
1439 return cx->blk_sub.retop;
1444 dVAR; dSP; dMARK; dORIGMARK;
1449 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
1451 if (gv && (io = GvIO(gv))) {
1452 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1454 if (MARK == ORIGMARK) {
1457 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1461 *MARK = SvTIED_obj((SV*)io, mg);
1464 call_method("PRINTF", G_SCALAR);
1467 MARK = ORIGMARK + 1;
1475 if (!(io = GvIO(gv))) {
1476 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1477 report_evil_fh(gv, io, PL_op->op_type);
1478 SETERRNO(EBADF,RMS_IFI);
1481 else if (!(fp = IoOFP(io))) {
1482 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1484 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1485 else if (ckWARN(WARN_CLOSED))
1486 report_evil_fh(gv, io, PL_op->op_type);
1488 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1492 if (SvTAINTED(MARK[1]))
1493 TAINT_PROPER("printf");
1494 do_sprintf(sv, SP - MARK, MARK + 1);
1495 if (!do_print(sv, fp))
1498 if (IoFLAGS(io) & IOf_FLUSH)
1499 if (PerlIO_flush(fp) == EOF)
1510 PUSHs(&PL_sv_undef);
1518 const int perm = (MAXARG > 3) ? POPi : 0666;
1519 const int mode = POPi;
1520 SV * const sv = POPs;
1521 GV * const gv = (GV *)POPs;
1524 /* Need TIEHANDLE method ? */
1525 const char * const tmps = SvPV_const(sv, len);
1526 /* FIXME? do_open should do const */
1527 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1528 IoLINES(GvIOp(gv)) = 0;
1532 PUSHs(&PL_sv_undef);
1539 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1545 Sock_size_t bufsize;
1553 bool charstart = FALSE;
1554 STRLEN charskip = 0;
1557 GV * const gv = (GV*)*++MARK;
1558 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1559 && gv && (io = GvIO(gv)) )
1561 const MAGIC * mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1565 *MARK = SvTIED_obj((SV*)io, mg);
1567 call_method("READ", G_SCALAR);
1581 sv_setpvn(bufsv, "", 0);
1582 length = SvIVx(*++MARK);
1585 offset = SvIVx(*++MARK);
1589 if (!io || !IoIFP(io)) {
1590 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1591 report_evil_fh(gv, io, PL_op->op_type);
1592 SETERRNO(EBADF,RMS_IFI);
1595 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1596 buffer = SvPVutf8_force(bufsv, blen);
1597 /* UTF-8 may not have been set if they are all low bytes */
1602 buffer = SvPV_force(bufsv, blen);
1603 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1606 DIE(aTHX_ "Negative length");
1614 if (PL_op->op_type == OP_RECV) {
1615 char namebuf[MAXPATHLEN];
1616 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1617 bufsize = sizeof (struct sockaddr_in);
1619 bufsize = sizeof namebuf;
1621 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1625 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1626 /* 'offset' means 'flags' here */
1627 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1628 (struct sockaddr *)namebuf, &bufsize);
1632 /* Bogus return without padding */
1633 bufsize = sizeof (struct sockaddr_in);
1635 SvCUR_set(bufsv, count);
1636 *SvEND(bufsv) = '\0';
1637 (void)SvPOK_only(bufsv);
1641 /* This should not be marked tainted if the fp is marked clean */
1642 if (!(IoFLAGS(io) & IOf_UNTAINT))
1643 SvTAINTED_on(bufsv);
1645 sv_setpvn(TARG, namebuf, bufsize);
1650 if (PL_op->op_type == OP_RECV)
1651 DIE(aTHX_ PL_no_sock_func, "recv");
1653 if (DO_UTF8(bufsv)) {
1654 /* offset adjust in characters not bytes */
1655 blen = sv_len_utf8(bufsv);
1658 if (-offset > (int)blen)
1659 DIE(aTHX_ "Offset outside string");
1662 if (DO_UTF8(bufsv)) {
1663 /* convert offset-as-chars to offset-as-bytes */
1664 if (offset >= (int)blen)
1665 offset += SvCUR(bufsv) - blen;
1667 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1670 bufsize = SvCUR(bufsv);
1671 /* Allocating length + offset + 1 isn't perfect in the case of reading
1672 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1674 (should be 2 * length + offset + 1, or possibly something longer if
1675 PL_encoding is true) */
1676 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1677 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1678 Zero(buffer+bufsize, offset-bufsize, char);
1680 buffer = buffer + offset;
1682 read_target = bufsv;
1684 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1685 concatenate it to the current buffer. */
1687 /* Truncate the existing buffer to the start of where we will be
1689 SvCUR_set(bufsv, offset);
1691 read_target = sv_newmortal();
1692 SvUPGRADE(read_target, SVt_PV);
1693 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1696 if (PL_op->op_type == OP_SYSREAD) {
1697 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1698 if (IoTYPE(io) == IoTYPE_SOCKET) {
1699 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1705 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1710 #ifdef HAS_SOCKET__bad_code_maybe
1711 if (IoTYPE(io) == IoTYPE_SOCKET) {
1712 char namebuf[MAXPATHLEN];
1713 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1714 bufsize = sizeof (struct sockaddr_in);
1716 bufsize = sizeof namebuf;
1718 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1719 (struct sockaddr *)namebuf, &bufsize);
1724 count = PerlIO_read(IoIFP(io), buffer, length);
1725 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1726 if (count == 0 && PerlIO_error(IoIFP(io)))
1730 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1731 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1734 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1735 *SvEND(read_target) = '\0';
1736 (void)SvPOK_only(read_target);
1737 if (fp_utf8 && !IN_BYTES) {
1738 /* Look at utf8 we got back and count the characters */
1739 const char *bend = buffer + count;
1740 while (buffer < bend) {
1742 skip = UTF8SKIP(buffer);
1745 if (buffer - charskip + skip > bend) {
1746 /* partial character - try for rest of it */
1747 length = skip - (bend-buffer);
1748 offset = bend - SvPVX_const(bufsv);
1760 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1761 provided amount read (count) was what was requested (length)
1763 if (got < wanted && count == length) {
1764 length = wanted - got;
1765 offset = bend - SvPVX_const(bufsv);
1768 /* return value is character count */
1772 else if (buffer_utf8) {
1773 /* Let svcatsv upgrade the bytes we read in to utf8.
1774 The buffer is a mortal so will be freed soon. */
1775 sv_catsv_nomg(bufsv, read_target);
1778 /* This should not be marked tainted if the fp is marked clean */
1779 if (!(IoFLAGS(io) & IOf_UNTAINT))
1780 SvTAINTED_on(bufsv);
1792 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1798 STRLEN orig_blen_bytes;
1799 const int op_type = PL_op->op_type;
1803 GV *const gv = (GV*)*++MARK;
1804 if (PL_op->op_type == OP_SYSWRITE
1805 && gv && (io = GvIO(gv))) {
1806 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1810 if (MARK == SP - 1) {
1812 sv = sv_2mortal(newSViv(sv_len(*SP)));
1818 *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg);
1820 call_method("WRITE", G_SCALAR);
1836 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1838 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1839 if (io && IoIFP(io))
1840 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1842 report_evil_fh(gv, io, PL_op->op_type);
1844 SETERRNO(EBADF,RMS_IFI);
1848 /* Do this first to trigger any overloading. */
1849 buffer = SvPV_const(bufsv, blen);
1850 orig_blen_bytes = blen;
1851 doing_utf8 = DO_UTF8(bufsv);
1853 if (PerlIO_isutf8(IoIFP(io))) {
1854 if (!SvUTF8(bufsv)) {
1855 /* We don't modify the original scalar. */
1856 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1857 buffer = (char *) tmpbuf;
1861 else if (doing_utf8) {
1862 STRLEN tmplen = blen;
1863 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1866 buffer = (char *) tmpbuf;
1870 assert((char *)result == buffer);
1871 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1875 if (op_type == OP_SYSWRITE) {
1876 Size_t length = 0; /* This length is in characters. */
1882 /* The SV is bytes, and we've had to upgrade it. */
1883 blen_chars = orig_blen_bytes;
1885 /* The SV really is UTF-8. */
1886 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1887 /* Don't call sv_len_utf8 again because it will call magic
1888 or overloading a second time, and we might get back a
1889 different result. */
1890 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1892 /* It's safe, and it may well be cached. */
1893 blen_chars = sv_len_utf8(bufsv);
1901 length = blen_chars;
1903 #if Size_t_size > IVSIZE
1904 length = (Size_t)SvNVx(*++MARK);
1906 length = (Size_t)SvIVx(*++MARK);
1908 if ((SSize_t)length < 0) {
1910 DIE(aTHX_ "Negative length");
1915 offset = SvIVx(*++MARK);
1917 if (-offset > (IV)blen_chars) {
1919 DIE(aTHX_ "Offset outside string");
1921 offset += blen_chars;
1922 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1924 DIE(aTHX_ "Offset outside string");
1928 if (length > blen_chars - offset)
1929 length = blen_chars - offset;
1931 /* Here we convert length from characters to bytes. */
1932 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1933 /* Either we had to convert the SV, or the SV is magical, or
1934 the SV has overloading, in which case we can't or mustn't
1935 or mustn't call it again. */
1937 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1938 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1940 /* It's a real UTF-8 SV, and it's not going to change under
1941 us. Take advantage of any cache. */
1943 I32 len_I32 = length;
1945 /* Convert the start and end character positions to bytes.
1946 Remember that the second argument to sv_pos_u2b is relative
1948 sv_pos_u2b(bufsv, &start, &len_I32);
1955 buffer = buffer+offset;
1957 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1958 if (IoTYPE(io) == IoTYPE_SOCKET) {
1959 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1965 /* See the note at doio.c:do_print about filesize limits. --jhi */
1966 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1972 const int flags = SvIVx(*++MARK);
1975 char * const sockbuf = SvPVx(*++MARK, mlen);
1976 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1977 flags, (struct sockaddr *)sockbuf, mlen);
1981 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1986 DIE(aTHX_ PL_no_sock_func, "send");
1993 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
1996 #if Size_t_size > IVSIZE
2015 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
2017 gv = PL_last_in_gv = GvEGV(PL_argvgv);
2019 if (io && !IoIFP(io)) {
2020 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2022 IoFLAGS(io) &= ~IOf_START;
2023 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2024 sv_setpvn(GvSV(gv), "-", 1);
2025 SvSETMAGIC(GvSV(gv));
2027 else if (!nextargv(gv))
2032 gv = PL_last_in_gv; /* eof */
2035 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
2038 IO * const io = GvIO(gv);
2040 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
2042 XPUSHs(SvTIED_obj((SV*)io, mg));
2045 call_method("EOF", G_SCALAR);
2052 PUSHs(boolSV(!gv || do_eof(gv)));
2063 PL_last_in_gv = (GV*)POPs;
2066 if (gv && (io = GvIO(gv))) {
2067 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2070 XPUSHs(SvTIED_obj((SV*)io, mg));
2073 call_method("TELL", G_SCALAR);
2080 #if LSEEKSIZE > IVSIZE
2081 PUSHn( do_tell(gv) );
2083 PUSHi( do_tell(gv) );
2091 const int whence = POPi;
2092 #if LSEEKSIZE > IVSIZE
2093 const Off_t offset = (Off_t)SvNVx(POPs);
2095 const Off_t offset = (Off_t)SvIVx(POPs);
2098 GV * const gv = PL_last_in_gv = (GV*)POPs;
2101 if (gv && (io = GvIO(gv))) {
2102 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2105 XPUSHs(SvTIED_obj((SV*)io, mg));
2106 #if LSEEKSIZE > IVSIZE
2107 XPUSHs(sv_2mortal(newSVnv((NV) offset)));
2109 XPUSHs(sv_2mortal(newSViv(offset)));
2111 XPUSHs(sv_2mortal(newSViv(whence)));
2114 call_method("SEEK", G_SCALAR);
2121 if (PL_op->op_type == OP_SEEK)
2122 PUSHs(boolSV(do_seek(gv, offset, whence)));
2124 const Off_t sought = do_sysseek(gv, offset, whence);
2126 PUSHs(&PL_sv_undef);
2128 SV* const sv = sought ?
2129 #if LSEEKSIZE > IVSIZE
2134 : newSVpvn(zero_but_true, ZBTLEN);
2135 PUSHs(sv_2mortal(sv));
2145 /* There seems to be no consensus on the length type of truncate()
2146 * and ftruncate(), both off_t and size_t have supporters. In
2147 * general one would think that when using large files, off_t is
2148 * at least as wide as size_t, so using an off_t should be okay. */
2149 /* XXX Configure probe for the length type of *truncate() needed XXX */
2152 #if Off_t_size > IVSIZE
2157 /* Checking for length < 0 is problematic as the type might or
2158 * might not be signed: if it is not, clever compilers will moan. */
2159 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2166 if (PL_op->op_flags & OPf_SPECIAL) {
2167 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2176 TAINT_PROPER("truncate");
2177 if (!(fp = IoIFP(io))) {
2183 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2185 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2192 SV * const sv = POPs;
2195 if (SvTYPE(sv) == SVt_PVGV) {
2196 tmpgv = (GV*)sv; /* *main::FRED for example */
2197 goto do_ftruncate_gv;
2199 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2200 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
2201 goto do_ftruncate_gv;
2203 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2204 io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
2205 goto do_ftruncate_io;
2208 name = SvPV_nolen_const(sv);
2209 TAINT_PROPER("truncate");
2211 if (truncate(name, len) < 0)
2215 const int tmpfd = PerlLIO_open(name, O_RDWR);
2220 if (my_chsize(tmpfd, len) < 0)
2222 PerlLIO_close(tmpfd);
2231 SETERRNO(EBADF,RMS_IFI);
2239 SV * const argsv = POPs;
2240 const unsigned int func = POPu;
2241 const int optype = PL_op->op_type;
2242 GV * const gv = (GV*)POPs;
2243 IO * const io = gv ? GvIOn(gv) : NULL;
2247 if (!io || !argsv || !IoIFP(io)) {
2248 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2249 report_evil_fh(gv, io, PL_op->op_type);
2250 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2254 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2257 s = SvPV_force(argsv, len);
2258 need = IOCPARM_LEN(func);
2260 s = Sv_Grow(argsv, need + 1);
2261 SvCUR_set(argsv, need);
2264 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2267 retval = SvIV(argsv);
2268 s = INT2PTR(char*,retval); /* ouch */
2271 TAINT_PROPER(PL_op_desc[optype]);
2273 if (optype == OP_IOCTL)
2275 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2277 DIE(aTHX_ "ioctl is not implemented");
2281 DIE(aTHX_ "fcntl is not implemented");
2283 #if defined(OS2) && defined(__EMX__)
2284 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2286 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2290 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2292 if (s[SvCUR(argsv)] != 17)
2293 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2295 s[SvCUR(argsv)] = 0; /* put our null back */
2296 SvSETMAGIC(argsv); /* Assume it has changed */
2305 PUSHp(zero_but_true, ZBTLEN);
2318 const int argtype = POPi;
2319 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
2321 if (gv && (io = GvIO(gv)))
2327 /* XXX Looks to me like io is always NULL at this point */
2329 (void)PerlIO_flush(fp);
2330 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2333 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2334 report_evil_fh(gv, io, PL_op->op_type);
2336 SETERRNO(EBADF,RMS_IFI);
2341 DIE(aTHX_ PL_no_func, "flock()");
2351 const int protocol = POPi;
2352 const int type = POPi;
2353 const int domain = POPi;
2354 GV * const gv = (GV*)POPs;
2355 register IO * const io = gv ? GvIOn(gv) : NULL;
2359 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2360 report_evil_fh(gv, io, PL_op->op_type);
2361 if (io && IoIFP(io))
2362 do_close(gv, FALSE);
2363 SETERRNO(EBADF,LIB_INVARG);
2368 do_close(gv, FALSE);
2370 TAINT_PROPER("socket");
2371 fd = PerlSock_socket(domain, type, protocol);
2374 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2375 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2376 IoTYPE(io) = IoTYPE_SOCKET;
2377 if (!IoIFP(io) || !IoOFP(io)) {
2378 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2379 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2380 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2383 #if defined(HAS_FCNTL) && defined(F_SETFD)
2384 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2388 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2393 DIE(aTHX_ PL_no_sock_func, "socket");
2399 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2401 const int protocol = POPi;
2402 const int type = POPi;
2403 const int domain = POPi;
2404 GV * const gv2 = (GV*)POPs;
2405 GV * const gv1 = (GV*)POPs;
2406 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2407 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2410 if (!gv1 || !gv2 || !io1 || !io2) {
2411 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2413 report_evil_fh(gv1, io1, PL_op->op_type);
2415 report_evil_fh(gv1, io2, PL_op->op_type);
2417 if (io1 && IoIFP(io1))
2418 do_close(gv1, FALSE);
2419 if (io2 && IoIFP(io2))
2420 do_close(gv2, FALSE);
2425 do_close(gv1, FALSE);
2427 do_close(gv2, FALSE);
2429 TAINT_PROPER("socketpair");
2430 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2432 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2433 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2434 IoTYPE(io1) = IoTYPE_SOCKET;
2435 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2436 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2437 IoTYPE(io2) = IoTYPE_SOCKET;
2438 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2439 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2440 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2441 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2442 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2443 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2444 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2447 #if defined(HAS_FCNTL) && defined(F_SETFD)
2448 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2449 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2454 DIE(aTHX_ PL_no_sock_func, "socketpair");
2462 SV * const addrsv = POPs;
2463 /* OK, so on what platform does bind modify addr? */
2465 GV * const gv = (GV*)POPs;
2466 register IO * const io = GvIOn(gv);
2469 if (!io || !IoIFP(io))
2472 addr = SvPV_const(addrsv, len);
2473 TAINT_PROPER("bind");
2474 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2480 if (ckWARN(WARN_CLOSED))
2481 report_evil_fh(gv, io, PL_op->op_type);
2482 SETERRNO(EBADF,SS_IVCHAN);
2485 DIE(aTHX_ PL_no_sock_func, "bind");
2493 SV * const addrsv = POPs;
2494 GV * const gv = (GV*)POPs;
2495 register IO * const io = GvIOn(gv);
2499 if (!io || !IoIFP(io))
2502 addr = SvPV_const(addrsv, len);
2503 TAINT_PROPER("connect");
2504 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2510 if (ckWARN(WARN_CLOSED))
2511 report_evil_fh(gv, io, PL_op->op_type);
2512 SETERRNO(EBADF,SS_IVCHAN);
2515 DIE(aTHX_ PL_no_sock_func, "connect");
2523 const int backlog = POPi;
2524 GV * const gv = (GV*)POPs;
2525 register IO * const io = gv ? GvIOn(gv) : NULL;
2527 if (!gv || !io || !IoIFP(io))
2530 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2536 if (ckWARN(WARN_CLOSED))
2537 report_evil_fh(gv, io, PL_op->op_type);
2538 SETERRNO(EBADF,SS_IVCHAN);
2541 DIE(aTHX_ PL_no_sock_func, "listen");
2551 char namebuf[MAXPATHLEN];
2552 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2553 Sock_size_t len = sizeof (struct sockaddr_in);
2555 Sock_size_t len = sizeof namebuf;
2557 GV * const ggv = (GV*)POPs;
2558 GV * const ngv = (GV*)POPs;
2567 if (!gstio || !IoIFP(gstio))
2571 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2574 /* Some platforms indicate zero length when an AF_UNIX client is
2575 * not bound. Simulate a non-zero-length sockaddr structure in
2577 namebuf[0] = 0; /* sun_len */
2578 namebuf[1] = AF_UNIX; /* sun_family */
2586 do_close(ngv, FALSE);
2587 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2588 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2589 IoTYPE(nstio) = IoTYPE_SOCKET;
2590 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2591 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2592 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2593 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2596 #if defined(HAS_FCNTL) && defined(F_SETFD)
2597 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2601 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2602 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2604 #ifdef __SCO_VERSION__
2605 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2608 PUSHp(namebuf, len);
2612 if (ckWARN(WARN_CLOSED))
2613 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2614 SETERRNO(EBADF,SS_IVCHAN);
2620 DIE(aTHX_ PL_no_sock_func, "accept");
2628 const int how = POPi;
2629 GV * const gv = (GV*)POPs;
2630 register IO * const io = GvIOn(gv);
2632 if (!io || !IoIFP(io))
2635 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2639 if (ckWARN(WARN_CLOSED))
2640 report_evil_fh(gv, io, PL_op->op_type);
2641 SETERRNO(EBADF,SS_IVCHAN);
2644 DIE(aTHX_ PL_no_sock_func, "shutdown");
2652 const int optype = PL_op->op_type;
2653 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2654 const unsigned int optname = (unsigned int) POPi;
2655 const unsigned int lvl = (unsigned int) POPi;
2656 GV * const gv = (GV*)POPs;
2657 register IO * const io = GvIOn(gv);
2661 if (!io || !IoIFP(io))
2664 fd = PerlIO_fileno(IoIFP(io));
2668 (void)SvPOK_only(sv);
2672 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2679 #if defined(__SYMBIAN32__)
2680 # define SETSOCKOPT_OPTION_VALUE_T void *
2682 # define SETSOCKOPT_OPTION_VALUE_T const char *
2684 /* XXX TODO: We need to have a proper type (a Configure probe,
2685 * etc.) for what the C headers think of the third argument of
2686 * setsockopt(), the option_value read-only buffer: is it
2687 * a "char *", or a "void *", const or not. Some compilers
2688 * don't take kindly to e.g. assuming that "char *" implicitly
2689 * promotes to a "void *", or to explicitly promoting/demoting
2690 * consts to non/vice versa. The "const void *" is the SUS
2691 * definition, but that does not fly everywhere for the above
2693 SETSOCKOPT_OPTION_VALUE_T buf;
2697 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2701 aint = (int)SvIV(sv);
2702 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2705 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2714 if (ckWARN(WARN_CLOSED))
2715 report_evil_fh(gv, io, optype);
2716 SETERRNO(EBADF,SS_IVCHAN);
2721 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2729 const int optype = PL_op->op_type;
2730 GV * const gv = (GV*)POPs;
2731 register IO * const io = GvIOn(gv);
2736 if (!io || !IoIFP(io))
2739 sv = sv_2mortal(newSV(257));
2740 (void)SvPOK_only(sv);
2744 fd = PerlIO_fileno(IoIFP(io));
2746 case OP_GETSOCKNAME:
2747 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2750 case OP_GETPEERNAME:
2751 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2753 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2755 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";
2756 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2757 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2758 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2759 sizeof(u_short) + sizeof(struct in_addr))) {
2766 #ifdef BOGUS_GETNAME_RETURN
2767 /* Interactive Unix, getpeername() and getsockname()
2768 does not return valid namelen */
2769 if (len == BOGUS_GETNAME_RETURN)
2770 len = sizeof(struct sockaddr);
2778 if (ckWARN(WARN_CLOSED))
2779 report_evil_fh(gv, io, optype);
2780 SETERRNO(EBADF,SS_IVCHAN);
2785 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2800 if (PL_op->op_flags & OPf_REF) {
2802 if (PL_op->op_type == OP_LSTAT) {
2803 if (gv != PL_defgv) {
2804 do_fstat_warning_check:
2805 if (ckWARN(WARN_IO))
2806 Perl_warner(aTHX_ packWARN(WARN_IO),
2807 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2808 } else if (PL_laststype != OP_LSTAT)
2809 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2813 if (gv != PL_defgv) {
2814 PL_laststype = OP_STAT;
2816 sv_setpvn(PL_statname, "", 0);
2823 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2824 } else if (IoDIRP(io)) {
2827 PerlLIO_fstat(dirfd(IoDIRP(io)), &PL_statcache);
2829 DIE(aTHX_ PL_no_func, "dirfd");
2832 PL_laststatval = -1;
2838 if (PL_laststatval < 0) {
2839 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2840 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2845 SV* const sv = POPs;
2846 if (SvTYPE(sv) == SVt_PVGV) {
2849 } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2851 if (PL_op->op_type == OP_LSTAT)
2852 goto do_fstat_warning_check;
2854 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2856 if (PL_op->op_type == OP_LSTAT)
2857 goto do_fstat_warning_check;
2858 goto do_fstat_have_io;
2861 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2863 PL_laststype = PL_op->op_type;
2864 if (PL_op->op_type == OP_LSTAT)
2865 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2867 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2868 if (PL_laststatval < 0) {
2869 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2870 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2876 if (gimme != G_ARRAY) {
2877 if (gimme != G_VOID)
2878 XPUSHs(boolSV(max));
2884 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2885 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2886 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2887 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2888 #if Uid_t_size > IVSIZE
2889 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2891 # if Uid_t_sign <= 0
2892 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2894 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2897 #if Gid_t_size > IVSIZE
2898 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2900 # if Gid_t_sign <= 0
2901 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2903 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2906 #ifdef USE_STAT_RDEV
2907 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2909 PUSHs(sv_2mortal(newSVpvs("")));
2911 #if Off_t_size > IVSIZE
2912 PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
2914 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2917 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2918 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2919 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2921 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_atime)));
2922 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_mtime)));
2923 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_ctime)));
2925 #ifdef USE_STAT_BLOCKS
2926 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2927 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2929 PUSHs(sv_2mortal(newSVpvs("")));
2930 PUSHs(sv_2mortal(newSVpvs("")));
2936 /* This macro is used by the stacked filetest operators :
2937 * if the previous filetest failed, short-circuit and pass its value.
2938 * Else, discard it from the stack and continue. --rgs
2940 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2941 if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
2942 else { (void)POPs; PUTBACK; } \
2949 /* Not const, because things tweak this below. Not bool, because there's
2950 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2951 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2952 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2953 /* Giving some sort of initial value silences compilers. */
2955 int access_mode = R_OK;
2957 int access_mode = 0;
2960 /* access_mode is never used, but leaving use_access in makes the
2961 conditional compiling below much clearer. */
2964 int stat_mode = S_IRUSR;
2966 bool effective = FALSE;
2969 STACKED_FTEST_CHECK;
2971 switch (PL_op->op_type) {
2973 #if !(defined(HAS_ACCESS) && defined(R_OK))
2979 #if defined(HAS_ACCESS) && defined(W_OK)
2984 stat_mode = S_IWUSR;
2988 #if defined(HAS_ACCESS) && defined(X_OK)
2993 stat_mode = S_IXUSR;
2997 #ifdef PERL_EFF_ACCESS
3000 stat_mode = S_IWUSR;
3004 #ifndef PERL_EFF_ACCESS
3012 #ifdef PERL_EFF_ACCESS
3017 stat_mode = S_IXUSR;
3023 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3024 const char *name = POPpx;
3026 # ifdef PERL_EFF_ACCESS
3027 result = PERL_EFF_ACCESS(name, access_mode);
3029 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3035 result = access(name, access_mode);
3037 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3052 if (cando(stat_mode, effective, &PL_statcache))
3061 const int op_type = PL_op->op_type;
3063 STACKED_FTEST_CHECK;
3068 if (op_type == OP_FTIS)
3071 /* You can't dTARGET inside OP_FTIS, because you'll get
3072 "panic: pad_sv po" - the op is not flagged to have a target. */
3076 #if Off_t_size > IVSIZE
3077 PUSHn(PL_statcache.st_size);
3079 PUSHi(PL_statcache.st_size);
3083 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3086 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3089 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3102 /* I believe that all these three are likely to be defined on most every
3103 system these days. */
3105 if(PL_op->op_type == OP_FTSUID)
3109 if(PL_op->op_type == OP_FTSGID)
3113 if(PL_op->op_type == OP_FTSVTX)
3117 STACKED_FTEST_CHECK;
3122 switch (PL_op->op_type) {
3124 if (PL_statcache.st_uid == PL_uid)
3128 if (PL_statcache.st_uid == PL_euid)
3132 if (PL_statcache.st_size == 0)
3136 if (S_ISSOCK(PL_statcache.st_mode))
3140 if (S_ISCHR(PL_statcache.st_mode))
3144 if (S_ISBLK(PL_statcache.st_mode))
3148 if (S_ISREG(PL_statcache.st_mode))
3152 if (S_ISDIR(PL_statcache.st_mode))
3156 if (S_ISFIFO(PL_statcache.st_mode))
3161 if (PL_statcache.st_mode & S_ISUID)
3167 if (PL_statcache.st_mode & S_ISGID)
3173 if (PL_statcache.st_mode & S_ISVTX)
3184 I32 result = my_lstat();
3188 if (S_ISLNK(PL_statcache.st_mode))
3201 STACKED_FTEST_CHECK;
3203 if (PL_op->op_flags & OPf_REF)
3205 else if (isGV(TOPs))
3207 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3208 gv = (GV*)SvRV(POPs);
3210 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3212 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3213 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3214 else if (tmpsv && SvOK(tmpsv)) {
3215 const char *tmps = SvPV_nolen_const(tmpsv);
3223 if (PerlLIO_isatty(fd))
3228 #if defined(atarist) /* this will work with atariST. Configure will
3229 make guesses for other systems. */
3230 # define FILE_base(f) ((f)->_base)
3231 # define FILE_ptr(f) ((f)->_ptr)
3232 # define FILE_cnt(f) ((f)->_cnt)
3233 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3244 register STDCHAR *s;
3250 STACKED_FTEST_CHECK;
3252 if (PL_op->op_flags & OPf_REF)
3254 else if (isGV(TOPs))
3256 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3257 gv = (GV*)SvRV(POPs);
3263 if (gv == PL_defgv) {
3265 io = GvIO(PL_statgv);
3268 goto really_filename;
3273 PL_laststatval = -1;
3274 sv_setpvn(PL_statname, "", 0);
3275 io = GvIO(PL_statgv);
3277 if (io && IoIFP(io)) {
3278 if (! PerlIO_has_base(IoIFP(io)))
3279 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3281 if (PL_laststatval < 0)
3283 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3284 if (PL_op->op_type == OP_FTTEXT)
3289 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3290 i = PerlIO_getc(IoIFP(io));
3292 (void)PerlIO_ungetc(IoIFP(io),i);
3294 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3296 len = PerlIO_get_bufsiz(IoIFP(io));
3297 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3298 /* sfio can have large buffers - limit to 512 */
3303 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3305 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3307 SETERRNO(EBADF,RMS_IFI);
3315 PL_laststype = OP_STAT;
3316 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3317 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3318 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3320 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3323 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3324 if (PL_laststatval < 0) {
3325 (void)PerlIO_close(fp);
3328 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3329 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3330 (void)PerlIO_close(fp);
3332 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3333 RETPUSHNO; /* special case NFS directories */
3334 RETPUSHYES; /* null file is anything */
3339 /* now scan s to look for textiness */
3340 /* XXX ASCII dependent code */
3342 #if defined(DOSISH) || defined(USEMYBINMODE)
3343 /* ignore trailing ^Z on short files */
3344 if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3348 for (i = 0; i < len; i++, s++) {
3349 if (!*s) { /* null never allowed in text */
3354 else if (!(isPRINT(*s) || isSPACE(*s)))
3357 else if (*s & 128) {
3359 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3362 /* utf8 characters don't count as odd */
3363 if (UTF8_IS_START(*s)) {
3364 int ulen = UTF8SKIP(s);
3365 if (ulen < len - i) {
3367 for (j = 1; j < ulen; j++) {
3368 if (!UTF8_IS_CONTINUATION(s[j]))
3371 --ulen; /* loop does extra increment */
3381 *s != '\n' && *s != '\r' && *s != '\b' &&
3382 *s != '\t' && *s != '\f' && *s != 27)
3387 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3398 const char *tmps = NULL;
3402 SV * const sv = POPs;
3403 if (PL_op->op_flags & OPf_SPECIAL) {
3404 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3406 else if (SvTYPE(sv) == SVt_PVGV) {
3409 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
3413 tmps = SvPVx_nolen_const(sv);
3417 if( !gv && (!tmps || !*tmps) ) {
3418 HV * const table = GvHVn(PL_envgv);
3421 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3422 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3424 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3429 deprecate("chdir('') or chdir(undef) as chdir()");
3430 tmps = SvPV_nolen_const(*svp);
3434 TAINT_PROPER("chdir");
3439 TAINT_PROPER("chdir");
3442 IO* const io = GvIO(gv);
3445 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3447 else if (IoDIRP(io)) {
3449 PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0);
3451 DIE(aTHX_ PL_no_func, "dirfd");
3455 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3456 report_evil_fh(gv, io, PL_op->op_type);
3457 SETERRNO(EBADF, RMS_IFI);
3462 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3463 report_evil_fh(gv, io, PL_op->op_type);
3464 SETERRNO(EBADF,RMS_IFI);
3468 DIE(aTHX_ PL_no_func, "fchdir");
3472 PUSHi( PerlDir_chdir(tmps) >= 0 );
3474 /* Clear the DEFAULT element of ENV so we'll get the new value
3476 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3483 dVAR; dSP; dMARK; dTARGET;
3484 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3495 char * const tmps = POPpx;
3496 TAINT_PROPER("chroot");
3497 PUSHi( chroot(tmps) >= 0 );
3500 DIE(aTHX_ PL_no_func, "chroot");
3508 const char * const tmps2 = POPpconstx;
3509 const char * const tmps = SvPV_nolen_const(TOPs);
3510 TAINT_PROPER("rename");
3512 anum = PerlLIO_rename(tmps, tmps2);
3514 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3515 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3518 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3519 (void)UNLINK(tmps2);
3520 if (!(anum = link(tmps, tmps2)))
3521 anum = UNLINK(tmps);
3529 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3533 const int op_type = PL_op->op_type;
3537 if (op_type == OP_LINK)
3538 DIE(aTHX_ PL_no_func, "link");
3540 # ifndef HAS_SYMLINK
3541 if (op_type == OP_SYMLINK)
3542 DIE(aTHX_ PL_no_func, "symlink");
3546 const char * const tmps2 = POPpconstx;
3547 const char * const tmps = SvPV_nolen_const(TOPs);
3548 TAINT_PROPER(PL_op_desc[op_type]);
3550 # if defined(HAS_LINK)
3551 # if defined(HAS_SYMLINK)
3552 /* Both present - need to choose which. */
3553 (op_type == OP_LINK) ?
3554 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3556 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3557 PerlLIO_link(tmps, tmps2);
3560 # if defined(HAS_SYMLINK)
3561 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3562 symlink(tmps, tmps2);
3567 SETi( result >= 0 );
3574 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3585 char buf[MAXPATHLEN];
3588 #ifndef INCOMPLETE_TAINTS
3592 len = readlink(tmps, buf, sizeof(buf) - 1);
3600 RETSETUNDEF; /* just pretend it's a normal file */
3604 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3606 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3608 char * const save_filename = filename;
3613 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3615 Newx(cmdline, size, char);
3616 my_strlcpy(cmdline, cmd, size);
3617 my_strlcat(cmdline, " ", size);
3618 for (s = cmdline + strlen(cmdline); *filename; ) {
3622 if (s - cmdline < size)
3623 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3624 myfp = PerlProc_popen(cmdline, "r");
3628 SV * const tmpsv = sv_newmortal();
3629 /* Need to save/restore 'PL_rs' ?? */
3630 s = sv_gets(tmpsv, myfp, 0);
3631 (void)PerlProc_pclose(myfp);
3635 #ifdef HAS_SYS_ERRLIST
3640 /* you don't see this */
3641 const char * const errmsg =
3642 #ifdef HAS_SYS_ERRLIST
3650 if (instr(s, errmsg)) {
3657 #define EACCES EPERM
3659 if (instr(s, "cannot make"))
3660 SETERRNO(EEXIST,RMS_FEX);
3661 else if (instr(s, "existing file"))
3662 SETERRNO(EEXIST,RMS_FEX);
3663 else if (instr(s, "ile exists"))
3664 SETERRNO(EEXIST,RMS_FEX);
3665 else if (instr(s, "non-exist"))
3666 SETERRNO(ENOENT,RMS_FNF);
3667 else if (instr(s, "does not exist"))
3668 SETERRNO(ENOENT,RMS_FNF);
3669 else if (instr(s, "not empty"))
3670 SETERRNO(EBUSY,SS_DEVOFFLINE);
3671 else if (instr(s, "cannot access"))
3672 SETERRNO(EACCES,RMS_PRV);
3674 SETERRNO(EPERM,RMS_PRV);
3677 else { /* some mkdirs return no failure indication */
3678 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3679 if (PL_op->op_type == OP_RMDIR)
3684 SETERRNO(EACCES,RMS_PRV); /* a guess */
3693 /* This macro removes trailing slashes from a directory name.
3694 * Different operating and file systems take differently to
3695 * trailing slashes. According to POSIX 1003.1 1996 Edition
3696 * any number of trailing slashes should be allowed.
3697 * Thusly we snip them away so that even non-conforming
3698 * systems are happy.
3699 * We should probably do this "filtering" for all
3700 * the functions that expect (potentially) directory names:
3701 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3702 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3704 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3705 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3708 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3709 (tmps) = savepvn((tmps), (len)); \
3719 const int mode = (MAXARG > 1) ? POPi : 0777;
3721 TRIMSLASHES(tmps,len,copy);
3723 TAINT_PROPER("mkdir");
3725 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3729 SETi( dooneliner("mkdir", tmps) );
3730 oldumask = PerlLIO_umask(0);
3731 PerlLIO_umask(oldumask);
3732 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3747 TRIMSLASHES(tmps,len,copy);
3748 TAINT_PROPER("rmdir");
3750 SETi( PerlDir_rmdir(tmps) >= 0 );
3752 SETi( dooneliner("rmdir", tmps) );
3759 /* Directory calls. */
3763 #if defined(Direntry_t) && defined(HAS_READDIR)
3765 const char * const dirname = POPpconstx;
3766 GV * const gv = (GV*)POPs;
3767 register IO * const io = GvIOn(gv);
3773 PerlDir_close(IoDIRP(io));
3774 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3780 SETERRNO(EBADF,RMS_DIR);
3783 DIE(aTHX_ PL_no_dir_func, "opendir");
3789 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3790 DIE(aTHX_ PL_no_dir_func, "readdir");
3792 #if !defined(I_DIRENT) && !defined(VMS)
3793 Direntry_t *readdir (DIR *);
3799 const I32 gimme = GIMME;
3800 GV * const gv = (GV *)POPs;
3801 register const Direntry_t *dp;
3802 register IO * const io = GvIOn(gv);
3804 if (!io || !IoDIRP(io)) {
3805 if(ckWARN(WARN_IO)) {
3806 Perl_warner(aTHX_ packWARN(WARN_IO),
3807 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3813 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3817 sv = newSVpvn(dp->d_name, dp->d_namlen);
3819 sv = newSVpv(dp->d_name, 0);
3821 #ifndef INCOMPLETE_TAINTS
3822 if (!(IoFLAGS(io) & IOf_UNTAINT))
3825 XPUSHs(sv_2mortal(sv));
3826 } while (gimme == G_ARRAY);
3828 if (!dp && gimme != G_ARRAY)
3835 SETERRNO(EBADF,RMS_ISI);
3836 if (GIMME == G_ARRAY)
3845 #if defined(HAS_TELLDIR) || defined(telldir)
3847 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3848 /* XXX netbsd still seemed to.
3849 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3850 --JHI 1999-Feb-02 */
3851 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3852 long telldir (DIR *);
3854 GV * const gv = (GV*)POPs;
3855 register IO * const io = GvIOn(gv);
3857 if (!io || !IoDIRP(io)) {
3858 if(ckWARN(WARN_IO)) {
3859 Perl_warner(aTHX_ packWARN(WARN_IO),
3860 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3865 PUSHi( PerlDir_tell(IoDIRP(io)) );
3869 SETERRNO(EBADF,RMS_ISI);
3872 DIE(aTHX_ PL_no_dir_func, "telldir");
3878 #if defined(HAS_SEEKDIR) || defined(seekdir)
3880 const long along = POPl;
3881 GV * const gv = (GV*)POPs;
3882 register IO * const io = GvIOn(gv);
3884 if (!io || !IoDIRP(io)) {
3885 if(ckWARN(WARN_IO)) {
3886 Perl_warner(aTHX_ packWARN(WARN_IO),
3887 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3891 (void)PerlDir_seek(IoDIRP(io), along);
3896 SETERRNO(EBADF,RMS_ISI);
3899 DIE(aTHX_ PL_no_dir_func, "seekdir");
3905 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3907 GV * const gv = (GV*)POPs;
3908 register IO * const io = GvIOn(gv);
3910 if (!io || !IoDIRP(io)) {
3911 if(ckWARN(WARN_IO)) {
3912 Perl_warner(aTHX_ packWARN(WARN_IO),
3913 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3917 (void)PerlDir_rewind(IoDIRP(io));
3921 SETERRNO(EBADF,RMS_ISI);
3924 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3930 #if defined(Direntry_t) && defined(HAS_READDIR)
3932 GV * const gv = (GV*)POPs;
3933 register IO * const io = GvIOn(gv);
3935 if (!io || !IoDIRP(io)) {
3936 if(ckWARN(WARN_IO)) {
3937 Perl_warner(aTHX_ packWARN(WARN_IO),
3938 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3942 #ifdef VOID_CLOSEDIR
3943 PerlDir_close(IoDIRP(io));
3945 if (PerlDir_close(IoDIRP(io)) < 0) {
3946 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3955 SETERRNO(EBADF,RMS_IFI);
3958 DIE(aTHX_ PL_no_dir_func, "closedir");
3962 /* Process control. */
3971 PERL_FLUSHALL_FOR_CHILD;
3972 childpid = PerlProc_fork();
3976 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3978 SvREADONLY_off(GvSV(tmpgv));
3979 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3980 SvREADONLY_on(GvSV(tmpgv));
3982 #ifdef THREADS_HAVE_PIDS
3983 PL_ppid = (IV)getppid();
3985 #ifdef PERL_USES_PL_PIDSTATUS
3986 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3992 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3997 PERL_FLUSHALL_FOR_CHILD;
3998 childpid = PerlProc_fork();
4004 DIE(aTHX_ PL_no_func, "fork");
4011 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4016 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4017 childpid = wait4pid(-1, &argflags, 0);
4019 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4024 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4025 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4026 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4028 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4033 DIE(aTHX_ PL_no_func, "wait");
4039 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4041 const int optype = POPi;
4042 const Pid_t pid = TOPi;
4046 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4047 result = wait4pid(pid, &argflags, optype);
4049 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4054 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4055 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4056 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4058 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4063 DIE(aTHX_ PL_no_func, "waitpid");
4069 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4075 while (++MARK <= SP) {
4076 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4081 TAINT_PROPER("system");
4083 PERL_FLUSHALL_FOR_CHILD;
4084 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4090 if (PerlProc_pipe(pp) >= 0)
4092 while ((childpid = PerlProc_fork()) == -1) {
4093 if (errno != EAGAIN) {
4098 PerlLIO_close(pp[0]);
4099 PerlLIO_close(pp[1]);
4106 Sigsave_t ihand,qhand; /* place to save signals during system() */
4110 PerlLIO_close(pp[1]);
4112 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4113 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4116 result = wait4pid(childpid, &status, 0);
4117 } while (result == -1 && errno == EINTR);
4119 (void)rsignal_restore(SIGINT, &ihand);
4120 (void)rsignal_restore(SIGQUIT, &qhand);
4122 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4123 do_execfree(); /* free any memory child malloced on fork */
4130 while (n < sizeof(int)) {
4131 n1 = PerlLIO_read(pp[0],
4132 (void*)(((char*)&errkid)+n),
4138 PerlLIO_close(pp[0]);
4139 if (n) { /* Error */
4140 if (n != sizeof(int))
4141 DIE(aTHX_ "panic: kid popen errno read");
4142 errno = errkid; /* Propagate errno from kid */
4143 STATUS_NATIVE_CHILD_SET(-1);
4146 XPUSHi(STATUS_CURRENT);
4150 PerlLIO_close(pp[0]);
4151 #if defined(HAS_FCNTL) && defined(F_SETFD)
4152 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4155 if (PL_op->op_flags & OPf_STACKED) {
4156 SV * const really = *++MARK;
4157 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4159 else if (SP - MARK != 1)
4160 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4162 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4166 #else /* ! FORK or VMS or OS/2 */
4169 if (PL_op->op_flags & OPf_STACKED) {
4170 SV * const really = *++MARK;
4171 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4172 value = (I32)do_aspawn(really, MARK, SP);
4174 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4177 else if (SP - MARK != 1) {
4178 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4179 value = (I32)do_aspawn(NULL, MARK, SP);
4181 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4185 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4187 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4189 STATUS_NATIVE_CHILD_SET(value);
4192 XPUSHi(result ? value : STATUS_CURRENT);
4193 #endif /* !FORK or VMS */
4199 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4204 while (++MARK <= SP) {
4205 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4210 TAINT_PROPER("exec");
4212 PERL_FLUSHALL_FOR_CHILD;
4213 if (PL_op->op_flags & OPf_STACKED) {
4214 SV * const really = *++MARK;
4215 value = (I32)do_aexec(really, MARK, SP);
4217 else if (SP - MARK != 1)
4219 value = (I32)vms_do_aexec(NULL, MARK, SP);
4223 (void ) do_aspawn(NULL, MARK, SP);
4227 value = (I32)do_aexec(NULL, MARK, SP);
4232 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4235 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4238 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4252 # ifdef THREADS_HAVE_PIDS
4253 if (PL_ppid != 1 && getppid() == 1)
4254 /* maybe the parent process has died. Refresh ppid cache */
4258 XPUSHi( getppid() );
4262 DIE(aTHX_ PL_no_func, "getppid");
4271 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4274 pgrp = (I32)BSD_GETPGRP(pid);
4276 if (pid != 0 && pid != PerlProc_getpid())
4277 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4283 DIE(aTHX_ PL_no_func, "getpgrp()");
4302 TAINT_PROPER("setpgrp");
4304 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4306 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4307 || (pid != 0 && pid != PerlProc_getpid()))
4309 DIE(aTHX_ "setpgrp can't take arguments");
4311 SETi( setpgrp() >= 0 );
4312 #endif /* USE_BSDPGRP */
4315 DIE(aTHX_ PL_no_func, "setpgrp()");
4321 #ifdef HAS_GETPRIORITY
4323 const int who = POPi;
4324 const int which = TOPi;
4325 SETi( getpriority(which, who) );
4328 DIE(aTHX_ PL_no_func, "getpriority()");
4334 #ifdef HAS_SETPRIORITY
4336 const int niceval = POPi;
4337 const int who = POPi;
4338 const int which = TOPi;
4339 TAINT_PROPER("setpriority");
4340 SETi( setpriority(which, who, niceval) >= 0 );
4343 DIE(aTHX_ PL_no_func, "setpriority()");
4353 XPUSHn( time(NULL) );
4355 XPUSHi( time(NULL) );
4367 (void)PerlProc_times(&PL_timesbuf);
4369 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4370 /* struct tms, though same data */
4374 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
4375 if (GIMME == G_ARRAY) {
4376 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
4377 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
4378 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
4384 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4386 if (GIMME == G_ARRAY) {
4387 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4388 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4389 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4393 DIE(aTHX_ "times not implemented");
4395 #endif /* HAS_TIMES */
4398 #ifdef LOCALTIME_EDGECASE_BROKEN
4399 static struct tm *S_my_localtime (pTHX_ Time_t *tp)
4404 /* No workarounds in the valid range */
4405 if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4406 return (localtime (tp));
4408 /* This edge case is to workaround the undefined behaviour, where the
4409 * TIMEZONE makes the time go beyond the defined range.
4410 * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4411 * If there is a negative offset in TZ, like MET-1METDST, some broken
4412 * implementations of localtime () (like AIX 5.2) barf with bogus
4414 * 0x7fffffff gmtime 2038-01-19 03:14:07
4415 * 0x7fffffff localtime 1901-12-13 21:45:51
4416 * 0x7fffffff mylocaltime 2038-01-19 04:14:07
4417 * 0x3c19137f gmtime 2001-12-13 20:45:51
4418 * 0x3c19137f localtime 2001-12-13 21:45:51
4419 * 0x3c19137f mylocaltime 2001-12-13 21:45:51
4420 * Given that legal timezones are typically between GMT-12 and GMT+12
4421 * we turn back the clock 23 hours before calling the localtime
4422 * function, and add those to the return value. This will never cause
4423 * day wrapping problems, since the edge case is Tue Jan *19*
4425 T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4428 if (P->tm_hour >= 24) {
4430 P->tm_mday++; /* 18 -> 19 */
4431 P->tm_wday++; /* Mon -> Tue */
4432 P->tm_yday++; /* 18 -> 19 */
4435 } /* S_my_localtime */
4443 const struct tm *tmbuf;
4444 static const char * const dayname[] =
4445 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4446 static const char * const monname[] =
4447 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4448 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4454 when = (Time_t)SvNVx(POPs);
4456 when = (Time_t)SvIVx(POPs);
4459 if (PL_op->op_type == OP_LOCALTIME)
4460 #ifdef LOCALTIME_EDGECASE_BROKEN
4461 tmbuf = S_my_localtime(aTHX_ &when);
4463 tmbuf = localtime(&when);
4466 tmbuf = gmtime(&when);
4468 if (GIMME != G_ARRAY) {
4474 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4475 dayname[tmbuf->tm_wday],
4476 monname[tmbuf->tm_mon],
4481 tmbuf->tm_year + 1900);
4482 PUSHs(sv_2mortal(tsv));
4487 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4488 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4489 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4490 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4491 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4492 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4493 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4494 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4495 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4506 anum = alarm((unsigned int)anum);
4513 DIE(aTHX_ PL_no_func, "alarm");
4524 (void)time(&lasttime);
4529 PerlProc_sleep((unsigned int)duration);
4532 XPUSHi(when - lasttime);
4536 /* Shared memory. */
4537 /* Merged with some message passing. */
4541 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4542 dVAR; dSP; dMARK; dTARGET;
4543 const int op_type = PL_op->op_type;
4548 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4551 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4554 value = (I32)(do_semop(MARK, SP) >= 0);
4557 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4573 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4574 dVAR; dSP; dMARK; dTARGET;
4575 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4582 DIE(aTHX_ "System V IPC is not implemented on this machine");
4588 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4589 dVAR; dSP; dMARK; dTARGET;
4590 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4598 PUSHp(zero_but_true, ZBTLEN);
4606 /* I can't const this further without getting warnings about the types of
4607 various arrays passed in from structures. */
4609 S_space_join_names_mortal(pTHX_ char *const *array)
4613 if (array && *array) {
4614 target = sv_2mortal(newSVpvs(""));
4616 sv_catpv(target, *array);
4619 sv_catpvs(target, " ");
4622 target = sv_mortalcopy(&PL_sv_no);
4627 /* Get system info. */
4631 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4633 I32 which = PL_op->op_type;
4634 register char **elem;
4636 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4637 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4638 struct hostent *gethostbyname(Netdb_name_t);
4639 struct hostent *gethostent(void);
4641 struct hostent *hent;
4645 if (which == OP_GHBYNAME) {
4646 #ifdef HAS_GETHOSTBYNAME
4647 const char* const name = POPpbytex;
4648 hent = PerlSock_gethostbyname(name);
4650 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4653 else if (which == OP_GHBYADDR) {
4654 #ifdef HAS_GETHOSTBYADDR
4655 const int addrtype = POPi;
4656 SV * const addrsv = POPs;
4658 Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4660 hent = PerlSock_gethostbyaddr((const char*)addr, (Netdb_hlen_t) addrlen, addrtype);
4662 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4666 #ifdef HAS_GETHOSTENT
4667 hent = PerlSock_gethostent();
4669 DIE(aTHX_ PL_no_sock_func, "gethostent");
4672 #ifdef HOST_NOT_FOUND
4674 #ifdef USE_REENTRANT_API
4675 # ifdef USE_GETHOSTENT_ERRNO
4676 h_errno = PL_reentrant_buffer->_gethostent_errno;
4679 STATUS_UNIX_SET(h_errno);
4683 if (GIMME != G_ARRAY) {
4684 PUSHs(sv = sv_newmortal());
4686 if (which == OP_GHBYNAME) {
4688 sv_setpvn(sv, hent->h_addr, hent->h_length);
4691 sv_setpv(sv, (char*)hent->h_name);
4697 PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
4698 PUSHs(space_join_names_mortal(hent->h_aliases));
4699 PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
4700 len = hent->h_length;
4701 PUSHs(sv_2mortal(newSViv((IV)len)));
4703 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4704 XPUSHs(sv_2mortal(newSVpvn(*elem, len)));
4708 PUSHs(newSVpvn(hent->h_addr, len));
4710 PUSHs(sv_mortalcopy(&PL_sv_no));
4715 DIE(aTHX_ PL_no_sock_func, "gethostent");
4721 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4723 I32 which = PL_op->op_type;
4725 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4726 struct netent *getnetbyaddr(Netdb_net_t, int);
4727 struct netent *getnetbyname(Netdb_name_t);
4728 struct netent *getnetent(void);
4730 struct netent *nent;
4732 if (which == OP_GNBYNAME){
4733 #ifdef HAS_GETNETBYNAME
4734 const char * const name = POPpbytex;
4735 nent = PerlSock_getnetbyname(name);
4737 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4740 else if (which == OP_GNBYADDR) {
4741 #ifdef HAS_GETNETBYADDR
4742 const int addrtype = POPi;
4743 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4744 nent = PerlSock_getnetbyaddr(addr, addrtype);
4746 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4750 #ifdef HAS_GETNETENT
4751 nent = PerlSock_getnetent();
4753 DIE(aTHX_ PL_no_sock_func, "getnetent");
4756 #ifdef HOST_NOT_FOUND
4758 #ifdef USE_REENTRANT_API
4759 # ifdef USE_GETNETENT_ERRNO
4760 h_errno = PL_reentrant_buffer->_getnetent_errno;
4763 STATUS_UNIX_SET(h_errno);
4768 if (GIMME != G_ARRAY) {
4769 PUSHs(sv = sv_newmortal());
4771 if (which == OP_GNBYNAME)
4772 sv_setiv(sv, (IV)nent->n_net);
4774 sv_setpv(sv, nent->n_name);
4780 PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
4781 PUSHs(space_join_names_mortal(nent->n_aliases));
4782 PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
4783 PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
4788 DIE(aTHX_ PL_no_sock_func, "getnetent");
4794 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4796 I32 which = PL_op->op_type;
4798 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4799 struct protoent *getprotobyname(Netdb_name_t);
4800 struct protoent *getprotobynumber(int);
4801 struct protoent *getprotoent(void);
4803 struct protoent *pent;
4805 if (which == OP_GPBYNAME) {
4806 #ifdef HAS_GETPROTOBYNAME
4807 const char* const name = POPpbytex;
4808 pent = PerlSock_getprotobyname(name);
4810 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4813 else if (which == OP_GPBYNUMBER) {
4814 #ifdef HAS_GETPROTOBYNUMBER
4815 const int number = POPi;
4816 pent = PerlSock_getprotobynumber(number);
4818 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4822 #ifdef HAS_GETPROTOENT
4823 pent = PerlSock_getprotoent();
4825 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4829 if (GIMME != G_ARRAY) {
4830 PUSHs(sv = sv_newmortal());
4832 if (which == OP_GPBYNAME)
4833 sv_setiv(sv, (IV)pent->p_proto);
4835 sv_setpv(sv, pent->p_name);
4841 PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
4842 PUSHs(space_join_names_mortal(pent->p_aliases));
4843 PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
4848 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4854 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4856 I32 which = PL_op->op_type;
4858 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4859 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4860 struct servent *getservbyport(int, Netdb_name_t);
4861 struct servent *getservent(void);
4863 struct servent *sent;
4865 if (which == OP_GSBYNAME) {
4866 #ifdef HAS_GETSERVBYNAME
4867 const char * const proto = POPpbytex;
4868 const char * const name = POPpbytex;
4869 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4871 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4874 else if (which == OP_GSBYPORT) {
4875 #ifdef HAS_GETSERVBYPORT
4876 const char * const proto = POPpbytex;
4877 unsigned short port = (unsigned short)POPu;
4879 port = PerlSock_htons(port);
4881 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4883 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4887 #ifdef HAS_GETSERVENT
4888 sent = PerlSock_getservent();
4890 DIE(aTHX_ PL_no_sock_func, "getservent");
4894 if (GIMME != G_ARRAY) {
4895 PUSHs(sv = sv_newmortal());
4897 if (which == OP_GSBYNAME) {
4899 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4901 sv_setiv(sv, (IV)(sent->s_port));
4905 sv_setpv(sv, sent->s_name);
4911 PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
4912 PUSHs(space_join_names_mortal(sent->s_aliases));
4914 PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
4916 PUSHs(sv_2mortal(newSViv((IV)(sent->s_port))));
4918 PUSHs(sv_2mortal(newSVpv(sent->s_proto, 0)));
4923 DIE(aTHX_ PL_no_sock_func, "getservent");
4929 #ifdef HAS_SETHOSTENT
4931 PerlSock_sethostent(TOPi);
4934 DIE(aTHX_ PL_no_sock_func, "sethostent");
4940 #ifdef HAS_SETNETENT
4942 PerlSock_setnetent(TOPi);
4945 DIE(aTHX_ PL_no_sock_func, "setnetent");
4951 #ifdef HAS_SETPROTOENT
4953 PerlSock_setprotoent(TOPi);
4956 DIE(aTHX_ PL_no_sock_func, "setprotoent");
4962 #ifdef HAS_SETSERVENT
4964 PerlSock_setservent(TOPi);
4967 DIE(aTHX_ PL_no_sock_func, "setservent");
4973 #ifdef HAS_ENDHOSTENT
4975 PerlSock_endhostent();
4979 DIE(aTHX_ PL_no_sock_func, "endhostent");
4985 #ifdef HAS_ENDNETENT
4987 PerlSock_endnetent();
4991 DIE(aTHX_ PL_no_sock_func, "endnetent");
4997 #ifdef HAS_ENDPROTOENT
4999 PerlSock_endprotoent();
5003 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5009 #ifdef HAS_ENDSERVENT
5011 PerlSock_endservent();
5015 DIE(aTHX_ PL_no_sock_func, "endservent");
5023 I32 which = PL_op->op_type;
5025 struct passwd *pwent = NULL;
5027 * We currently support only the SysV getsp* shadow password interface.
5028 * The interface is declared in <shadow.h> and often one needs to link
5029 * with -lsecurity or some such.
5030 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5033 * AIX getpwnam() is clever enough to return the encrypted password
5034 * only if the caller (euid?) is root.
5036 * There are at least three other shadow password APIs. Many platforms
5037 * seem to contain more than one interface for accessing the shadow
5038 * password databases, possibly for compatibility reasons.
5039 * The getsp*() is by far he simplest one, the other two interfaces
5040 * are much more complicated, but also very similar to each other.
5045 * struct pr_passwd *getprpw*();
5046 * The password is in
5047 * char getprpw*(...).ufld.fd_encrypt[]
5048 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5053 * struct es_passwd *getespw*();
5054 * The password is in
5055 * char *(getespw*(...).ufld.fd_encrypt)
5056 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5059 * struct userpw *getuserpw();
5060 * The password is in
5061 * char *(getuserpw(...)).spw_upw_passwd
5062 * (but the de facto standard getpwnam() should work okay)
5064 * Mention I_PROT here so that Configure probes for it.
5066 * In HP-UX for getprpw*() the manual page claims that one should include
5067 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5068 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5069 * and pp_sys.c already includes <shadow.h> if there is such.
5071 * Note that <sys/security.h> is already probed for, but currently
5072 * it is only included in special cases.
5074 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5075 * be preferred interface, even though also the getprpw*() interface
5076 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5077 * One also needs to call set_auth_parameters() in main() before
5078 * doing anything else, whether one is using getespw*() or getprpw*().
5080 * Note that accessing the shadow databases can be magnitudes
5081 * slower than accessing the standard databases.
5086 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5087 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5088 * the pw_comment is left uninitialized. */
5089 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5095 const char* const name = POPpbytex;
5096 pwent = getpwnam(name);
5102 pwent = getpwuid(uid);
5106 # ifdef HAS_GETPWENT
5108 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5109 if (pwent) pwent = getpwnam(pwent->pw_name);
5112 DIE(aTHX_ PL_no_func, "getpwent");
5118 if (GIMME != G_ARRAY) {
5119 PUSHs(sv = sv_newmortal());
5121 if (which == OP_GPWNAM)
5122 # if Uid_t_sign <= 0
5123 sv_setiv(sv, (IV)pwent->pw_uid);
5125 sv_setuv(sv, (UV)pwent->pw_uid);
5128 sv_setpv(sv, pwent->pw_name);
5134 PUSHs(sv_2mortal(newSVpv(pwent->pw_name, 0)));
5136 PUSHs(sv = sv_2mortal(newSViv(0)));
5137 /* If we have getspnam(), we try to dig up the shadow
5138 * password. If we are underprivileged, the shadow
5139 * interface will set the errno to EACCES or similar,
5140 * and return a null pointer. If this happens, we will
5141 * use the dummy password (usually "*" or "x") from the
5142 * standard password database.
5144 * In theory we could skip the shadow call completely
5145 * if euid != 0 but in practice we cannot know which
5146 * security measures are guarding the shadow databases
5147 * on a random platform.
5149 * Resist the urge to use additional shadow interfaces.
5150 * Divert the urge to writing an extension instead.
5153 /* Some AIX setups falsely(?) detect some getspnam(), which
5154 * has a different API than the Solaris/IRIX one. */
5155 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5157 const int saverrno = errno;
5158 const struct spwd * const spwent = getspnam(pwent->pw_name);
5159 /* Save and restore errno so that
5160 * underprivileged attempts seem
5161 * to have never made the unsccessful
5162 * attempt to retrieve the shadow password. */
5164 if (spwent && spwent->sp_pwdp)
5165 sv_setpv(sv, spwent->sp_pwdp);
5169 if (!SvPOK(sv)) /* Use the standard password, then. */
5170 sv_setpv(sv, pwent->pw_passwd);
5173 # ifndef INCOMPLETE_TAINTS
5174 /* passwd is tainted because user himself can diddle with it.
5175 * admittedly not much and in a very limited way, but nevertheless. */
5179 # if Uid_t_sign <= 0
5180 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_uid)));
5182 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_uid)));
5185 # if Uid_t_sign <= 0
5186 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_gid)));
5188 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_gid)));
5190 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5191 * because of the poor interface of the Perl getpw*(),
5192 * not because there's some standard/convention saying so.
5193 * A better interface would have been to return a hash,
5194 * but we are accursed by our history, alas. --jhi. */
5196 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_change)));
5199 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_quota)));
5202 PUSHs(sv_2mortal(newSVpv(pwent->pw_age, 0)));
5204 /* I think that you can never get this compiled, but just in case. */
5205 PUSHs(sv_mortalcopy(&PL_sv_no));
5210 /* pw_class and pw_comment are mutually exclusive--.
5211 * see the above note for pw_change, pw_quota, and pw_age. */
5213 PUSHs(sv_2mortal(newSVpv(pwent->pw_class, 0)));
5216 PUSHs(sv_2mortal(newSVpv(pwent->pw_comment, 0)));
5218 /* I think that you can never get this compiled, but just in case. */
5219 PUSHs(sv_mortalcopy(&PL_sv_no));
5224 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5226 PUSHs(sv_mortalcopy(&PL_sv_no));
5228 # ifndef INCOMPLETE_TAINTS
5229 /* pw_gecos is tainted because user himself can diddle with it. */
5233 PUSHs(sv_2mortal(newSVpv(pwent->pw_dir, 0)));
5235 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5236 # ifndef INCOMPLETE_TAINTS
5237 /* pw_shell is tainted because user himself can diddle with it. */
5242 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_expire)));
5247 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5253 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5258 DIE(aTHX_ PL_no_func, "setpwent");
5264 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5269 DIE(aTHX_ PL_no_func, "endpwent");
5277 const I32 which = PL_op->op_type;
5278 const struct group *grent;
5280 if (which == OP_GGRNAM) {
5281 const char* const name = POPpbytex;
5282 grent = (const struct group *)getgrnam(name);
5284 else if (which == OP_GGRGID) {
5285 const Gid_t gid = POPi;
5286 grent = (const struct group *)getgrgid(gid);
5290 grent = (struct group *)getgrent();
5292 DIE(aTHX_ PL_no_func, "getgrent");
5296 if (GIMME != G_ARRAY) {
5297 SV * const sv = sv_newmortal();
5301 if (which == OP_GGRNAM)
5302 sv_setiv(sv, (IV)grent->gr_gid);
5304 sv_setpv(sv, grent->gr_name);
5310 PUSHs(sv_2mortal(newSVpv(grent->gr_name, 0)));
5313 PUSHs(sv_2mortal(newSVpv(grent->gr_passwd, 0)));
5315 PUSHs(sv_mortalcopy(&PL_sv_no));
5318 PUSHs(sv_2mortal(newSViv((IV)grent->gr_gid)));
5320 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5321 /* In UNICOS/mk (_CRAYMPP) the multithreading
5322 * versions (getgrnam_r, getgrgid_r)
5323 * seem to return an illegal pointer
5324 * as the group members list, gr_mem.
5325 * getgrent() doesn't even have a _r version
5326 * but the gr_mem is poisonous anyway.
5327 * So yes, you cannot get the list of group
5328 * members if building multithreaded in UNICOS/mk. */
5329 PUSHs(space_join_names_mortal(grent->gr_mem));
5335 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5341 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5346 DIE(aTHX_ PL_no_func, "setgrent");
5352 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5357 DIE(aTHX_ PL_no_func, "endgrent");
5367 if (!(tmps = PerlProc_getlogin()))
5369 PUSHp(tmps, strlen(tmps));
5372 DIE(aTHX_ PL_no_func, "getlogin");
5376 /* Miscellaneous. */
5381 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5382 register I32 items = SP - MARK;
5383 unsigned long a[20];
5388 while (++MARK <= SP) {
5389 if (SvTAINTED(*MARK)) {
5395 TAINT_PROPER("syscall");
5398 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5399 * or where sizeof(long) != sizeof(char*). But such machines will
5400 * not likely have syscall implemented either, so who cares?
5402 while (++MARK <= SP) {
5403 if (SvNIOK(*MARK) || !i)
5404 a[i++] = SvIV(*MARK);
5405 else if (*MARK == &PL_sv_undef)
5408 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5414 DIE(aTHX_ "Too many args to syscall");
5416 DIE(aTHX_ "Too few args to syscall");
5418 retval = syscall(a[0]);
5421 retval = syscall(a[0],a[1]);
5424 retval = syscall(a[0],a[1],a[2]);
5427 retval = syscall(a[0],a[1],a[2],a[3]);
5430 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5433 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5436 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5439 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5443 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5446 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],
5457 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5461 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5462 a[10],a[11],a[12],a[13]);
5464 #endif /* atarist */
5470 DIE(aTHX_ PL_no_func, "syscall");
5474 #ifdef FCNTL_EMULATE_FLOCK
5476 /* XXX Emulate flock() with fcntl().
5477 What's really needed is a good file locking module.
5481 fcntl_emulate_flock(int fd, int operation)
5485 switch (operation & ~LOCK_NB) {
5487 flock.l_type = F_RDLCK;
5490 flock.l_type = F_WRLCK;
5493 flock.l_type = F_UNLCK;
5499 flock.l_whence = SEEK_SET;
5500 flock.l_start = flock.l_len = (Off_t)0;
5502 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5505 #endif /* FCNTL_EMULATE_FLOCK */
5507 #ifdef LOCKF_EMULATE_FLOCK
5509 /* XXX Emulate flock() with lockf(). This is just to increase
5510 portability of scripts. The calls are not completely
5511 interchangeable. What's really needed is a good file
5515 /* The lockf() constants might have been defined in <unistd.h>.
5516 Unfortunately, <unistd.h> causes troubles on some mixed
5517 (BSD/POSIX) systems, such as SunOS 4.1.3.
5519 Further, the lockf() constants aren't POSIX, so they might not be
5520 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5521 just stick in the SVID values and be done with it. Sigh.
5525 # define F_ULOCK 0 /* Unlock a previously locked region */
5528 # define F_LOCK 1 /* Lock a region for exclusive use */
5531 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5534 # define F_TEST 3 /* Test a region for other processes locks */
5538 lockf_emulate_flock(int fd, int operation)
5541 const int save_errno = errno;
5544 /* flock locks entire file so for lockf we need to do the same */
5545 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5546 if (pos > 0) /* is seekable and needs to be repositioned */
5547 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5548 pos = -1; /* seek failed, so don't seek back afterwards */
5551 switch (operation) {
5553 /* LOCK_SH - get a shared lock */
5555 /* LOCK_EX - get an exclusive lock */
5557 i = lockf (fd, F_LOCK, 0);
5560 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5561 case LOCK_SH|LOCK_NB:
5562 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5563 case LOCK_EX|LOCK_NB:
5564 i = lockf (fd, F_TLOCK, 0);
5566 if ((errno == EAGAIN) || (errno == EACCES))
5567 errno = EWOULDBLOCK;
5570 /* LOCK_UN - unlock (non-blocking is a no-op) */
5572 case LOCK_UN|LOCK_NB:
5573 i = lockf (fd, F_ULOCK, 0);
5576 /* Default - can't decipher operation */
5583 if (pos > 0) /* need to restore position of the handle */
5584 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5589 #endif /* LOCKF_EMULATE_FLOCK */
5593 * c-indentation-style: bsd
5595 * indent-tabs-mode: t
5598 * ex: set ts=8 sts=4 sw=4 noet: