3 * Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 * 2004, 2005, 2006, 2007 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * But only a short way ahead its floor and the walls on either side were
13 * cloven by a great fissure, out of which the red glare came, now leaping
14 * up, now dying down into darkness; and all the while far below there was
15 * a rumour and a trouble as of great engines throbbing and labouring.
18 /* This file contains system pp ("push/pop") functions that
19 * execute the opcodes that make up a perl program. A typical pp function
20 * expects to find its arguments on the stack, and usually pushes its
21 * results onto the stack, hence the 'pp' terminology. Each OP structure
22 * contains a pointer to the relevant pp_foo() function.
24 * By 'system', we mean ops which interact with the OS, such as pp_open().
28 #define PERL_IN_PP_SYS_C
32 /* Shadow password support for solaris - pdo@cs.umd.edu
33 * Not just Solaris: at least HP-UX, IRIX, Linux.
34 * The API is from SysV.
36 * There are at least two more shadow interfaces,
37 * see the comments in pp_gpwent().
41 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
42 * and another MAXINT from "perl.h" <- <sys/param.h>. */
49 # include <sys/wait.h>
53 # include <sys/resource.h>
62 # include <sys/select.h>
66 /* XXX Configure test needed.
67 h_errno might not be a simple 'int', especially for multi-threaded
68 applications, see "extern int errno in perl.h". Creating such
69 a test requires taking into account the differences between
70 compiling multithreaded and singlethreaded ($ccflags et al).
71 HOST_NOT_FOUND is typically defined in <netdb.h>.
73 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
82 struct passwd *getpwnam (char *);
83 struct passwd *getpwuid (Uid_t);
88 struct passwd *getpwent (void);
89 #elif defined (VMS) && defined (my_getpwent)
90 struct passwd *Perl_my_getpwent (pTHX);
99 struct group *getgrnam (char *);
100 struct group *getgrgid (Gid_t);
104 struct group *getgrent (void);
110 # if defined(_MSC_VER) || defined(__MINGW32__)
111 # include <sys/utime.h>
118 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
121 # define my_chsize PerlLIO_chsize
124 # define my_chsize PerlLIO_chsize
126 I32 my_chsize(int fd, Off_t length);
132 #else /* no flock() */
134 /* fcntl.h might not have been included, even if it exists, because
135 the current Configure only sets I_FCNTL if it's needed to pick up
136 the *_OK constants. Make sure it has been included before testing
137 the fcntl() locking constants. */
138 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
142 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
143 # define FLOCK fcntl_emulate_flock
144 # define FCNTL_EMULATE_FLOCK
145 # else /* no flock() or fcntl(F_SETLK,...) */
147 # define FLOCK lockf_emulate_flock
148 # define LOCKF_EMULATE_FLOCK
150 # endif /* no flock() or fcntl(F_SETLK,...) */
153 static int FLOCK (int, int);
156 * These are the flock() constants. Since this sytems doesn't have
157 * flock(), the values of the constants are probably not available.
171 # endif /* emulating flock() */
173 #endif /* no flock() */
176 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
178 #if defined(I_SYS_ACCESS) && !defined(R_OK)
179 # include <sys/access.h>
182 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
183 # define FD_CLOEXEC 1 /* NeXT needs this */
189 /* Missing protos on LynxOS */
190 void sethostent(int);
191 void endhostent(void);
193 void endnetent(void);
194 void setprotoent(int);
195 void endprotoent(void);
196 void setservent(int);
197 void endservent(void);
200 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
202 /* AIX 5.2 and below use mktime for localtime, and defines the edge case
203 * for time 0x7fffffff to be valid only in UTC. AIX 5.3 provides localtime64
204 * available in the 32bit environment, which could warrant Configure
205 * checks in the future.
208 #define LOCALTIME_EDGECASE_BROKEN
211 /* F_OK unused: if stat() cannot find it... */
213 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
214 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
215 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
218 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
219 # ifdef I_SYS_SECURITY
220 # include <sys/security.h>
224 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
227 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
231 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
233 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
237 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
238 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
239 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
242 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
244 const Uid_t ruid = getuid();
245 const Uid_t euid = geteuid();
246 const Gid_t rgid = getgid();
247 const Gid_t egid = getegid();
251 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
252 Perl_croak(aTHX_ "switching effective uid is not implemented");
255 if (setreuid(euid, ruid))
258 if (setresuid(euid, ruid, (Uid_t)-1))
261 Perl_croak(aTHX_ "entering effective uid failed");
264 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
265 Perl_croak(aTHX_ "switching effective gid is not implemented");
268 if (setregid(egid, rgid))
271 if (setresgid(egid, rgid, (Gid_t)-1))
274 Perl_croak(aTHX_ "entering effective gid failed");
277 res = access(path, mode);
280 if (setreuid(ruid, euid))
283 if (setresuid(ruid, euid, (Uid_t)-1))
286 Perl_croak(aTHX_ "leaving effective uid failed");
289 if (setregid(rgid, egid))
292 if (setresgid(rgid, egid, (Gid_t)-1))
295 Perl_croak(aTHX_ "leaving effective gid failed");
300 # define PERL_EFF_ACCESS(p,f) (emulate_eaccess((p), (f)))
303 #if !defined(PERL_EFF_ACCESS)
304 /* With it or without it: anyway you get a warning: either that
305 it is unused, or it is declared static and never defined.
308 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
310 PERL_UNUSED_ARG(path);
311 PERL_UNUSED_ARG(mode);
312 Perl_croak(aTHX_ "switching effective uid is not implemented");
322 const char * const tmps = POPpconstx;
323 const I32 gimme = GIMME_V;
324 const char *mode = "r";
327 if (PL_op->op_private & OPpOPEN_IN_RAW)
329 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
331 fp = PerlProc_popen(tmps, mode);
333 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
335 PerlIO_apply_layers(aTHX_ fp,mode,type);
337 if (gimme == G_VOID) {
339 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
342 else if (gimme == G_SCALAR) {
345 PL_rs = &PL_sv_undef;
346 sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */
347 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
355 SV * const sv = newSV(79);
356 if (sv_gets(sv, fp, 0) == NULL) {
360 XPUSHs(sv_2mortal(sv));
361 if (SvLEN(sv) - SvCUR(sv) > 20) {
362 SvPV_shrink_to_cur(sv);
367 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
368 TAINT; /* "I believe that this is not gratuitous!" */
371 STATUS_NATIVE_CHILD_SET(-1);
372 if (gimme == G_SCALAR)
383 tryAMAGICunTARGET(iter, -1);
385 /* Note that we only ever get here if File::Glob fails to load
386 * without at the same time croaking, for some reason, or if
387 * perl was built with PERL_EXTERNAL_GLOB */
394 * The external globbing program may use things we can't control,
395 * so for security reasons we must assume the worst.
398 taint_proper(PL_no_security, "glob");
402 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
403 PL_last_in_gv = (GV*)*PL_stack_sp--;
405 SAVESPTR(PL_rs); /* This is not permanent, either. */
406 PL_rs = sv_2mortal(newSVpvs("\000"));
409 *SvPVX(PL_rs) = '\n';
413 result = do_readline();
421 PL_last_in_gv = cGVOP_gv;
422 return do_readline();
433 do_join(TARG, &PL_sv_no, MARK, SP);
437 else if (SP == MARK) {
445 tmps = SvPV_const(tmpsv, len);
446 if ((!tmps || !len) && PL_errgv) {
447 SV * const error = ERRSV;
448 SvUPGRADE(error, SVt_PV);
449 if (SvPOK(error) && SvCUR(error))
450 sv_catpvs(error, "\t...caught");
452 tmps = SvPV_const(tmpsv, len);
455 tmpsv = sv_2mortal(newSVpvs("Warning: something's wrong"));
457 Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv));
469 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
471 if (SP - MARK != 1) {
473 do_join(TARG, &PL_sv_no, MARK, SP);
475 tmps = SvPV_const(tmpsv, len);
481 tmps = SvROK(tmpsv) ? NULL : SvPV_const(tmpsv, len);
484 SV * const error = ERRSV;
485 SvUPGRADE(error, SVt_PV);
486 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
488 SvSetSV(error,tmpsv);
489 else if (sv_isobject(error)) {
490 HV * const stash = SvSTASH(SvRV(error));
491 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
493 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
494 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
501 call_sv((SV*)GvCV(gv),
502 G_SCALAR|G_EVAL|G_KEEPERR);
503 sv_setsv(error,*PL_stack_sp--);
509 if (SvPOK(error) && SvCUR(error))
510 sv_catpvs(error, "\t...propagated");
513 tmps = SvPV_const(tmpsv, len);
519 tmpsv = sv_2mortal(newSVpvs("Died"));
521 DIE(aTHX_ "%"SVf, SVfARG(tmpsv));
537 GV * const gv = (GV *)*++MARK;
540 DIE(aTHX_ PL_no_usym, "filehandle");
542 if ((io = GvIOp(gv))) {
544 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
546 if (IoDIRP(io) && ckWARN2(WARN_IO, WARN_DEPRECATED))
547 Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
548 "Opening dirhandle %s also as a file", GvENAME(gv));
550 mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
552 /* Method's args are same as ours ... */
553 /* ... except handle is replaced by the object */
554 *MARK-- = SvTIED_obj((SV*)io, mg);
558 call_method("OPEN", G_SCALAR);
572 tmps = SvPV_const(sv, len);
573 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
576 PUSHi( (I32)PL_forkprocess );
577 else if (PL_forkprocess == 0) /* we are a new child */
587 GV * const gv = (MAXARG == 0) ? PL_defoutgv : (GV*)POPs;
590 IO * const io = GvIO(gv);
592 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
595 XPUSHs(SvTIED_obj((SV*)io, mg));
598 call_method("CLOSE", G_SCALAR);
606 PUSHs(boolSV(do_close(gv, TRUE)));
619 GV * const wgv = (GV*)POPs;
620 GV * const rgv = (GV*)POPs;
625 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
626 DIE(aTHX_ PL_no_usym, "filehandle");
631 do_close(rgv, FALSE);
633 do_close(wgv, FALSE);
635 if (PerlProc_pipe(fd) < 0)
638 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
639 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
640 IoOFP(rstio) = IoIFP(rstio);
641 IoIFP(wstio) = IoOFP(wstio);
642 IoTYPE(rstio) = IoTYPE_RDONLY;
643 IoTYPE(wstio) = IoTYPE_WRONLY;
645 if (!IoIFP(rstio) || !IoOFP(wstio)) {
647 PerlIO_close(IoIFP(rstio));
649 PerlLIO_close(fd[0]);
651 PerlIO_close(IoOFP(wstio));
653 PerlLIO_close(fd[1]);
656 #if defined(HAS_FCNTL) && defined(F_SETFD)
657 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
658 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
665 DIE(aTHX_ PL_no_func, "pipe");
681 if (gv && (io = GvIO(gv))
682 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
685 XPUSHs(SvTIED_obj((SV*)io, mg));
688 call_method("FILENO", G_SCALAR);
694 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
695 /* Can't do this because people seem to do things like
696 defined(fileno($foo)) to check whether $foo is a valid fh.
697 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
698 report_evil_fh(gv, io, PL_op->op_type);
703 PUSHi(PerlIO_fileno(fp));
716 anum = PerlLIO_umask(022);
717 /* setting it to 022 between the two calls to umask avoids
718 * to have a window where the umask is set to 0 -- meaning
719 * that another thread could create world-writeable files. */
721 (void)PerlLIO_umask(anum);
724 anum = PerlLIO_umask(POPi);
725 TAINT_PROPER("umask");
728 /* Only DIE if trying to restrict permissions on "user" (self).
729 * Otherwise it's harmless and more useful to just return undef
730 * since 'group' and 'other' concepts probably don't exist here. */
731 if (MAXARG >= 1 && (POPi & 0700))
732 DIE(aTHX_ "umask not implemented");
733 XPUSHs(&PL_sv_undef);
754 if (gv && (io = GvIO(gv))) {
755 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
758 XPUSHs(SvTIED_obj((SV*)io, mg));
763 call_method("BINMODE", G_SCALAR);
771 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
772 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
773 report_evil_fh(gv, io, PL_op->op_type);
774 SETERRNO(EBADF,RMS_IFI);
780 const int mode = mode_from_discipline(discp);
781 const char *const d = (discp ? SvPV_nolen_const(discp) : NULL);
782 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
783 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
784 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
805 const I32 markoff = MARK - PL_stack_base;
806 const char *methname;
807 int how = PERL_MAGIC_tied;
811 switch(SvTYPE(varsv)) {
813 methname = "TIEHASH";
814 HvEITER_set((HV *)varsv, 0);
817 methname = "TIEARRAY";
820 #ifdef GV_UNIQUE_CHECK
821 if (GvUNIQUE((GV*)varsv)) {
822 Perl_croak(aTHX_ "Attempt to tie unique GV");
825 methname = "TIEHANDLE";
826 how = PERL_MAGIC_tiedscalar;
827 /* For tied filehandles, we apply tiedscalar magic to the IO
828 slot of the GP rather than the GV itself. AMS 20010812 */
830 GvIOp(varsv) = newIO();
831 varsv = (SV *)GvIOp(varsv);
834 methname = "TIESCALAR";
835 how = PERL_MAGIC_tiedscalar;
839 if (sv_isobject(*MARK)) {
841 PUSHSTACKi(PERLSI_MAGIC);
843 EXTEND(SP,(I32)items);
847 call_method(methname, G_SCALAR);
850 /* Not clear why we don't call call_method here too.
851 * perhaps to get different error message ?
853 stash = gv_stashsv(*MARK, 0);
854 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
855 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
856 methname, SVfARG(*MARK));
859 PUSHSTACKi(PERLSI_MAGIC);
861 EXTEND(SP,(I32)items);
865 call_sv((SV*)GvCV(gv), G_SCALAR);
871 if (sv_isobject(sv)) {
872 sv_unmagic(varsv, how);
873 /* Croak if a self-tie on an aggregate is attempted. */
874 if (varsv == SvRV(sv) &&
875 (SvTYPE(varsv) == SVt_PVAV ||
876 SvTYPE(varsv) == SVt_PVHV))
878 "Self-ties of arrays and hashes are not supported");
879 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
882 SP = PL_stack_base + markoff;
892 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
893 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
895 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
898 if ((mg = SvTIED_mg(sv, how))) {
899 SV * const obj = SvRV(SvTIED_obj(sv, mg));
901 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
903 if (gv && isGV(gv) && (cv = GvCV(gv))) {
905 XPUSHs(SvTIED_obj((SV*)gv, mg));
906 XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
909 call_sv((SV *)cv, G_VOID);
913 else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
914 Perl_warner(aTHX_ packWARN(WARN_UNTIE),
915 "untie attempted while %"UVuf" inner references still exist",
916 (UV)SvREFCNT(obj) - 1 ) ;
920 sv_unmagic(sv, how) ;
930 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
931 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
933 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
936 if ((mg = SvTIED_mg(sv, how))) {
937 SV *osv = SvTIED_obj(sv, mg);
938 if (osv == mg->mg_obj)
939 osv = sv_mortalcopy(osv);
953 HV * const hv = (HV*)POPs;
954 SV * const sv = sv_2mortal(newSVpvs("AnyDBM_File"));
955 stash = gv_stashsv(sv, 0);
956 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
958 require_pv("AnyDBM_File.pm");
960 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
961 DIE(aTHX_ "No dbm on this machine");
971 PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
973 PUSHs(sv_2mortal(newSVuv(O_RDWR)));
976 call_sv((SV*)GvCV(gv), G_SCALAR);
979 if (!sv_isobject(TOPs)) {
984 PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
987 call_sv((SV*)GvCV(gv), G_SCALAR);
991 if (sv_isobject(TOPs)) {
992 sv_unmagic((SV *) hv, PERL_MAGIC_tied);
993 sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, NULL, 0);
1010 struct timeval timebuf;
1011 struct timeval *tbuf = &timebuf;
1014 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1019 # if BYTEORDER & 0xf0000
1020 # define ORDERBYTE (0x88888888 - BYTEORDER)
1022 # define ORDERBYTE (0x4444 - BYTEORDER)
1028 for (i = 1; i <= 3; i++) {
1029 SV * const sv = SP[i];
1032 if (SvREADONLY(sv)) {
1034 sv_force_normal_flags(sv, 0);
1035 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1036 DIE(aTHX_ PL_no_modify);
1039 if (ckWARN(WARN_MISC))
1040 Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1041 SvPV_force_nolen(sv); /* force string conversion */
1048 /* little endians can use vecs directly */
1049 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1056 masksize = NFDBITS / NBBY;
1058 masksize = sizeof(long); /* documented int, everyone seems to use long */
1060 Zero(&fd_sets[0], 4, char*);
1063 # if SELECT_MIN_BITS == 1
1064 growsize = sizeof(fd_set);
1066 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1067 # undef SELECT_MIN_BITS
1068 # define SELECT_MIN_BITS __FD_SETSIZE
1070 /* If SELECT_MIN_BITS is greater than one we most probably will want
1071 * to align the sizes with SELECT_MIN_BITS/8 because for example
1072 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1073 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1074 * on (sets/tests/clears bits) is 32 bits. */
1075 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1083 timebuf.tv_sec = (long)value;
1084 value -= (NV)timebuf.tv_sec;
1085 timebuf.tv_usec = (long)(value * 1000000.0);
1090 for (i = 1; i <= 3; i++) {
1092 if (!SvOK(sv) || SvCUR(sv) == 0) {
1099 Sv_Grow(sv, growsize);
1103 while (++j <= growsize) {
1107 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1109 Newx(fd_sets[i], growsize, char);
1110 for (offset = 0; offset < growsize; offset += masksize) {
1111 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1112 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1115 fd_sets[i] = SvPVX(sv);
1119 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1120 /* Can't make just the (void*) conditional because that would be
1121 * cpp #if within cpp macro, and not all compilers like that. */
1122 nfound = PerlSock_select(
1124 (Select_fd_set_t) fd_sets[1],
1125 (Select_fd_set_t) fd_sets[2],
1126 (Select_fd_set_t) fd_sets[3],
1127 (void*) tbuf); /* Workaround for compiler bug. */
1129 nfound = PerlSock_select(
1131 (Select_fd_set_t) fd_sets[1],
1132 (Select_fd_set_t) fd_sets[2],
1133 (Select_fd_set_t) fd_sets[3],
1136 for (i = 1; i <= 3; i++) {
1139 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1141 for (offset = 0; offset < growsize; offset += masksize) {
1142 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1143 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1145 Safefree(fd_sets[i]);
1152 if (GIMME == G_ARRAY && tbuf) {
1153 value = (NV)(timebuf.tv_sec) +
1154 (NV)(timebuf.tv_usec) / 1000000.0;
1155 PUSHs(sv_2mortal(newSVnv(value)));
1159 DIE(aTHX_ "select not implemented");
1164 Perl_setdefout(pTHX_ GV *gv)
1167 SvREFCNT_inc_simple_void(gv);
1169 SvREFCNT_dec(PL_defoutgv);
1177 GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : NULL;
1178 GV * egv = GvEGV(PL_defoutgv);
1184 XPUSHs(&PL_sv_undef);
1186 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1187 if (gvp && *gvp == egv) {
1188 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1192 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1197 if (!GvIO(newdefout))
1198 gv_IOadd(newdefout);
1199 setdefout(newdefout);
1209 GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs;
1211 if (gv && (io = GvIO(gv))) {
1212 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1214 const I32 gimme = GIMME_V;
1216 XPUSHs(SvTIED_obj((SV*)io, mg));
1219 call_method("GETC", gimme);
1222 if (gimme == G_SCALAR)
1223 SvSetMagicSV_nosteal(TARG, TOPs);
1227 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1228 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1229 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1230 report_evil_fh(gv, io, PL_op->op_type);
1231 SETERRNO(EBADF,RMS_IFI);
1235 sv_setpvn(TARG, " ", 1);
1236 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1237 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1238 /* Find out how many bytes the char needs */
1239 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1242 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1243 SvCUR_set(TARG,1+len);
1252 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1255 register PERL_CONTEXT *cx;
1256 const I32 gimme = GIMME_V;
1261 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1263 cx->blk_sub.retop = retop;
1265 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1267 setdefout(gv); /* locally select filehandle so $% et al work */
1299 goto not_a_format_reference;
1304 tmpsv = sv_newmortal();
1305 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1306 name = SvPV_nolen_const(tmpsv);
1308 DIE(aTHX_ "Undefined format \"%s\" called", name);
1310 not_a_format_reference:
1311 DIE(aTHX_ "Not a format reference");
1314 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1316 IoFLAGS(io) &= ~IOf_DIDTOP;
1317 return doform(cv,gv,PL_op->op_next);
1323 GV * const gv = cxstack[cxstack_ix].blk_sub.gv;
1324 register IO * const io = GvIOp(gv);
1329 register PERL_CONTEXT *cx;
1331 if (!io || !(ofp = IoOFP(io)))
1334 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1335 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1337 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1338 PL_formtarget != PL_toptarget)
1342 if (!IoTOP_GV(io)) {
1345 if (!IoTOP_NAME(io)) {
1347 if (!IoFMT_NAME(io))
1348 IoFMT_NAME(io) = savepv(GvNAME(gv));
1349 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1350 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1351 if ((topgv && GvFORM(topgv)) ||
1352 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1353 IoTOP_NAME(io) = savesvpv(topname);
1355 IoTOP_NAME(io) = savepvs("top");
1357 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1358 if (!topgv || !GvFORM(topgv)) {
1359 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1362 IoTOP_GV(io) = topgv;
1364 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1365 I32 lines = IoLINES_LEFT(io);
1366 const char *s = SvPVX_const(PL_formtarget);
1367 if (lines <= 0) /* Yow, header didn't even fit!!! */
1369 while (lines-- > 0) {
1370 s = strchr(s, '\n');
1376 const STRLEN save = SvCUR(PL_formtarget);
1377 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1378 do_print(PL_formtarget, ofp);
1379 SvCUR_set(PL_formtarget, save);
1380 sv_chop(PL_formtarget, s);
1381 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1384 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1385 do_print(PL_formfeed, ofp);
1386 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1388 PL_formtarget = PL_toptarget;
1389 IoFLAGS(io) |= IOf_DIDTOP;
1392 DIE(aTHX_ "bad top format reference");
1395 SV * const sv = sv_newmortal();
1397 gv_efullname4(sv, fgv, NULL, FALSE);
1398 name = SvPV_nolen_const(sv);
1400 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1402 DIE(aTHX_ "Undefined top format called");
1404 if (cv && CvCLONE(cv))
1405 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1406 return doform(cv, gv, PL_op);
1410 POPBLOCK(cx,PL_curpm);
1416 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1418 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1419 else if (ckWARN(WARN_CLOSED))
1420 report_evil_fh(gv, io, PL_op->op_type);
1425 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1426 if (ckWARN(WARN_IO))
1427 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1429 if (!do_print(PL_formtarget, fp))
1432 FmLINES(PL_formtarget) = 0;
1433 SvCUR_set(PL_formtarget, 0);
1434 *SvEND(PL_formtarget) = '\0';
1435 if (IoFLAGS(io) & IOf_FLUSH)
1436 (void)PerlIO_flush(fp);
1441 PL_formtarget = PL_bodytarget;
1443 PERL_UNUSED_VAR(newsp);
1444 PERL_UNUSED_VAR(gimme);
1445 return cx->blk_sub.retop;
1450 dVAR; dSP; dMARK; dORIGMARK;
1455 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
1457 if (gv && (io = GvIO(gv))) {
1458 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1460 if (MARK == ORIGMARK) {
1463 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1467 *MARK = SvTIED_obj((SV*)io, mg);
1470 call_method("PRINTF", G_SCALAR);
1473 MARK = ORIGMARK + 1;
1481 if (!(io = GvIO(gv))) {
1482 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1483 report_evil_fh(gv, io, PL_op->op_type);
1484 SETERRNO(EBADF,RMS_IFI);
1487 else if (!(fp = IoOFP(io))) {
1488 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1490 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1491 else if (ckWARN(WARN_CLOSED))
1492 report_evil_fh(gv, io, PL_op->op_type);
1494 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1498 if (SvTAINTED(MARK[1]))
1499 TAINT_PROPER("printf");
1500 do_sprintf(sv, SP - MARK, MARK + 1);
1501 if (!do_print(sv, fp))
1504 if (IoFLAGS(io) & IOf_FLUSH)
1505 if (PerlIO_flush(fp) == EOF)
1516 PUSHs(&PL_sv_undef);
1524 const int perm = (MAXARG > 3) ? POPi : 0666;
1525 const int mode = POPi;
1526 SV * const sv = POPs;
1527 GV * const gv = (GV *)POPs;
1530 /* Need TIEHANDLE method ? */
1531 const char * const tmps = SvPV_const(sv, len);
1532 /* FIXME? do_open should do const */
1533 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1534 IoLINES(GvIOp(gv)) = 0;
1538 PUSHs(&PL_sv_undef);
1545 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1551 Sock_size_t bufsize;
1559 bool charstart = FALSE;
1560 STRLEN charskip = 0;
1563 GV * const gv = (GV*)*++MARK;
1564 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1565 && gv && (io = GvIO(gv)) )
1567 const MAGIC * mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1571 *MARK = SvTIED_obj((SV*)io, mg);
1573 call_method("READ", G_SCALAR);
1587 sv_setpvn(bufsv, "", 0);
1588 length = SvIVx(*++MARK);
1591 offset = SvIVx(*++MARK);
1595 if (!io || !IoIFP(io)) {
1596 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1597 report_evil_fh(gv, io, PL_op->op_type);
1598 SETERRNO(EBADF,RMS_IFI);
1601 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1602 buffer = SvPVutf8_force(bufsv, blen);
1603 /* UTF-8 may not have been set if they are all low bytes */
1608 buffer = SvPV_force(bufsv, blen);
1609 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1612 DIE(aTHX_ "Negative length");
1620 if (PL_op->op_type == OP_RECV) {
1621 char namebuf[MAXPATHLEN];
1622 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1623 bufsize = sizeof (struct sockaddr_in);
1625 bufsize = sizeof namebuf;
1627 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1631 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1632 /* 'offset' means 'flags' here */
1633 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1634 (struct sockaddr *)namebuf, &bufsize);
1638 /* Bogus return without padding */
1639 bufsize = sizeof (struct sockaddr_in);
1641 SvCUR_set(bufsv, count);
1642 *SvEND(bufsv) = '\0';
1643 (void)SvPOK_only(bufsv);
1647 /* This should not be marked tainted if the fp is marked clean */
1648 if (!(IoFLAGS(io) & IOf_UNTAINT))
1649 SvTAINTED_on(bufsv);
1651 sv_setpvn(TARG, namebuf, bufsize);
1656 if (PL_op->op_type == OP_RECV)
1657 DIE(aTHX_ PL_no_sock_func, "recv");
1659 if (DO_UTF8(bufsv)) {
1660 /* offset adjust in characters not bytes */
1661 blen = sv_len_utf8(bufsv);
1664 if (-offset > (int)blen)
1665 DIE(aTHX_ "Offset outside string");
1668 if (DO_UTF8(bufsv)) {
1669 /* convert offset-as-chars to offset-as-bytes */
1670 if (offset >= (int)blen)
1671 offset += SvCUR(bufsv) - blen;
1673 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1676 bufsize = SvCUR(bufsv);
1677 /* Allocating length + offset + 1 isn't perfect in the case of reading
1678 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1680 (should be 2 * length + offset + 1, or possibly something longer if
1681 PL_encoding is true) */
1682 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1683 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1684 Zero(buffer+bufsize, offset-bufsize, char);
1686 buffer = buffer + offset;
1688 read_target = bufsv;
1690 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1691 concatenate it to the current buffer. */
1693 /* Truncate the existing buffer to the start of where we will be
1695 SvCUR_set(bufsv, offset);
1697 read_target = sv_newmortal();
1698 SvUPGRADE(read_target, SVt_PV);
1699 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1702 if (PL_op->op_type == OP_SYSREAD) {
1703 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1704 if (IoTYPE(io) == IoTYPE_SOCKET) {
1705 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1711 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1716 #ifdef HAS_SOCKET__bad_code_maybe
1717 if (IoTYPE(io) == IoTYPE_SOCKET) {
1718 char namebuf[MAXPATHLEN];
1719 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1720 bufsize = sizeof (struct sockaddr_in);
1722 bufsize = sizeof namebuf;
1724 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1725 (struct sockaddr *)namebuf, &bufsize);
1730 count = PerlIO_read(IoIFP(io), buffer, length);
1731 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1732 if (count == 0 && PerlIO_error(IoIFP(io)))
1736 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1737 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1740 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1741 *SvEND(read_target) = '\0';
1742 (void)SvPOK_only(read_target);
1743 if (fp_utf8 && !IN_BYTES) {
1744 /* Look at utf8 we got back and count the characters */
1745 const char *bend = buffer + count;
1746 while (buffer < bend) {
1748 skip = UTF8SKIP(buffer);
1751 if (buffer - charskip + skip > bend) {
1752 /* partial character - try for rest of it */
1753 length = skip - (bend-buffer);
1754 offset = bend - SvPVX_const(bufsv);
1766 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1767 provided amount read (count) was what was requested (length)
1769 if (got < wanted && count == length) {
1770 length = wanted - got;
1771 offset = bend - SvPVX_const(bufsv);
1774 /* return value is character count */
1778 else if (buffer_utf8) {
1779 /* Let svcatsv upgrade the bytes we read in to utf8.
1780 The buffer is a mortal so will be freed soon. */
1781 sv_catsv_nomg(bufsv, read_target);
1784 /* This should not be marked tainted if the fp is marked clean */
1785 if (!(IoFLAGS(io) & IOf_UNTAINT))
1786 SvTAINTED_on(bufsv);
1798 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1804 STRLEN orig_blen_bytes;
1805 const int op_type = PL_op->op_type;
1809 GV *const gv = (GV*)*++MARK;
1810 if (PL_op->op_type == OP_SYSWRITE
1811 && gv && (io = GvIO(gv))) {
1812 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1816 if (MARK == SP - 1) {
1818 sv = sv_2mortal(newSViv(sv_len(*SP)));
1824 *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg);
1826 call_method("WRITE", G_SCALAR);
1842 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1844 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1845 if (io && IoIFP(io))
1846 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1848 report_evil_fh(gv, io, PL_op->op_type);
1850 SETERRNO(EBADF,RMS_IFI);
1854 /* Do this first to trigger any overloading. */
1855 buffer = SvPV_const(bufsv, blen);
1856 orig_blen_bytes = blen;
1857 doing_utf8 = DO_UTF8(bufsv);
1859 if (PerlIO_isutf8(IoIFP(io))) {
1860 if (!SvUTF8(bufsv)) {
1861 /* We don't modify the original scalar. */
1862 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1863 buffer = (char *) tmpbuf;
1867 else if (doing_utf8) {
1868 STRLEN tmplen = blen;
1869 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1872 buffer = (char *) tmpbuf;
1876 assert((char *)result == buffer);
1877 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1881 if (op_type == OP_SYSWRITE) {
1882 Size_t length = 0; /* This length is in characters. */
1888 /* The SV is bytes, and we've had to upgrade it. */
1889 blen_chars = orig_blen_bytes;
1891 /* The SV really is UTF-8. */
1892 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1893 /* Don't call sv_len_utf8 again because it will call magic
1894 or overloading a second time, and we might get back a
1895 different result. */
1896 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1898 /* It's safe, and it may well be cached. */
1899 blen_chars = sv_len_utf8(bufsv);
1907 length = blen_chars;
1909 #if Size_t_size > IVSIZE
1910 length = (Size_t)SvNVx(*++MARK);
1912 length = (Size_t)SvIVx(*++MARK);
1914 if ((SSize_t)length < 0) {
1916 DIE(aTHX_ "Negative length");
1921 offset = SvIVx(*++MARK);
1923 if (-offset > (IV)blen_chars) {
1925 DIE(aTHX_ "Offset outside string");
1927 offset += blen_chars;
1928 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1930 DIE(aTHX_ "Offset outside string");
1934 if (length > blen_chars - offset)
1935 length = blen_chars - offset;
1937 /* Here we convert length from characters to bytes. */
1938 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1939 /* Either we had to convert the SV, or the SV is magical, or
1940 the SV has overloading, in which case we can't or mustn't
1941 or mustn't call it again. */
1943 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1944 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1946 /* It's a real UTF-8 SV, and it's not going to change under
1947 us. Take advantage of any cache. */
1949 I32 len_I32 = length;
1951 /* Convert the start and end character positions to bytes.
1952 Remember that the second argument to sv_pos_u2b is relative
1954 sv_pos_u2b(bufsv, &start, &len_I32);
1961 buffer = buffer+offset;
1963 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1964 if (IoTYPE(io) == IoTYPE_SOCKET) {
1965 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1971 /* See the note at doio.c:do_print about filesize limits. --jhi */
1972 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1978 const int flags = SvIVx(*++MARK);
1981 char * const sockbuf = SvPVx(*++MARK, mlen);
1982 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1983 flags, (struct sockaddr *)sockbuf, mlen);
1987 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1992 DIE(aTHX_ PL_no_sock_func, "send");
1999 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2002 #if Size_t_size > IVSIZE
2021 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
2023 gv = PL_last_in_gv = GvEGV(PL_argvgv);
2025 if (io && !IoIFP(io)) {
2026 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2028 IoFLAGS(io) &= ~IOf_START;
2029 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2030 sv_setpvn(GvSV(gv), "-", 1);
2031 SvSETMAGIC(GvSV(gv));
2033 else if (!nextargv(gv))
2038 gv = PL_last_in_gv; /* eof */
2041 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
2044 IO * const io = GvIO(gv);
2046 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
2048 XPUSHs(SvTIED_obj((SV*)io, mg));
2051 call_method("EOF", G_SCALAR);
2058 PUSHs(boolSV(!gv || do_eof(gv)));
2069 PL_last_in_gv = (GV*)POPs;
2072 if (gv && (io = GvIO(gv))) {
2073 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2076 XPUSHs(SvTIED_obj((SV*)io, mg));
2079 call_method("TELL", G_SCALAR);
2086 #if LSEEKSIZE > IVSIZE
2087 PUSHn( do_tell(gv) );
2089 PUSHi( do_tell(gv) );
2097 const int whence = POPi;
2098 #if LSEEKSIZE > IVSIZE
2099 const Off_t offset = (Off_t)SvNVx(POPs);
2101 const Off_t offset = (Off_t)SvIVx(POPs);
2104 GV * const gv = PL_last_in_gv = (GV*)POPs;
2107 if (gv && (io = GvIO(gv))) {
2108 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2111 XPUSHs(SvTIED_obj((SV*)io, mg));
2112 #if LSEEKSIZE > IVSIZE
2113 XPUSHs(sv_2mortal(newSVnv((NV) offset)));
2115 XPUSHs(sv_2mortal(newSViv(offset)));
2117 XPUSHs(sv_2mortal(newSViv(whence)));
2120 call_method("SEEK", G_SCALAR);
2127 if (PL_op->op_type == OP_SEEK)
2128 PUSHs(boolSV(do_seek(gv, offset, whence)));
2130 const Off_t sought = do_sysseek(gv, offset, whence);
2132 PUSHs(&PL_sv_undef);
2134 SV* const sv = sought ?
2135 #if LSEEKSIZE > IVSIZE
2140 : newSVpvn(zero_but_true, ZBTLEN);
2141 PUSHs(sv_2mortal(sv));
2151 /* There seems to be no consensus on the length type of truncate()
2152 * and ftruncate(), both off_t and size_t have supporters. In
2153 * general one would think that when using large files, off_t is
2154 * at least as wide as size_t, so using an off_t should be okay. */
2155 /* XXX Configure probe for the length type of *truncate() needed XXX */
2158 #if Off_t_size > IVSIZE
2163 /* Checking for length < 0 is problematic as the type might or
2164 * might not be signed: if it is not, clever compilers will moan. */
2165 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2172 if (PL_op->op_flags & OPf_SPECIAL) {
2173 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2182 TAINT_PROPER("truncate");
2183 if (!(fp = IoIFP(io))) {
2189 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2191 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2198 SV * const sv = POPs;
2201 if (SvTYPE(sv) == SVt_PVGV) {
2202 tmpgv = (GV*)sv; /* *main::FRED for example */
2203 goto do_ftruncate_gv;
2205 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2206 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
2207 goto do_ftruncate_gv;
2209 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2210 io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
2211 goto do_ftruncate_io;
2214 name = SvPV_nolen_const(sv);
2215 TAINT_PROPER("truncate");
2217 if (truncate(name, len) < 0)
2221 const int tmpfd = PerlLIO_open(name, O_RDWR);
2226 if (my_chsize(tmpfd, len) < 0)
2228 PerlLIO_close(tmpfd);
2237 SETERRNO(EBADF,RMS_IFI);
2245 SV * const argsv = POPs;
2246 const unsigned int func = POPu;
2247 const int optype = PL_op->op_type;
2248 GV * const gv = (GV*)POPs;
2249 IO * const io = gv ? GvIOn(gv) : NULL;
2253 if (!io || !argsv || !IoIFP(io)) {
2254 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2255 report_evil_fh(gv, io, PL_op->op_type);
2256 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2260 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2263 s = SvPV_force(argsv, len);
2264 need = IOCPARM_LEN(func);
2266 s = Sv_Grow(argsv, need + 1);
2267 SvCUR_set(argsv, need);
2270 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2273 retval = SvIV(argsv);
2274 s = INT2PTR(char*,retval); /* ouch */
2277 TAINT_PROPER(PL_op_desc[optype]);
2279 if (optype == OP_IOCTL)
2281 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2283 DIE(aTHX_ "ioctl is not implemented");
2287 DIE(aTHX_ "fcntl is not implemented");
2289 #if defined(OS2) && defined(__EMX__)
2290 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2292 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2296 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2298 if (s[SvCUR(argsv)] != 17)
2299 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2301 s[SvCUR(argsv)] = 0; /* put our null back */
2302 SvSETMAGIC(argsv); /* Assume it has changed */
2311 PUSHp(zero_but_true, ZBTLEN);
2324 const int argtype = POPi;
2325 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
2327 if (gv && (io = GvIO(gv)))
2333 /* XXX Looks to me like io is always NULL at this point */
2335 (void)PerlIO_flush(fp);
2336 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2339 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2340 report_evil_fh(gv, io, PL_op->op_type);
2342 SETERRNO(EBADF,RMS_IFI);
2347 DIE(aTHX_ PL_no_func, "flock()");
2357 const int protocol = POPi;
2358 const int type = POPi;
2359 const int domain = POPi;
2360 GV * const gv = (GV*)POPs;
2361 register IO * const io = gv ? GvIOn(gv) : NULL;
2365 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2366 report_evil_fh(gv, io, PL_op->op_type);
2367 if (io && IoIFP(io))
2368 do_close(gv, FALSE);
2369 SETERRNO(EBADF,LIB_INVARG);
2374 do_close(gv, FALSE);
2376 TAINT_PROPER("socket");
2377 fd = PerlSock_socket(domain, type, protocol);
2380 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2381 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2382 IoTYPE(io) = IoTYPE_SOCKET;
2383 if (!IoIFP(io) || !IoOFP(io)) {
2384 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2385 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2386 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2389 #if defined(HAS_FCNTL) && defined(F_SETFD)
2390 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2394 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2399 DIE(aTHX_ PL_no_sock_func, "socket");
2405 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2407 const int protocol = POPi;
2408 const int type = POPi;
2409 const int domain = POPi;
2410 GV * const gv2 = (GV*)POPs;
2411 GV * const gv1 = (GV*)POPs;
2412 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2413 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2416 if (!gv1 || !gv2 || !io1 || !io2) {
2417 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2419 report_evil_fh(gv1, io1, PL_op->op_type);
2421 report_evil_fh(gv1, io2, PL_op->op_type);
2423 if (io1 && IoIFP(io1))
2424 do_close(gv1, FALSE);
2425 if (io2 && IoIFP(io2))
2426 do_close(gv2, FALSE);
2431 do_close(gv1, FALSE);
2433 do_close(gv2, FALSE);
2435 TAINT_PROPER("socketpair");
2436 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2438 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2439 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2440 IoTYPE(io1) = IoTYPE_SOCKET;
2441 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2442 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2443 IoTYPE(io2) = IoTYPE_SOCKET;
2444 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2445 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2446 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2447 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2448 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2449 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2450 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2453 #if defined(HAS_FCNTL) && defined(F_SETFD)
2454 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2455 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2460 DIE(aTHX_ PL_no_sock_func, "socketpair");
2468 SV * const addrsv = POPs;
2469 /* OK, so on what platform does bind modify addr? */
2471 GV * const gv = (GV*)POPs;
2472 register IO * const io = GvIOn(gv);
2475 if (!io || !IoIFP(io))
2478 addr = SvPV_const(addrsv, len);
2479 TAINT_PROPER("bind");
2480 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2486 if (ckWARN(WARN_CLOSED))
2487 report_evil_fh(gv, io, PL_op->op_type);
2488 SETERRNO(EBADF,SS_IVCHAN);
2491 DIE(aTHX_ PL_no_sock_func, "bind");
2499 SV * const addrsv = POPs;
2500 GV * const gv = (GV*)POPs;
2501 register IO * const io = GvIOn(gv);
2505 if (!io || !IoIFP(io))
2508 addr = SvPV_const(addrsv, len);
2509 TAINT_PROPER("connect");
2510 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2516 if (ckWARN(WARN_CLOSED))
2517 report_evil_fh(gv, io, PL_op->op_type);
2518 SETERRNO(EBADF,SS_IVCHAN);
2521 DIE(aTHX_ PL_no_sock_func, "connect");
2529 const int backlog = POPi;
2530 GV * const gv = (GV*)POPs;
2531 register IO * const io = gv ? GvIOn(gv) : NULL;
2533 if (!gv || !io || !IoIFP(io))
2536 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2542 if (ckWARN(WARN_CLOSED))
2543 report_evil_fh(gv, io, PL_op->op_type);
2544 SETERRNO(EBADF,SS_IVCHAN);
2547 DIE(aTHX_ PL_no_sock_func, "listen");
2557 char namebuf[MAXPATHLEN];
2558 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2559 Sock_size_t len = sizeof (struct sockaddr_in);
2561 Sock_size_t len = sizeof namebuf;
2563 GV * const ggv = (GV*)POPs;
2564 GV * const ngv = (GV*)POPs;
2573 if (!gstio || !IoIFP(gstio))
2577 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2580 /* Some platforms indicate zero length when an AF_UNIX client is
2581 * not bound. Simulate a non-zero-length sockaddr structure in
2583 namebuf[0] = 0; /* sun_len */
2584 namebuf[1] = AF_UNIX; /* sun_family */
2592 do_close(ngv, FALSE);
2593 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2594 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2595 IoTYPE(nstio) = IoTYPE_SOCKET;
2596 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2597 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2598 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2599 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2602 #if defined(HAS_FCNTL) && defined(F_SETFD)
2603 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2607 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2608 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2610 #ifdef __SCO_VERSION__
2611 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2614 PUSHp(namebuf, len);
2618 if (ckWARN(WARN_CLOSED))
2619 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2620 SETERRNO(EBADF,SS_IVCHAN);
2626 DIE(aTHX_ PL_no_sock_func, "accept");
2634 const int how = POPi;
2635 GV * const gv = (GV*)POPs;
2636 register IO * const io = GvIOn(gv);
2638 if (!io || !IoIFP(io))
2641 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2645 if (ckWARN(WARN_CLOSED))
2646 report_evil_fh(gv, io, PL_op->op_type);
2647 SETERRNO(EBADF,SS_IVCHAN);
2650 DIE(aTHX_ PL_no_sock_func, "shutdown");
2658 const int optype = PL_op->op_type;
2659 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2660 const unsigned int optname = (unsigned int) POPi;
2661 const unsigned int lvl = (unsigned int) POPi;
2662 GV * const gv = (GV*)POPs;
2663 register IO * const io = GvIOn(gv);
2667 if (!io || !IoIFP(io))
2670 fd = PerlIO_fileno(IoIFP(io));
2674 (void)SvPOK_only(sv);
2678 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2685 #if defined(__SYMBIAN32__)
2686 # define SETSOCKOPT_OPTION_VALUE_T void *
2688 # define SETSOCKOPT_OPTION_VALUE_T const char *
2690 /* XXX TODO: We need to have a proper type (a Configure probe,
2691 * etc.) for what the C headers think of the third argument of
2692 * setsockopt(), the option_value read-only buffer: is it
2693 * a "char *", or a "void *", const or not. Some compilers
2694 * don't take kindly to e.g. assuming that "char *" implicitly
2695 * promotes to a "void *", or to explicitly promoting/demoting
2696 * consts to non/vice versa. The "const void *" is the SUS
2697 * definition, but that does not fly everywhere for the above
2699 SETSOCKOPT_OPTION_VALUE_T buf;
2703 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2707 aint = (int)SvIV(sv);
2708 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2711 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2720 if (ckWARN(WARN_CLOSED))
2721 report_evil_fh(gv, io, optype);
2722 SETERRNO(EBADF,SS_IVCHAN);
2727 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2735 const int optype = PL_op->op_type;
2736 GV * const gv = (GV*)POPs;
2737 register IO * const io = GvIOn(gv);
2742 if (!io || !IoIFP(io))
2745 sv = sv_2mortal(newSV(257));
2746 (void)SvPOK_only(sv);
2750 fd = PerlIO_fileno(IoIFP(io));
2752 case OP_GETSOCKNAME:
2753 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2756 case OP_GETPEERNAME:
2757 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2759 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2761 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";
2762 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2763 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2764 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2765 sizeof(u_short) + sizeof(struct in_addr))) {
2772 #ifdef BOGUS_GETNAME_RETURN
2773 /* Interactive Unix, getpeername() and getsockname()
2774 does not return valid namelen */
2775 if (len == BOGUS_GETNAME_RETURN)
2776 len = sizeof(struct sockaddr);
2784 if (ckWARN(WARN_CLOSED))
2785 report_evil_fh(gv, io, optype);
2786 SETERRNO(EBADF,SS_IVCHAN);
2791 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2806 if (PL_op->op_flags & OPf_REF) {
2808 if (PL_op->op_type == OP_LSTAT) {
2809 if (gv != PL_defgv) {
2810 do_fstat_warning_check:
2811 if (ckWARN(WARN_IO))
2812 Perl_warner(aTHX_ packWARN(WARN_IO),
2813 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2814 } else if (PL_laststype != OP_LSTAT)
2815 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2819 if (gv != PL_defgv) {
2820 PL_laststype = OP_STAT;
2822 sv_setpvn(PL_statname, "", 0);
2829 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2830 } else if (IoDIRP(io)) {
2833 PerlLIO_fstat(dirfd(IoDIRP(io)), &PL_statcache);
2835 DIE(aTHX_ PL_no_func, "dirfd");
2838 PL_laststatval = -1;
2844 if (PL_laststatval < 0) {
2845 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2846 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2851 SV* const sv = POPs;
2852 if (SvTYPE(sv) == SVt_PVGV) {
2855 } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2857 if (PL_op->op_type == OP_LSTAT)
2858 goto do_fstat_warning_check;
2860 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2862 if (PL_op->op_type == OP_LSTAT)
2863 goto do_fstat_warning_check;
2864 goto do_fstat_have_io;
2867 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2869 PL_laststype = PL_op->op_type;
2870 if (PL_op->op_type == OP_LSTAT)
2871 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2873 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2874 if (PL_laststatval < 0) {
2875 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2876 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2882 if (gimme != G_ARRAY) {
2883 if (gimme != G_VOID)
2884 XPUSHs(boolSV(max));
2890 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2891 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2892 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2893 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2894 #if Uid_t_size > IVSIZE
2895 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2897 # if Uid_t_sign <= 0
2898 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2900 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2903 #if Gid_t_size > IVSIZE
2904 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2906 # if Gid_t_sign <= 0
2907 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2909 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2912 #ifdef USE_STAT_RDEV
2913 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2915 PUSHs(sv_2mortal(newSVpvs("")));
2917 #if Off_t_size > IVSIZE
2918 PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
2920 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2923 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2924 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2925 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2927 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_atime)));
2928 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_mtime)));
2929 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_ctime)));
2931 #ifdef USE_STAT_BLOCKS
2932 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2933 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2935 PUSHs(sv_2mortal(newSVpvs("")));
2936 PUSHs(sv_2mortal(newSVpvs("")));
2942 /* This macro is used by the stacked filetest operators :
2943 * if the previous filetest failed, short-circuit and pass its value.
2944 * Else, discard it from the stack and continue. --rgs
2946 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2947 if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
2948 else { (void)POPs; PUTBACK; } \
2955 /* Not const, because things tweak this below. Not bool, because there's
2956 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2957 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2958 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2959 /* Giving some sort of initial value silences compilers. */
2961 int access_mode = R_OK;
2963 int access_mode = 0;
2966 /* access_mode is never used, but leaving use_access in makes the
2967 conditional compiling below much clearer. */
2970 int stat_mode = S_IRUSR;
2972 bool effective = FALSE;
2975 STACKED_FTEST_CHECK;
2977 switch (PL_op->op_type) {
2979 #if !(defined(HAS_ACCESS) && defined(R_OK))
2985 #if defined(HAS_ACCESS) && defined(W_OK)
2990 stat_mode = S_IWUSR;
2994 #if defined(HAS_ACCESS) && defined(X_OK)
2999 stat_mode = S_IXUSR;
3003 #ifdef PERL_EFF_ACCESS
3006 stat_mode = S_IWUSR;
3010 #ifndef PERL_EFF_ACCESS
3018 #ifdef PERL_EFF_ACCESS
3023 stat_mode = S_IXUSR;
3029 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3030 const char *name = POPpx;
3032 # ifdef PERL_EFF_ACCESS
3033 result = PERL_EFF_ACCESS(name, access_mode);
3035 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3041 result = access(name, access_mode);
3043 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3058 if (cando(stat_mode, effective, &PL_statcache))
3067 const int op_type = PL_op->op_type;
3069 STACKED_FTEST_CHECK;
3074 if (op_type == OP_FTIS)
3077 /* You can't dTARGET inside OP_FTIS, because you'll get
3078 "panic: pad_sv po" - the op is not flagged to have a target. */
3082 #if Off_t_size > IVSIZE
3083 PUSHn(PL_statcache.st_size);
3085 PUSHi(PL_statcache.st_size);
3089 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3092 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3095 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3108 /* I believe that all these three are likely to be defined on most every
3109 system these days. */
3111 if(PL_op->op_type == OP_FTSUID)
3115 if(PL_op->op_type == OP_FTSGID)
3119 if(PL_op->op_type == OP_FTSVTX)
3123 STACKED_FTEST_CHECK;
3128 switch (PL_op->op_type) {
3130 if (PL_statcache.st_uid == PL_uid)
3134 if (PL_statcache.st_uid == PL_euid)
3138 if (PL_statcache.st_size == 0)
3142 if (S_ISSOCK(PL_statcache.st_mode))
3146 if (S_ISCHR(PL_statcache.st_mode))
3150 if (S_ISBLK(PL_statcache.st_mode))
3154 if (S_ISREG(PL_statcache.st_mode))
3158 if (S_ISDIR(PL_statcache.st_mode))
3162 if (S_ISFIFO(PL_statcache.st_mode))
3167 if (PL_statcache.st_mode & S_ISUID)
3173 if (PL_statcache.st_mode & S_ISGID)
3179 if (PL_statcache.st_mode & S_ISVTX)
3190 I32 result = my_lstat();
3194 if (S_ISLNK(PL_statcache.st_mode))
3207 STACKED_FTEST_CHECK;
3209 if (PL_op->op_flags & OPf_REF)
3211 else if (isGV(TOPs))
3213 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3214 gv = (GV*)SvRV(POPs);
3216 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3218 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3219 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3220 else if (tmpsv && SvOK(tmpsv)) {
3221 const char *tmps = SvPV_nolen_const(tmpsv);
3229 if (PerlLIO_isatty(fd))
3234 #if defined(atarist) /* this will work with atariST. Configure will
3235 make guesses for other systems. */
3236 # define FILE_base(f) ((f)->_base)
3237 # define FILE_ptr(f) ((f)->_ptr)
3238 # define FILE_cnt(f) ((f)->_cnt)
3239 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3250 register STDCHAR *s;
3256 STACKED_FTEST_CHECK;
3258 if (PL_op->op_flags & OPf_REF)
3260 else if (isGV(TOPs))
3262 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3263 gv = (GV*)SvRV(POPs);
3269 if (gv == PL_defgv) {
3271 io = GvIO(PL_statgv);
3274 goto really_filename;
3279 PL_laststatval = -1;
3280 sv_setpvn(PL_statname, "", 0);
3281 io = GvIO(PL_statgv);
3283 if (io && IoIFP(io)) {
3284 if (! PerlIO_has_base(IoIFP(io)))
3285 DIE(aTHX_ "-T and -B not implemented on filehandles");
3286 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3287 if (PL_laststatval < 0)
3289 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3290 if (PL_op->op_type == OP_FTTEXT)
3295 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3296 i = PerlIO_getc(IoIFP(io));
3298 (void)PerlIO_ungetc(IoIFP(io),i);
3300 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3302 len = PerlIO_get_bufsiz(IoIFP(io));
3303 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3304 /* sfio can have large buffers - limit to 512 */
3309 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3311 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3313 SETERRNO(EBADF,RMS_IFI);
3321 PL_laststype = OP_STAT;
3322 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3323 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3324 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3326 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3329 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3330 if (PL_laststatval < 0) {
3331 (void)PerlIO_close(fp);
3334 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3335 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3336 (void)PerlIO_close(fp);
3338 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3339 RETPUSHNO; /* special case NFS directories */
3340 RETPUSHYES; /* null file is anything */
3345 /* now scan s to look for textiness */
3346 /* XXX ASCII dependent code */
3348 #if defined(DOSISH) || defined(USEMYBINMODE)
3349 /* ignore trailing ^Z on short files */
3350 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3354 for (i = 0; i < len; i++, s++) {
3355 if (!*s) { /* null never allowed in text */
3360 else if (!(isPRINT(*s) || isSPACE(*s)))
3363 else if (*s & 128) {
3365 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3368 /* utf8 characters don't count as odd */
3369 if (UTF8_IS_START(*s)) {
3370 int ulen = UTF8SKIP(s);
3371 if (ulen < len - i) {
3373 for (j = 1; j < ulen; j++) {
3374 if (!UTF8_IS_CONTINUATION(s[j]))
3377 --ulen; /* loop does extra increment */
3387 *s != '\n' && *s != '\r' && *s != '\b' &&
3388 *s != '\t' && *s != '\f' && *s != 27)
3393 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3404 const char *tmps = NULL;
3408 SV * const sv = POPs;
3409 if (PL_op->op_flags & OPf_SPECIAL) {
3410 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3412 else if (SvTYPE(sv) == SVt_PVGV) {
3415 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
3419 tmps = SvPVx_nolen_const(sv);
3423 if( !gv && (!tmps || !*tmps) ) {
3424 HV * const table = GvHVn(PL_envgv);
3427 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3428 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3430 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3435 deprecate("chdir('') or chdir(undef) as chdir()");
3436 tmps = SvPV_nolen_const(*svp);
3440 TAINT_PROPER("chdir");
3445 TAINT_PROPER("chdir");
3448 IO* const io = GvIO(gv);
3452 PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0);
3454 DIE(aTHX_ PL_no_func, "dirfd");
3456 } else if (IoIFP(io)) {
3457 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3460 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3461 report_evil_fh(gv, io, PL_op->op_type);
3462 SETERRNO(EBADF, RMS_IFI);
3467 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3468 report_evil_fh(gv, io, PL_op->op_type);
3469 SETERRNO(EBADF,RMS_IFI);
3473 DIE(aTHX_ PL_no_func, "fchdir");
3477 PUSHi( PerlDir_chdir(tmps) >= 0 );
3479 /* Clear the DEFAULT element of ENV so we'll get the new value
3481 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3488 dVAR; dSP; dMARK; dTARGET;
3489 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3500 char * const tmps = POPpx;
3501 TAINT_PROPER("chroot");
3502 PUSHi( chroot(tmps) >= 0 );
3505 DIE(aTHX_ PL_no_func, "chroot");
3513 const char * const tmps2 = POPpconstx;
3514 const char * const tmps = SvPV_nolen_const(TOPs);
3515 TAINT_PROPER("rename");
3517 anum = PerlLIO_rename(tmps, tmps2);
3519 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3520 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3523 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3524 (void)UNLINK(tmps2);
3525 if (!(anum = link(tmps, tmps2)))
3526 anum = UNLINK(tmps);
3534 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3538 const int op_type = PL_op->op_type;
3542 if (op_type == OP_LINK)
3543 DIE(aTHX_ PL_no_func, "link");
3545 # ifndef HAS_SYMLINK
3546 if (op_type == OP_SYMLINK)
3547 DIE(aTHX_ PL_no_func, "symlink");
3551 const char * const tmps2 = POPpconstx;
3552 const char * const tmps = SvPV_nolen_const(TOPs);
3553 TAINT_PROPER(PL_op_desc[op_type]);
3555 # if defined(HAS_LINK)
3556 # if defined(HAS_SYMLINK)
3557 /* Both present - need to choose which. */
3558 (op_type == OP_LINK) ?
3559 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3561 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3562 PerlLIO_link(tmps, tmps2);
3565 # if defined(HAS_SYMLINK)
3566 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3567 symlink(tmps, tmps2);
3572 SETi( result >= 0 );
3579 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3590 char buf[MAXPATHLEN];
3593 #ifndef INCOMPLETE_TAINTS
3597 len = readlink(tmps, buf, sizeof(buf) - 1);
3605 RETSETUNDEF; /* just pretend it's a normal file */
3609 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3611 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3613 char * const save_filename = filename;
3618 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3620 Newx(cmdline, size, char);
3621 my_strlcpy(cmdline, cmd, size);
3622 my_strlcat(cmdline, " ", size);
3623 for (s = cmdline + strlen(cmdline); *filename; ) {
3627 if (s - cmdline < size)
3628 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3629 myfp = PerlProc_popen(cmdline, "r");
3633 SV * const tmpsv = sv_newmortal();
3634 /* Need to save/restore 'PL_rs' ?? */
3635 s = sv_gets(tmpsv, myfp, 0);
3636 (void)PerlProc_pclose(myfp);
3640 #ifdef HAS_SYS_ERRLIST
3645 /* you don't see this */
3646 const char * const errmsg =
3647 #ifdef HAS_SYS_ERRLIST
3655 if (instr(s, errmsg)) {
3662 #define EACCES EPERM
3664 if (instr(s, "cannot make"))
3665 SETERRNO(EEXIST,RMS_FEX);
3666 else if (instr(s, "existing file"))
3667 SETERRNO(EEXIST,RMS_FEX);
3668 else if (instr(s, "ile exists"))
3669 SETERRNO(EEXIST,RMS_FEX);
3670 else if (instr(s, "non-exist"))
3671 SETERRNO(ENOENT,RMS_FNF);
3672 else if (instr(s, "does not exist"))
3673 SETERRNO(ENOENT,RMS_FNF);
3674 else if (instr(s, "not empty"))
3675 SETERRNO(EBUSY,SS_DEVOFFLINE);
3676 else if (instr(s, "cannot access"))
3677 SETERRNO(EACCES,RMS_PRV);
3679 SETERRNO(EPERM,RMS_PRV);
3682 else { /* some mkdirs return no failure indication */
3683 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3684 if (PL_op->op_type == OP_RMDIR)
3689 SETERRNO(EACCES,RMS_PRV); /* a guess */
3698 /* This macro removes trailing slashes from a directory name.
3699 * Different operating and file systems take differently to
3700 * trailing slashes. According to POSIX 1003.1 1996 Edition
3701 * any number of trailing slashes should be allowed.
3702 * Thusly we snip them away so that even non-conforming
3703 * systems are happy.
3704 * We should probably do this "filtering" for all
3705 * the functions that expect (potentially) directory names:
3706 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3707 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3709 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3710 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3713 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3714 (tmps) = savepvn((tmps), (len)); \
3724 const int mode = (MAXARG > 1) ? POPi : 0777;
3726 TRIMSLASHES(tmps,len,copy);
3728 TAINT_PROPER("mkdir");
3730 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3734 SETi( dooneliner("mkdir", tmps) );
3735 oldumask = PerlLIO_umask(0);
3736 PerlLIO_umask(oldumask);
3737 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3752 TRIMSLASHES(tmps,len,copy);
3753 TAINT_PROPER("rmdir");
3755 SETi( PerlDir_rmdir(tmps) >= 0 );
3757 SETi( dooneliner("rmdir", tmps) );
3764 /* Directory calls. */
3768 #if defined(Direntry_t) && defined(HAS_READDIR)
3770 const char * const dirname = POPpconstx;
3771 GV * const gv = (GV*)POPs;
3772 register IO * const io = GvIOn(gv);
3777 if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED))
3778 Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3779 "Opening filehandle %s also as a directory", GvENAME(gv));
3781 PerlDir_close(IoDIRP(io));
3782 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3788 SETERRNO(EBADF,RMS_DIR);
3791 DIE(aTHX_ PL_no_dir_func, "opendir");
3797 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3798 DIE(aTHX_ PL_no_dir_func, "readdir");
3800 #if !defined(I_DIRENT) && !defined(VMS)
3801 Direntry_t *readdir (DIR *);
3807 const I32 gimme = GIMME;
3808 GV * const gv = (GV *)POPs;
3809 register const Direntry_t *dp;
3810 register IO * const io = GvIOn(gv);
3812 if (!io || !IoDIRP(io)) {
3813 if(ckWARN(WARN_IO)) {
3814 Perl_warner(aTHX_ packWARN(WARN_IO),
3815 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3821 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3825 sv = newSVpvn(dp->d_name, dp->d_namlen);
3827 sv = newSVpv(dp->d_name, 0);
3829 #ifndef INCOMPLETE_TAINTS
3830 if (!(IoFLAGS(io) & IOf_UNTAINT))
3833 XPUSHs(sv_2mortal(sv));
3834 } while (gimme == G_ARRAY);
3836 if (!dp && gimme != G_ARRAY)
3843 SETERRNO(EBADF,RMS_ISI);
3844 if (GIMME == G_ARRAY)
3853 #if defined(HAS_TELLDIR) || defined(telldir)
3855 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3856 /* XXX netbsd still seemed to.
3857 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3858 --JHI 1999-Feb-02 */
3859 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3860 long telldir (DIR *);
3862 GV * const gv = (GV*)POPs;
3863 register IO * const io = GvIOn(gv);
3865 if (!io || !IoDIRP(io)) {
3866 if(ckWARN(WARN_IO)) {
3867 Perl_warner(aTHX_ packWARN(WARN_IO),
3868 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3873 PUSHi( PerlDir_tell(IoDIRP(io)) );
3877 SETERRNO(EBADF,RMS_ISI);
3880 DIE(aTHX_ PL_no_dir_func, "telldir");
3886 #if defined(HAS_SEEKDIR) || defined(seekdir)
3888 const long along = POPl;
3889 GV * const gv = (GV*)POPs;
3890 register IO * const io = GvIOn(gv);
3892 if (!io || !IoDIRP(io)) {
3893 if(ckWARN(WARN_IO)) {
3894 Perl_warner(aTHX_ packWARN(WARN_IO),
3895 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3899 (void)PerlDir_seek(IoDIRP(io), along);
3904 SETERRNO(EBADF,RMS_ISI);
3907 DIE(aTHX_ PL_no_dir_func, "seekdir");
3913 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3915 GV * const gv = (GV*)POPs;
3916 register IO * const io = GvIOn(gv);
3918 if (!io || !IoDIRP(io)) {
3919 if(ckWARN(WARN_IO)) {
3920 Perl_warner(aTHX_ packWARN(WARN_IO),
3921 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3925 (void)PerlDir_rewind(IoDIRP(io));
3929 SETERRNO(EBADF,RMS_ISI);
3932 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3938 #if defined(Direntry_t) && defined(HAS_READDIR)
3940 GV * const gv = (GV*)POPs;
3941 register IO * const io = GvIOn(gv);
3943 if (!io || !IoDIRP(io)) {
3944 if(ckWARN(WARN_IO)) {
3945 Perl_warner(aTHX_ packWARN(WARN_IO),
3946 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3950 #ifdef VOID_CLOSEDIR
3951 PerlDir_close(IoDIRP(io));
3953 if (PerlDir_close(IoDIRP(io)) < 0) {
3954 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3963 SETERRNO(EBADF,RMS_IFI);
3966 DIE(aTHX_ PL_no_dir_func, "closedir");
3970 /* Process control. */
3979 PERL_FLUSHALL_FOR_CHILD;
3980 childpid = PerlProc_fork();
3984 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3986 SvREADONLY_off(GvSV(tmpgv));
3987 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3988 SvREADONLY_on(GvSV(tmpgv));
3990 #ifdef THREADS_HAVE_PIDS
3991 PL_ppid = (IV)getppid();
3993 #ifdef PERL_USES_PL_PIDSTATUS
3994 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4000 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4005 PERL_FLUSHALL_FOR_CHILD;
4006 childpid = PerlProc_fork();
4012 DIE(aTHX_ PL_no_func, "fork");
4019 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4024 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4025 childpid = wait4pid(-1, &argflags, 0);
4027 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4032 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4033 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4034 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4036 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4041 DIE(aTHX_ PL_no_func, "wait");
4047 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4049 const int optype = POPi;
4050 const Pid_t pid = TOPi;
4054 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4055 result = wait4pid(pid, &argflags, optype);
4057 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4062 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4063 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4064 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4066 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4071 DIE(aTHX_ PL_no_func, "waitpid");
4077 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4083 while (++MARK <= SP) {
4084 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4089 TAINT_PROPER("system");
4091 PERL_FLUSHALL_FOR_CHILD;
4092 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4098 if (PerlProc_pipe(pp) >= 0)
4100 while ((childpid = PerlProc_fork()) == -1) {
4101 if (errno != EAGAIN) {
4106 PerlLIO_close(pp[0]);
4107 PerlLIO_close(pp[1]);
4114 Sigsave_t ihand,qhand; /* place to save signals during system() */
4118 PerlLIO_close(pp[1]);
4120 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4121 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4124 result = wait4pid(childpid, &status, 0);
4125 } while (result == -1 && errno == EINTR);
4127 (void)rsignal_restore(SIGINT, &ihand);
4128 (void)rsignal_restore(SIGQUIT, &qhand);
4130 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4131 do_execfree(); /* free any memory child malloced on fork */
4138 while (n < sizeof(int)) {
4139 n1 = PerlLIO_read(pp[0],
4140 (void*)(((char*)&errkid)+n),
4146 PerlLIO_close(pp[0]);
4147 if (n) { /* Error */
4148 if (n != sizeof(int))
4149 DIE(aTHX_ "panic: kid popen errno read");
4150 errno = errkid; /* Propagate errno from kid */
4151 STATUS_NATIVE_CHILD_SET(-1);
4154 XPUSHi(STATUS_CURRENT);
4158 PerlLIO_close(pp[0]);
4159 #if defined(HAS_FCNTL) && defined(F_SETFD)
4160 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4163 if (PL_op->op_flags & OPf_STACKED) {
4164 SV * const really = *++MARK;
4165 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4167 else if (SP - MARK != 1)
4168 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4170 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4174 #else /* ! FORK or VMS or OS/2 */
4177 if (PL_op->op_flags & OPf_STACKED) {
4178 SV * const really = *++MARK;
4179 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4180 value = (I32)do_aspawn(really, MARK, SP);
4182 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4185 else if (SP - MARK != 1) {
4186 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4187 value = (I32)do_aspawn(NULL, MARK, SP);
4189 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4193 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4195 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4197 STATUS_NATIVE_CHILD_SET(value);
4200 XPUSHi(result ? value : STATUS_CURRENT);
4201 #endif /* !FORK or VMS */
4207 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4212 while (++MARK <= SP) {
4213 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4218 TAINT_PROPER("exec");
4220 PERL_FLUSHALL_FOR_CHILD;
4221 if (PL_op->op_flags & OPf_STACKED) {
4222 SV * const really = *++MARK;
4223 value = (I32)do_aexec(really, MARK, SP);
4225 else if (SP - MARK != 1)
4227 value = (I32)vms_do_aexec(NULL, MARK, SP);
4231 (void ) do_aspawn(NULL, MARK, SP);
4235 value = (I32)do_aexec(NULL, MARK, SP);
4240 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4243 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4246 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4260 # ifdef THREADS_HAVE_PIDS
4261 if (PL_ppid != 1 && getppid() == 1)
4262 /* maybe the parent process has died. Refresh ppid cache */
4266 XPUSHi( getppid() );
4270 DIE(aTHX_ PL_no_func, "getppid");
4279 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4282 pgrp = (I32)BSD_GETPGRP(pid);
4284 if (pid != 0 && pid != PerlProc_getpid())
4285 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4291 DIE(aTHX_ PL_no_func, "getpgrp()");
4310 TAINT_PROPER("setpgrp");
4312 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4314 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4315 || (pid != 0 && pid != PerlProc_getpid()))
4317 DIE(aTHX_ "setpgrp can't take arguments");
4319 SETi( setpgrp() >= 0 );
4320 #endif /* USE_BSDPGRP */
4323 DIE(aTHX_ PL_no_func, "setpgrp()");
4329 #ifdef HAS_GETPRIORITY
4331 const int who = POPi;
4332 const int which = TOPi;
4333 SETi( getpriority(which, who) );
4336 DIE(aTHX_ PL_no_func, "getpriority()");
4342 #ifdef HAS_SETPRIORITY
4344 const int niceval = POPi;
4345 const int who = POPi;
4346 const int which = TOPi;
4347 TAINT_PROPER("setpriority");
4348 SETi( setpriority(which, who, niceval) >= 0 );
4351 DIE(aTHX_ PL_no_func, "setpriority()");
4361 XPUSHn( time(NULL) );
4363 XPUSHi( time(NULL) );
4375 (void)PerlProc_times(&PL_timesbuf);
4377 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4378 /* struct tms, though same data */
4382 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
4383 if (GIMME == G_ARRAY) {
4384 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
4385 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
4386 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
4392 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4394 if (GIMME == G_ARRAY) {
4395 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4396 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4397 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4401 DIE(aTHX_ "times not implemented");
4403 #endif /* HAS_TIMES */
4406 #ifdef LOCALTIME_EDGECASE_BROKEN
4407 static struct tm *S_my_localtime (pTHX_ Time_t *tp)
4412 /* No workarounds in the valid range */
4413 if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4414 return (localtime (tp));
4416 /* This edge case is to workaround the undefined behaviour, where the
4417 * TIMEZONE makes the time go beyond the defined range.
4418 * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4419 * If there is a negative offset in TZ, like MET-1METDST, some broken
4420 * implementations of localtime () (like AIX 5.2) barf with bogus
4422 * 0x7fffffff gmtime 2038-01-19 03:14:07
4423 * 0x7fffffff localtime 1901-12-13 21:45:51
4424 * 0x7fffffff mylocaltime 2038-01-19 04:14:07
4425 * 0x3c19137f gmtime 2001-12-13 20:45:51
4426 * 0x3c19137f localtime 2001-12-13 21:45:51
4427 * 0x3c19137f mylocaltime 2001-12-13 21:45:51
4428 * Given that legal timezones are typically between GMT-12 and GMT+12
4429 * we turn back the clock 23 hours before calling the localtime
4430 * function, and add those to the return value. This will never cause
4431 * day wrapping problems, since the edge case is Tue Jan *19*
4433 T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4436 if (P->tm_hour >= 24) {
4438 P->tm_mday++; /* 18 -> 19 */
4439 P->tm_wday++; /* Mon -> Tue */
4440 P->tm_yday++; /* 18 -> 19 */
4443 } /* S_my_localtime */
4451 const struct tm *tmbuf;
4452 static const char * const dayname[] =
4453 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4454 static const char * const monname[] =
4455 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4456 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4462 when = (Time_t)SvNVx(POPs);
4464 when = (Time_t)SvIVx(POPs);
4467 if (PL_op->op_type == OP_LOCALTIME)
4468 #ifdef LOCALTIME_EDGECASE_BROKEN
4469 tmbuf = S_my_localtime(aTHX_ &when);
4471 tmbuf = localtime(&when);
4474 tmbuf = gmtime(&when);
4476 if (GIMME != G_ARRAY) {
4482 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4483 dayname[tmbuf->tm_wday],
4484 monname[tmbuf->tm_mon],
4489 tmbuf->tm_year + 1900);
4490 PUSHs(sv_2mortal(tsv));
4495 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4496 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4497 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4498 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4499 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4500 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4501 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4502 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4503 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4514 anum = alarm((unsigned int)anum);
4521 DIE(aTHX_ PL_no_func, "alarm");
4532 (void)time(&lasttime);
4537 PerlProc_sleep((unsigned int)duration);
4540 XPUSHi(when - lasttime);
4544 /* Shared memory. */
4545 /* Merged with some message passing. */
4549 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4550 dVAR; dSP; dMARK; dTARGET;
4551 const int op_type = PL_op->op_type;
4556 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4559 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4562 value = (I32)(do_semop(MARK, SP) >= 0);
4565 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4581 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4582 dVAR; dSP; dMARK; dTARGET;
4583 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4590 DIE(aTHX_ "System V IPC is not implemented on this machine");
4596 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4597 dVAR; dSP; dMARK; dTARGET;
4598 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4606 PUSHp(zero_but_true, ZBTLEN);
4614 /* I can't const this further without getting warnings about the types of
4615 various arrays passed in from structures. */
4617 S_space_join_names_mortal(pTHX_ char *const *array)
4621 if (array && *array) {
4622 target = sv_2mortal(newSVpvs(""));
4624 sv_catpv(target, *array);
4627 sv_catpvs(target, " ");
4630 target = sv_mortalcopy(&PL_sv_no);
4635 /* Get system info. */
4639 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4641 I32 which = PL_op->op_type;
4642 register char **elem;
4644 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4645 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4646 struct hostent *gethostbyname(Netdb_name_t);
4647 struct hostent *gethostent(void);
4649 struct hostent *hent;
4653 if (which == OP_GHBYNAME) {
4654 #ifdef HAS_GETHOSTBYNAME
4655 const char* const name = POPpbytex;
4656 hent = PerlSock_gethostbyname(name);
4658 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4661 else if (which == OP_GHBYADDR) {
4662 #ifdef HAS_GETHOSTBYADDR
4663 const int addrtype = POPi;
4664 SV * const addrsv = POPs;
4666 Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4668 hent = PerlSock_gethostbyaddr((const char*)addr, (Netdb_hlen_t) addrlen, addrtype);
4670 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4674 #ifdef HAS_GETHOSTENT
4675 hent = PerlSock_gethostent();
4677 DIE(aTHX_ PL_no_sock_func, "gethostent");
4680 #ifdef HOST_NOT_FOUND
4682 #ifdef USE_REENTRANT_API
4683 # ifdef USE_GETHOSTENT_ERRNO
4684 h_errno = PL_reentrant_buffer->_gethostent_errno;
4687 STATUS_UNIX_SET(h_errno);
4691 if (GIMME != G_ARRAY) {
4692 PUSHs(sv = sv_newmortal());
4694 if (which == OP_GHBYNAME) {
4696 sv_setpvn(sv, hent->h_addr, hent->h_length);
4699 sv_setpv(sv, (char*)hent->h_name);
4705 PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
4706 PUSHs(space_join_names_mortal(hent->h_aliases));
4707 PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
4708 len = hent->h_length;
4709 PUSHs(sv_2mortal(newSViv((IV)len)));
4711 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4712 XPUSHs(sv_2mortal(newSVpvn(*elem, len)));
4716 PUSHs(newSVpvn(hent->h_addr, len));
4718 PUSHs(sv_mortalcopy(&PL_sv_no));
4723 DIE(aTHX_ PL_no_sock_func, "gethostent");
4729 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4731 I32 which = PL_op->op_type;
4733 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4734 struct netent *getnetbyaddr(Netdb_net_t, int);
4735 struct netent *getnetbyname(Netdb_name_t);
4736 struct netent *getnetent(void);
4738 struct netent *nent;
4740 if (which == OP_GNBYNAME){
4741 #ifdef HAS_GETNETBYNAME
4742 const char * const name = POPpbytex;
4743 nent = PerlSock_getnetbyname(name);
4745 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4748 else if (which == OP_GNBYADDR) {
4749 #ifdef HAS_GETNETBYADDR
4750 const int addrtype = POPi;
4751 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4752 nent = PerlSock_getnetbyaddr(addr, addrtype);
4754 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4758 #ifdef HAS_GETNETENT
4759 nent = PerlSock_getnetent();
4761 DIE(aTHX_ PL_no_sock_func, "getnetent");
4764 #ifdef HOST_NOT_FOUND
4766 #ifdef USE_REENTRANT_API
4767 # ifdef USE_GETNETENT_ERRNO
4768 h_errno = PL_reentrant_buffer->_getnetent_errno;
4771 STATUS_UNIX_SET(h_errno);
4776 if (GIMME != G_ARRAY) {
4777 PUSHs(sv = sv_newmortal());
4779 if (which == OP_GNBYNAME)
4780 sv_setiv(sv, (IV)nent->n_net);
4782 sv_setpv(sv, nent->n_name);
4788 PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
4789 PUSHs(space_join_names_mortal(nent->n_aliases));
4790 PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
4791 PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
4796 DIE(aTHX_ PL_no_sock_func, "getnetent");
4802 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4804 I32 which = PL_op->op_type;
4806 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4807 struct protoent *getprotobyname(Netdb_name_t);
4808 struct protoent *getprotobynumber(int);
4809 struct protoent *getprotoent(void);
4811 struct protoent *pent;
4813 if (which == OP_GPBYNAME) {
4814 #ifdef HAS_GETPROTOBYNAME
4815 const char* const name = POPpbytex;
4816 pent = PerlSock_getprotobyname(name);
4818 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4821 else if (which == OP_GPBYNUMBER) {
4822 #ifdef HAS_GETPROTOBYNUMBER
4823 const int number = POPi;
4824 pent = PerlSock_getprotobynumber(number);
4826 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4830 #ifdef HAS_GETPROTOENT
4831 pent = PerlSock_getprotoent();
4833 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4837 if (GIMME != G_ARRAY) {
4838 PUSHs(sv = sv_newmortal());
4840 if (which == OP_GPBYNAME)
4841 sv_setiv(sv, (IV)pent->p_proto);
4843 sv_setpv(sv, pent->p_name);
4849 PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
4850 PUSHs(space_join_names_mortal(pent->p_aliases));
4851 PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
4856 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4862 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4864 I32 which = PL_op->op_type;
4866 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4867 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4868 struct servent *getservbyport(int, Netdb_name_t);
4869 struct servent *getservent(void);
4871 struct servent *sent;
4873 if (which == OP_GSBYNAME) {
4874 #ifdef HAS_GETSERVBYNAME
4875 const char * const proto = POPpbytex;
4876 const char * const name = POPpbytex;
4877 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4879 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4882 else if (which == OP_GSBYPORT) {
4883 #ifdef HAS_GETSERVBYPORT
4884 const char * const proto = POPpbytex;
4885 unsigned short port = (unsigned short)POPu;
4887 port = PerlSock_htons(port);
4889 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4891 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4895 #ifdef HAS_GETSERVENT
4896 sent = PerlSock_getservent();
4898 DIE(aTHX_ PL_no_sock_func, "getservent");
4902 if (GIMME != G_ARRAY) {
4903 PUSHs(sv = sv_newmortal());
4905 if (which == OP_GSBYNAME) {
4907 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4909 sv_setiv(sv, (IV)(sent->s_port));
4913 sv_setpv(sv, sent->s_name);
4919 PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
4920 PUSHs(space_join_names_mortal(sent->s_aliases));
4922 PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
4924 PUSHs(sv_2mortal(newSViv((IV)(sent->s_port))));
4926 PUSHs(sv_2mortal(newSVpv(sent->s_proto, 0)));
4931 DIE(aTHX_ PL_no_sock_func, "getservent");
4937 #ifdef HAS_SETHOSTENT
4939 PerlSock_sethostent(TOPi);
4942 DIE(aTHX_ PL_no_sock_func, "sethostent");
4948 #ifdef HAS_SETNETENT
4950 PerlSock_setnetent(TOPi);
4953 DIE(aTHX_ PL_no_sock_func, "setnetent");
4959 #ifdef HAS_SETPROTOENT
4961 PerlSock_setprotoent(TOPi);
4964 DIE(aTHX_ PL_no_sock_func, "setprotoent");
4970 #ifdef HAS_SETSERVENT
4972 PerlSock_setservent(TOPi);
4975 DIE(aTHX_ PL_no_sock_func, "setservent");
4981 #ifdef HAS_ENDHOSTENT
4983 PerlSock_endhostent();
4987 DIE(aTHX_ PL_no_sock_func, "endhostent");
4993 #ifdef HAS_ENDNETENT
4995 PerlSock_endnetent();
4999 DIE(aTHX_ PL_no_sock_func, "endnetent");
5005 #ifdef HAS_ENDPROTOENT
5007 PerlSock_endprotoent();
5011 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5017 #ifdef HAS_ENDSERVENT
5019 PerlSock_endservent();
5023 DIE(aTHX_ PL_no_sock_func, "endservent");
5031 I32 which = PL_op->op_type;
5033 struct passwd *pwent = NULL;
5035 * We currently support only the SysV getsp* shadow password interface.
5036 * The interface is declared in <shadow.h> and often one needs to link
5037 * with -lsecurity or some such.
5038 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5041 * AIX getpwnam() is clever enough to return the encrypted password
5042 * only if the caller (euid?) is root.
5044 * There are at least three other shadow password APIs. Many platforms
5045 * seem to contain more than one interface for accessing the shadow
5046 * password databases, possibly for compatibility reasons.
5047 * The getsp*() is by far he simplest one, the other two interfaces
5048 * are much more complicated, but also very similar to each other.
5053 * struct pr_passwd *getprpw*();
5054 * The password is in
5055 * char getprpw*(...).ufld.fd_encrypt[]
5056 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5061 * struct es_passwd *getespw*();
5062 * The password is in
5063 * char *(getespw*(...).ufld.fd_encrypt)
5064 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5067 * struct userpw *getuserpw();
5068 * The password is in
5069 * char *(getuserpw(...)).spw_upw_passwd
5070 * (but the de facto standard getpwnam() should work okay)
5072 * Mention I_PROT here so that Configure probes for it.
5074 * In HP-UX for getprpw*() the manual page claims that one should include
5075 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5076 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5077 * and pp_sys.c already includes <shadow.h> if there is such.
5079 * Note that <sys/security.h> is already probed for, but currently
5080 * it is only included in special cases.
5082 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5083 * be preferred interface, even though also the getprpw*() interface
5084 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5085 * One also needs to call set_auth_parameters() in main() before
5086 * doing anything else, whether one is using getespw*() or getprpw*().
5088 * Note that accessing the shadow databases can be magnitudes
5089 * slower than accessing the standard databases.
5094 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5095 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5096 * the pw_comment is left uninitialized. */
5097 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5103 const char* const name = POPpbytex;
5104 pwent = getpwnam(name);
5110 pwent = getpwuid(uid);
5114 # ifdef HAS_GETPWENT
5116 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5117 if (pwent) pwent = getpwnam(pwent->pw_name);
5120 DIE(aTHX_ PL_no_func, "getpwent");
5126 if (GIMME != G_ARRAY) {
5127 PUSHs(sv = sv_newmortal());
5129 if (which == OP_GPWNAM)
5130 # if Uid_t_sign <= 0
5131 sv_setiv(sv, (IV)pwent->pw_uid);
5133 sv_setuv(sv, (UV)pwent->pw_uid);
5136 sv_setpv(sv, pwent->pw_name);
5142 PUSHs(sv_2mortal(newSVpv(pwent->pw_name, 0)));
5144 PUSHs(sv = sv_2mortal(newSViv(0)));
5145 /* If we have getspnam(), we try to dig up the shadow
5146 * password. If we are underprivileged, the shadow
5147 * interface will set the errno to EACCES or similar,
5148 * and return a null pointer. If this happens, we will
5149 * use the dummy password (usually "*" or "x") from the
5150 * standard password database.
5152 * In theory we could skip the shadow call completely
5153 * if euid != 0 but in practice we cannot know which
5154 * security measures are guarding the shadow databases
5155 * on a random platform.
5157 * Resist the urge to use additional shadow interfaces.
5158 * Divert the urge to writing an extension instead.
5161 /* Some AIX setups falsely(?) detect some getspnam(), which
5162 * has a different API than the Solaris/IRIX one. */
5163 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5165 const int saverrno = errno;
5166 const struct spwd * const spwent = getspnam(pwent->pw_name);
5167 /* Save and restore errno so that
5168 * underprivileged attempts seem
5169 * to have never made the unsccessful
5170 * attempt to retrieve the shadow password. */
5172 if (spwent && spwent->sp_pwdp)
5173 sv_setpv(sv, spwent->sp_pwdp);
5177 if (!SvPOK(sv)) /* Use the standard password, then. */
5178 sv_setpv(sv, pwent->pw_passwd);
5181 # ifndef INCOMPLETE_TAINTS
5182 /* passwd is tainted because user himself can diddle with it.
5183 * admittedly not much and in a very limited way, but nevertheless. */
5187 # if Uid_t_sign <= 0
5188 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_uid)));
5190 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_uid)));
5193 # if Uid_t_sign <= 0
5194 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_gid)));
5196 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_gid)));
5198 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5199 * because of the poor interface of the Perl getpw*(),
5200 * not because there's some standard/convention saying so.
5201 * A better interface would have been to return a hash,
5202 * but we are accursed by our history, alas. --jhi. */
5204 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_change)));
5207 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_quota)));
5210 PUSHs(sv_2mortal(newSVpv(pwent->pw_age, 0)));
5212 /* I think that you can never get this compiled, but just in case. */
5213 PUSHs(sv_mortalcopy(&PL_sv_no));
5218 /* pw_class and pw_comment are mutually exclusive--.
5219 * see the above note for pw_change, pw_quota, and pw_age. */
5221 PUSHs(sv_2mortal(newSVpv(pwent->pw_class, 0)));
5224 PUSHs(sv_2mortal(newSVpv(pwent->pw_comment, 0)));
5226 /* I think that you can never get this compiled, but just in case. */
5227 PUSHs(sv_mortalcopy(&PL_sv_no));
5232 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5234 PUSHs(sv_mortalcopy(&PL_sv_no));
5236 # ifndef INCOMPLETE_TAINTS
5237 /* pw_gecos is tainted because user himself can diddle with it. */
5241 PUSHs(sv_2mortal(newSVpv(pwent->pw_dir, 0)));
5243 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5244 # ifndef INCOMPLETE_TAINTS
5245 /* pw_shell is tainted because user himself can diddle with it. */
5250 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_expire)));
5255 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5261 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5266 DIE(aTHX_ PL_no_func, "setpwent");
5272 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5277 DIE(aTHX_ PL_no_func, "endpwent");
5285 const I32 which = PL_op->op_type;
5286 const struct group *grent;
5288 if (which == OP_GGRNAM) {
5289 const char* const name = POPpbytex;
5290 grent = (const struct group *)getgrnam(name);
5292 else if (which == OP_GGRGID) {
5293 const Gid_t gid = POPi;
5294 grent = (const struct group *)getgrgid(gid);
5298 grent = (struct group *)getgrent();
5300 DIE(aTHX_ PL_no_func, "getgrent");
5304 if (GIMME != G_ARRAY) {
5305 SV * const sv = sv_newmortal();
5309 if (which == OP_GGRNAM)
5310 sv_setiv(sv, (IV)grent->gr_gid);
5312 sv_setpv(sv, grent->gr_name);
5318 PUSHs(sv_2mortal(newSVpv(grent->gr_name, 0)));
5321 PUSHs(sv_2mortal(newSVpv(grent->gr_passwd, 0)));
5323 PUSHs(sv_mortalcopy(&PL_sv_no));
5326 PUSHs(sv_2mortal(newSViv((IV)grent->gr_gid)));
5328 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5329 /* In UNICOS/mk (_CRAYMPP) the multithreading
5330 * versions (getgrnam_r, getgrgid_r)
5331 * seem to return an illegal pointer
5332 * as the group members list, gr_mem.
5333 * getgrent() doesn't even have a _r version
5334 * but the gr_mem is poisonous anyway.
5335 * So yes, you cannot get the list of group
5336 * members if building multithreaded in UNICOS/mk. */
5337 PUSHs(space_join_names_mortal(grent->gr_mem));
5343 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5349 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5354 DIE(aTHX_ PL_no_func, "setgrent");
5360 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5365 DIE(aTHX_ PL_no_func, "endgrent");
5375 if (!(tmps = PerlProc_getlogin()))
5377 PUSHp(tmps, strlen(tmps));
5380 DIE(aTHX_ PL_no_func, "getlogin");
5384 /* Miscellaneous. */
5389 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5390 register I32 items = SP - MARK;
5391 unsigned long a[20];
5396 while (++MARK <= SP) {
5397 if (SvTAINTED(*MARK)) {
5403 TAINT_PROPER("syscall");
5406 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5407 * or where sizeof(long) != sizeof(char*). But such machines will
5408 * not likely have syscall implemented either, so who cares?
5410 while (++MARK <= SP) {
5411 if (SvNIOK(*MARK) || !i)
5412 a[i++] = SvIV(*MARK);
5413 else if (*MARK == &PL_sv_undef)
5416 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5422 DIE(aTHX_ "Too many args to syscall");
5424 DIE(aTHX_ "Too few args to syscall");
5426 retval = syscall(a[0]);
5429 retval = syscall(a[0],a[1]);
5432 retval = syscall(a[0],a[1],a[2]);
5435 retval = syscall(a[0],a[1],a[2],a[3]);
5438 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5441 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5444 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5447 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5451 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5454 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],
5465 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5469 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5470 a[10],a[11],a[12],a[13]);
5472 #endif /* atarist */
5478 DIE(aTHX_ PL_no_func, "syscall");
5482 #ifdef FCNTL_EMULATE_FLOCK
5484 /* XXX Emulate flock() with fcntl().
5485 What's really needed is a good file locking module.
5489 fcntl_emulate_flock(int fd, int operation)
5493 switch (operation & ~LOCK_NB) {
5495 flock.l_type = F_RDLCK;
5498 flock.l_type = F_WRLCK;
5501 flock.l_type = F_UNLCK;
5507 flock.l_whence = SEEK_SET;
5508 flock.l_start = flock.l_len = (Off_t)0;
5510 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5513 #endif /* FCNTL_EMULATE_FLOCK */
5515 #ifdef LOCKF_EMULATE_FLOCK
5517 /* XXX Emulate flock() with lockf(). This is just to increase
5518 portability of scripts. The calls are not completely
5519 interchangeable. What's really needed is a good file
5523 /* The lockf() constants might have been defined in <unistd.h>.
5524 Unfortunately, <unistd.h> causes troubles on some mixed
5525 (BSD/POSIX) systems, such as SunOS 4.1.3.
5527 Further, the lockf() constants aren't POSIX, so they might not be
5528 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5529 just stick in the SVID values and be done with it. Sigh.
5533 # define F_ULOCK 0 /* Unlock a previously locked region */
5536 # define F_LOCK 1 /* Lock a region for exclusive use */
5539 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5542 # define F_TEST 3 /* Test a region for other processes locks */
5546 lockf_emulate_flock(int fd, int operation)
5549 const int save_errno = errno;
5552 /* flock locks entire file so for lockf we need to do the same */
5553 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5554 if (pos > 0) /* is seekable and needs to be repositioned */
5555 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5556 pos = -1; /* seek failed, so don't seek back afterwards */
5559 switch (operation) {
5561 /* LOCK_SH - get a shared lock */
5563 /* LOCK_EX - get an exclusive lock */
5565 i = lockf (fd, F_LOCK, 0);
5568 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5569 case LOCK_SH|LOCK_NB:
5570 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5571 case LOCK_EX|LOCK_NB:
5572 i = lockf (fd, F_TLOCK, 0);
5574 if ((errno == EAGAIN) || (errno == EACCES))
5575 errno = EWOULDBLOCK;
5578 /* LOCK_UN - unlock (non-blocking is a no-op) */
5580 case LOCK_UN|LOCK_NB:
5581 i = lockf (fd, F_ULOCK, 0);
5584 /* Default - can't decipher operation */
5591 if (pos > 0) /* need to restore position of the handle */
5592 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5597 #endif /* LOCKF_EMULATE_FLOCK */
5601 * c-indentation-style: bsd
5603 * indent-tabs-mode: t
5606 * ex: set ts=8 sts=4 sw=4 noet: