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)))
302 /* With it or without it: anyway you get a warning: either that
303 it is unused, or it is declared static and never defined.
306 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
308 PERL_UNUSED_ARG(path);
309 PERL_UNUSED_ARG(mode);
310 Perl_croak(aTHX_ "switching effective uid is not implemented");
320 const char * const tmps = POPpconstx;
321 const I32 gimme = GIMME_V;
322 const char *mode = "r";
325 if (PL_op->op_private & OPpOPEN_IN_RAW)
327 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
329 fp = PerlProc_popen(tmps, mode);
331 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
333 PerlIO_apply_layers(aTHX_ fp,mode,type);
335 if (gimme == G_VOID) {
337 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
340 else if (gimme == G_SCALAR) {
343 PL_rs = &PL_sv_undef;
344 sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */
345 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
353 SV * const sv = newSV(79);
354 if (sv_gets(sv, fp, 0) == NULL) {
358 XPUSHs(sv_2mortal(sv));
359 if (SvLEN(sv) - SvCUR(sv) > 20) {
360 SvPV_shrink_to_cur(sv);
365 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
366 TAINT; /* "I believe that this is not gratuitous!" */
369 STATUS_NATIVE_CHILD_SET(-1);
370 if (gimme == G_SCALAR)
381 tryAMAGICunTARGET(iter, -1);
383 /* Note that we only ever get here if File::Glob fails to load
384 * without at the same time croaking, for some reason, or if
385 * perl was built with PERL_EXTERNAL_GLOB */
392 * The external globbing program may use things we can't control,
393 * so for security reasons we must assume the worst.
396 taint_proper(PL_no_security, "glob");
400 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
401 PL_last_in_gv = (GV*)*PL_stack_sp--;
403 SAVESPTR(PL_rs); /* This is not permanent, either. */
404 PL_rs = sv_2mortal(newSVpvs("\000"));
407 *SvPVX(PL_rs) = '\n';
411 result = do_readline();
419 PL_last_in_gv = cGVOP_gv;
420 return do_readline();
431 do_join(TARG, &PL_sv_no, MARK, SP);
435 else if (SP == MARK) {
443 tmps = SvPV_const(tmpsv, len);
444 if ((!tmps || !len) && PL_errgv) {
445 SV * const error = ERRSV;
446 SvUPGRADE(error, SVt_PV);
447 if (SvPOK(error) && SvCUR(error))
448 sv_catpvs(error, "\t...caught");
450 tmps = SvPV_const(tmpsv, len);
453 tmpsv = sv_2mortal(newSVpvs("Warning: something's wrong"));
455 Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv));
467 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
469 if (SP - MARK != 1) {
471 do_join(TARG, &PL_sv_no, MARK, SP);
473 tmps = SvPV_const(tmpsv, len);
479 tmps = SvROK(tmpsv) ? (const char *)NULL : SvPV_const(tmpsv, len);
482 SV * const error = ERRSV;
483 SvUPGRADE(error, SVt_PV);
484 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
486 SvSetSV(error,tmpsv);
487 else if (sv_isobject(error)) {
488 HV * const stash = SvSTASH(SvRV(error));
489 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
491 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
492 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
499 call_sv((SV*)GvCV(gv),
500 G_SCALAR|G_EVAL|G_KEEPERR);
501 sv_setsv(error,*PL_stack_sp--);
507 if (SvPOK(error) && SvCUR(error))
508 sv_catpvs(error, "\t...propagated");
511 tmps = SvPV_const(tmpsv, len);
517 tmpsv = sv_2mortal(newSVpvs("Died"));
519 DIE(aTHX_ "%"SVf, SVfARG(tmpsv));
535 GV * const gv = (GV *)*++MARK;
538 DIE(aTHX_ PL_no_usym, "filehandle");
540 if ((io = GvIOp(gv))) {
542 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
544 if (IoDIRP(io) && ckWARN2(WARN_IO, WARN_DEPRECATED))
545 Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
546 "Opening dirhandle %s also as a file", GvENAME(gv));
548 mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
550 /* Method's args are same as ours ... */
551 /* ... except handle is replaced by the object */
552 *MARK-- = SvTIED_obj((SV*)io, mg);
556 call_method("OPEN", G_SCALAR);
570 tmps = SvPV_const(sv, len);
571 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
574 PUSHi( (I32)PL_forkprocess );
575 else if (PL_forkprocess == 0) /* we are a new child */
585 GV * const gv = (MAXARG == 0) ? PL_defoutgv : (GV*)POPs;
588 IO * const io = GvIO(gv);
590 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
593 XPUSHs(SvTIED_obj((SV*)io, mg));
596 call_method("CLOSE", G_SCALAR);
604 PUSHs(boolSV(do_close(gv, TRUE)));
617 GV * const wgv = (GV*)POPs;
618 GV * const rgv = (GV*)POPs;
623 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
624 DIE(aTHX_ PL_no_usym, "filehandle");
629 do_close(rgv, FALSE);
631 do_close(wgv, FALSE);
633 if (PerlProc_pipe(fd) < 0)
636 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
637 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
638 IoOFP(rstio) = IoIFP(rstio);
639 IoIFP(wstio) = IoOFP(wstio);
640 IoTYPE(rstio) = IoTYPE_RDONLY;
641 IoTYPE(wstio) = IoTYPE_WRONLY;
643 if (!IoIFP(rstio) || !IoOFP(wstio)) {
645 PerlIO_close(IoIFP(rstio));
647 PerlLIO_close(fd[0]);
649 PerlIO_close(IoOFP(wstio));
651 PerlLIO_close(fd[1]);
654 #if defined(HAS_FCNTL) && defined(F_SETFD)
655 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
656 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
663 DIE(aTHX_ PL_no_func, "pipe");
679 if (gv && (io = GvIO(gv))
680 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
683 XPUSHs(SvTIED_obj((SV*)io, mg));
686 call_method("FILENO", G_SCALAR);
692 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
693 /* Can't do this because people seem to do things like
694 defined(fileno($foo)) to check whether $foo is a valid fh.
695 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
696 report_evil_fh(gv, io, PL_op->op_type);
701 PUSHi(PerlIO_fileno(fp));
714 anum = PerlLIO_umask(022);
715 /* setting it to 022 between the two calls to umask avoids
716 * to have a window where the umask is set to 0 -- meaning
717 * that another thread could create world-writeable files. */
719 (void)PerlLIO_umask(anum);
722 anum = PerlLIO_umask(POPi);
723 TAINT_PROPER("umask");
726 /* Only DIE if trying to restrict permissions on "user" (self).
727 * Otherwise it's harmless and more useful to just return undef
728 * since 'group' and 'other' concepts probably don't exist here. */
729 if (MAXARG >= 1 && (POPi & 0700))
730 DIE(aTHX_ "umask not implemented");
731 XPUSHs(&PL_sv_undef);
752 if (gv && (io = GvIO(gv))) {
753 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
756 XPUSHs(SvTIED_obj((SV*)io, mg));
761 call_method("BINMODE", G_SCALAR);
769 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
770 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
771 report_evil_fh(gv, io, PL_op->op_type);
772 SETERRNO(EBADF,RMS_IFI);
778 const int mode = mode_from_discipline(discp);
779 const char *const d = (discp ? SvPV_nolen_const(discp) : NULL);
780 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
781 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
782 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
803 const I32 markoff = MARK - PL_stack_base;
804 const char *methname;
805 int how = PERL_MAGIC_tied;
809 switch(SvTYPE(varsv)) {
811 methname = "TIEHASH";
812 HvEITER_set((HV *)varsv, 0);
815 methname = "TIEARRAY";
818 #ifdef GV_UNIQUE_CHECK
819 if (GvUNIQUE((GV*)varsv)) {
820 Perl_croak(aTHX_ "Attempt to tie unique GV");
823 methname = "TIEHANDLE";
824 how = PERL_MAGIC_tiedscalar;
825 /* For tied filehandles, we apply tiedscalar magic to the IO
826 slot of the GP rather than the GV itself. AMS 20010812 */
828 GvIOp(varsv) = newIO();
829 varsv = (SV *)GvIOp(varsv);
832 methname = "TIESCALAR";
833 how = PERL_MAGIC_tiedscalar;
837 if (sv_isobject(*MARK)) {
839 PUSHSTACKi(PERLSI_MAGIC);
841 EXTEND(SP,(I32)items);
845 call_method(methname, G_SCALAR);
848 /* Not clear why we don't call call_method here too.
849 * perhaps to get different error message ?
851 stash = gv_stashsv(*MARK, 0);
852 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
853 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
854 methname, SVfARG(*MARK));
857 PUSHSTACKi(PERLSI_MAGIC);
859 EXTEND(SP,(I32)items);
863 call_sv((SV*)GvCV(gv), G_SCALAR);
869 if (sv_isobject(sv)) {
870 sv_unmagic(varsv, how);
871 /* Croak if a self-tie on an aggregate is attempted. */
872 if (varsv == SvRV(sv) &&
873 (SvTYPE(varsv) == SVt_PVAV ||
874 SvTYPE(varsv) == SVt_PVHV))
876 "Self-ties of arrays and hashes are not supported");
877 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
880 SP = PL_stack_base + markoff;
890 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
891 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
893 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
896 if ((mg = SvTIED_mg(sv, how))) {
897 SV * const obj = SvRV(SvTIED_obj(sv, mg));
899 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
901 if (gv && isGV(gv) && (cv = GvCV(gv))) {
903 XPUSHs(SvTIED_obj((SV*)gv, mg));
904 XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
907 call_sv((SV *)cv, G_VOID);
911 else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
912 Perl_warner(aTHX_ packWARN(WARN_UNTIE),
913 "untie attempted while %"UVuf" inner references still exist",
914 (UV)SvREFCNT(obj) - 1 ) ;
918 sv_unmagic(sv, how) ;
928 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
929 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
931 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
934 if ((mg = SvTIED_mg(sv, how))) {
935 SV *osv = SvTIED_obj(sv, mg);
936 if (osv == mg->mg_obj)
937 osv = sv_mortalcopy(osv);
951 HV * const hv = (HV*)POPs;
952 SV * const sv = sv_2mortal(newSVpvs("AnyDBM_File"));
953 stash = gv_stashsv(sv, 0);
954 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
956 require_pv("AnyDBM_File.pm");
958 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
959 DIE(aTHX_ "No dbm on this machine");
969 PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
971 PUSHs(sv_2mortal(newSVuv(O_RDWR)));
974 call_sv((SV*)GvCV(gv), G_SCALAR);
977 if (!sv_isobject(TOPs)) {
982 PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
985 call_sv((SV*)GvCV(gv), G_SCALAR);
989 if (sv_isobject(TOPs)) {
990 sv_unmagic((SV *) hv, PERL_MAGIC_tied);
991 sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, NULL, 0);
1008 struct timeval timebuf;
1009 struct timeval *tbuf = &timebuf;
1012 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1017 # if BYTEORDER & 0xf0000
1018 # define ORDERBYTE (0x88888888 - BYTEORDER)
1020 # define ORDERBYTE (0x4444 - BYTEORDER)
1026 for (i = 1; i <= 3; i++) {
1027 SV * const sv = SP[i];
1030 if (SvREADONLY(sv)) {
1032 sv_force_normal_flags(sv, 0);
1033 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1034 DIE(aTHX_ PL_no_modify);
1037 if (ckWARN(WARN_MISC))
1038 Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1039 SvPV_force_nolen(sv); /* force string conversion */
1046 /* little endians can use vecs directly */
1047 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1054 masksize = NFDBITS / NBBY;
1056 masksize = sizeof(long); /* documented int, everyone seems to use long */
1058 Zero(&fd_sets[0], 4, char*);
1061 # if SELECT_MIN_BITS == 1
1062 growsize = sizeof(fd_set);
1064 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1065 # undef SELECT_MIN_BITS
1066 # define SELECT_MIN_BITS __FD_SETSIZE
1068 /* If SELECT_MIN_BITS is greater than one we most probably will want
1069 * to align the sizes with SELECT_MIN_BITS/8 because for example
1070 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1071 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1072 * on (sets/tests/clears bits) is 32 bits. */
1073 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1081 timebuf.tv_sec = (long)value;
1082 value -= (NV)timebuf.tv_sec;
1083 timebuf.tv_usec = (long)(value * 1000000.0);
1088 for (i = 1; i <= 3; i++) {
1090 if (!SvOK(sv) || SvCUR(sv) == 0) {
1097 Sv_Grow(sv, growsize);
1101 while (++j <= growsize) {
1105 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1107 Newx(fd_sets[i], growsize, char);
1108 for (offset = 0; offset < growsize; offset += masksize) {
1109 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1110 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1113 fd_sets[i] = SvPVX(sv);
1117 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1118 /* Can't make just the (void*) conditional because that would be
1119 * cpp #if within cpp macro, and not all compilers like that. */
1120 nfound = PerlSock_select(
1122 (Select_fd_set_t) fd_sets[1],
1123 (Select_fd_set_t) fd_sets[2],
1124 (Select_fd_set_t) fd_sets[3],
1125 (void*) tbuf); /* Workaround for compiler bug. */
1127 nfound = PerlSock_select(
1129 (Select_fd_set_t) fd_sets[1],
1130 (Select_fd_set_t) fd_sets[2],
1131 (Select_fd_set_t) fd_sets[3],
1134 for (i = 1; i <= 3; i++) {
1137 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1139 for (offset = 0; offset < growsize; offset += masksize) {
1140 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1141 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1143 Safefree(fd_sets[i]);
1150 if (GIMME == G_ARRAY && tbuf) {
1151 value = (NV)(timebuf.tv_sec) +
1152 (NV)(timebuf.tv_usec) / 1000000.0;
1153 PUSHs(sv_2mortal(newSVnv(value)));
1157 DIE(aTHX_ "select not implemented");
1162 Perl_setdefout(pTHX_ GV *gv)
1165 SvREFCNT_inc_simple_void(gv);
1167 SvREFCNT_dec(PL_defoutgv);
1175 GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : NULL;
1176 GV * egv = GvEGV(PL_defoutgv);
1182 XPUSHs(&PL_sv_undef);
1184 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1185 if (gvp && *gvp == egv) {
1186 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1190 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1195 if (!GvIO(newdefout))
1196 gv_IOadd(newdefout);
1197 setdefout(newdefout);
1207 GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs;
1209 if (gv && (io = GvIO(gv))) {
1210 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1212 const I32 gimme = GIMME_V;
1214 XPUSHs(SvTIED_obj((SV*)io, mg));
1217 call_method("GETC", gimme);
1220 if (gimme == G_SCALAR)
1221 SvSetMagicSV_nosteal(TARG, TOPs);
1225 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1226 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1227 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1228 report_evil_fh(gv, io, PL_op->op_type);
1229 SETERRNO(EBADF,RMS_IFI);
1233 sv_setpvn(TARG, " ", 1);
1234 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1235 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1236 /* Find out how many bytes the char needs */
1237 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1240 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1241 SvCUR_set(TARG,1+len);
1250 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1253 register PERL_CONTEXT *cx;
1254 const I32 gimme = GIMME_V;
1259 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1261 cx->blk_sub.retop = retop;
1263 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1265 setdefout(gv); /* locally select filehandle so $% et al work */
1297 goto not_a_format_reference;
1302 tmpsv = sv_newmortal();
1303 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1304 name = SvPV_nolen_const(tmpsv);
1306 DIE(aTHX_ "Undefined format \"%s\" called", name);
1308 not_a_format_reference:
1309 DIE(aTHX_ "Not a format reference");
1312 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1314 IoFLAGS(io) &= ~IOf_DIDTOP;
1315 return doform(cv,gv,PL_op->op_next);
1321 GV * const gv = cxstack[cxstack_ix].blk_sub.gv;
1322 register IO * const io = GvIOp(gv);
1327 register PERL_CONTEXT *cx;
1329 if (!io || !(ofp = IoOFP(io)))
1332 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1333 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1335 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1336 PL_formtarget != PL_toptarget)
1340 if (!IoTOP_GV(io)) {
1343 if (!IoTOP_NAME(io)) {
1345 if (!IoFMT_NAME(io))
1346 IoFMT_NAME(io) = savepv(GvNAME(gv));
1347 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1348 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1349 if ((topgv && GvFORM(topgv)) ||
1350 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1351 IoTOP_NAME(io) = savesvpv(topname);
1353 IoTOP_NAME(io) = savepvs("top");
1355 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1356 if (!topgv || !GvFORM(topgv)) {
1357 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1360 IoTOP_GV(io) = topgv;
1362 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1363 I32 lines = IoLINES_LEFT(io);
1364 const char *s = SvPVX_const(PL_formtarget);
1365 if (lines <= 0) /* Yow, header didn't even fit!!! */
1367 while (lines-- > 0) {
1368 s = strchr(s, '\n');
1374 const STRLEN save = SvCUR(PL_formtarget);
1375 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1376 do_print(PL_formtarget, ofp);
1377 SvCUR_set(PL_formtarget, save);
1378 sv_chop(PL_formtarget, s);
1379 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1382 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1383 do_print(PL_formfeed, ofp);
1384 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1386 PL_formtarget = PL_toptarget;
1387 IoFLAGS(io) |= IOf_DIDTOP;
1390 DIE(aTHX_ "bad top format reference");
1393 SV * const sv = sv_newmortal();
1395 gv_efullname4(sv, fgv, NULL, FALSE);
1396 name = SvPV_nolen_const(sv);
1398 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1400 DIE(aTHX_ "Undefined top format called");
1402 if (cv && CvCLONE(cv))
1403 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1404 return doform(cv, gv, PL_op);
1408 POPBLOCK(cx,PL_curpm);
1414 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1416 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1417 else if (ckWARN(WARN_CLOSED))
1418 report_evil_fh(gv, io, PL_op->op_type);
1423 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1424 if (ckWARN(WARN_IO))
1425 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1427 if (!do_print(PL_formtarget, fp))
1430 FmLINES(PL_formtarget) = 0;
1431 SvCUR_set(PL_formtarget, 0);
1432 *SvEND(PL_formtarget) = '\0';
1433 if (IoFLAGS(io) & IOf_FLUSH)
1434 (void)PerlIO_flush(fp);
1439 PL_formtarget = PL_bodytarget;
1441 PERL_UNUSED_VAR(newsp);
1442 PERL_UNUSED_VAR(gimme);
1443 return cx->blk_sub.retop;
1448 dVAR; dSP; dMARK; dORIGMARK;
1453 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
1455 if (gv && (io = GvIO(gv))) {
1456 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1458 if (MARK == ORIGMARK) {
1461 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1465 *MARK = SvTIED_obj((SV*)io, mg);
1468 call_method("PRINTF", G_SCALAR);
1471 MARK = ORIGMARK + 1;
1479 if (!(io = GvIO(gv))) {
1480 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1481 report_evil_fh(gv, io, PL_op->op_type);
1482 SETERRNO(EBADF,RMS_IFI);
1485 else if (!(fp = IoOFP(io))) {
1486 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1488 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1489 else if (ckWARN(WARN_CLOSED))
1490 report_evil_fh(gv, io, PL_op->op_type);
1492 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1496 if (SvTAINTED(MARK[1]))
1497 TAINT_PROPER("printf");
1498 do_sprintf(sv, SP - MARK, MARK + 1);
1499 if (!do_print(sv, fp))
1502 if (IoFLAGS(io) & IOf_FLUSH)
1503 if (PerlIO_flush(fp) == EOF)
1514 PUSHs(&PL_sv_undef);
1522 const int perm = (MAXARG > 3) ? POPi : 0666;
1523 const int mode = POPi;
1524 SV * const sv = POPs;
1525 GV * const gv = (GV *)POPs;
1528 /* Need TIEHANDLE method ? */
1529 const char * const tmps = SvPV_const(sv, len);
1530 /* FIXME? do_open should do const */
1531 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1532 IoLINES(GvIOp(gv)) = 0;
1536 PUSHs(&PL_sv_undef);
1543 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1549 Sock_size_t bufsize;
1557 bool charstart = FALSE;
1558 STRLEN charskip = 0;
1561 GV * const gv = (GV*)*++MARK;
1562 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1563 && gv && (io = GvIO(gv)) )
1565 const MAGIC * mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1569 *MARK = SvTIED_obj((SV*)io, mg);
1571 call_method("READ", G_SCALAR);
1585 sv_setpvn(bufsv, "", 0);
1586 length = SvIVx(*++MARK);
1589 offset = SvIVx(*++MARK);
1593 if (!io || !IoIFP(io)) {
1594 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1595 report_evil_fh(gv, io, PL_op->op_type);
1596 SETERRNO(EBADF,RMS_IFI);
1599 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1600 buffer = SvPVutf8_force(bufsv, blen);
1601 /* UTF-8 may not have been set if they are all low bytes */
1606 buffer = SvPV_force(bufsv, blen);
1607 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1610 DIE(aTHX_ "Negative length");
1618 if (PL_op->op_type == OP_RECV) {
1619 char namebuf[MAXPATHLEN];
1620 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1621 bufsize = sizeof (struct sockaddr_in);
1623 bufsize = sizeof namebuf;
1625 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1629 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1630 /* 'offset' means 'flags' here */
1631 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1632 (struct sockaddr *)namebuf, &bufsize);
1636 /* Bogus return without padding */
1637 bufsize = sizeof (struct sockaddr_in);
1639 SvCUR_set(bufsv, count);
1640 *SvEND(bufsv) = '\0';
1641 (void)SvPOK_only(bufsv);
1645 /* This should not be marked tainted if the fp is marked clean */
1646 if (!(IoFLAGS(io) & IOf_UNTAINT))
1647 SvTAINTED_on(bufsv);
1649 sv_setpvn(TARG, namebuf, bufsize);
1654 if (PL_op->op_type == OP_RECV)
1655 DIE(aTHX_ PL_no_sock_func, "recv");
1657 if (DO_UTF8(bufsv)) {
1658 /* offset adjust in characters not bytes */
1659 blen = sv_len_utf8(bufsv);
1662 if (-offset > (int)blen)
1663 DIE(aTHX_ "Offset outside string");
1666 if (DO_UTF8(bufsv)) {
1667 /* convert offset-as-chars to offset-as-bytes */
1668 if (offset >= (int)blen)
1669 offset += SvCUR(bufsv) - blen;
1671 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1674 bufsize = SvCUR(bufsv);
1675 /* Allocating length + offset + 1 isn't perfect in the case of reading
1676 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1678 (should be 2 * length + offset + 1, or possibly something longer if
1679 PL_encoding is true) */
1680 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1681 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1682 Zero(buffer+bufsize, offset-bufsize, char);
1684 buffer = buffer + offset;
1686 read_target = bufsv;
1688 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1689 concatenate it to the current buffer. */
1691 /* Truncate the existing buffer to the start of where we will be
1693 SvCUR_set(bufsv, offset);
1695 read_target = sv_newmortal();
1696 SvUPGRADE(read_target, SVt_PV);
1697 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1700 if (PL_op->op_type == OP_SYSREAD) {
1701 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1702 if (IoTYPE(io) == IoTYPE_SOCKET) {
1703 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1709 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1714 #ifdef HAS_SOCKET__bad_code_maybe
1715 if (IoTYPE(io) == IoTYPE_SOCKET) {
1716 char namebuf[MAXPATHLEN];
1717 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1718 bufsize = sizeof (struct sockaddr_in);
1720 bufsize = sizeof namebuf;
1722 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1723 (struct sockaddr *)namebuf, &bufsize);
1728 count = PerlIO_read(IoIFP(io), buffer, length);
1729 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1730 if (count == 0 && PerlIO_error(IoIFP(io)))
1734 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1735 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1738 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1739 *SvEND(read_target) = '\0';
1740 (void)SvPOK_only(read_target);
1741 if (fp_utf8 && !IN_BYTES) {
1742 /* Look at utf8 we got back and count the characters */
1743 const char *bend = buffer + count;
1744 while (buffer < bend) {
1746 skip = UTF8SKIP(buffer);
1749 if (buffer - charskip + skip > bend) {
1750 /* partial character - try for rest of it */
1751 length = skip - (bend-buffer);
1752 offset = bend - SvPVX_const(bufsv);
1764 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1765 provided amount read (count) was what was requested (length)
1767 if (got < wanted && count == length) {
1768 length = wanted - got;
1769 offset = bend - SvPVX_const(bufsv);
1772 /* return value is character count */
1776 else if (buffer_utf8) {
1777 /* Let svcatsv upgrade the bytes we read in to utf8.
1778 The buffer is a mortal so will be freed soon. */
1779 sv_catsv_nomg(bufsv, read_target);
1782 /* This should not be marked tainted if the fp is marked clean */
1783 if (!(IoFLAGS(io) & IOf_UNTAINT))
1784 SvTAINTED_on(bufsv);
1796 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1802 STRLEN orig_blen_bytes;
1803 const int op_type = PL_op->op_type;
1807 GV *const gv = (GV*)*++MARK;
1808 if (PL_op->op_type == OP_SYSWRITE
1809 && gv && (io = GvIO(gv))) {
1810 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1814 if (MARK == SP - 1) {
1816 sv = sv_2mortal(newSViv(sv_len(*SP)));
1822 *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg);
1824 call_method("WRITE", G_SCALAR);
1840 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1842 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1843 if (io && IoIFP(io))
1844 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1846 report_evil_fh(gv, io, PL_op->op_type);
1848 SETERRNO(EBADF,RMS_IFI);
1852 /* Do this first to trigger any overloading. */
1853 buffer = SvPV_const(bufsv, blen);
1854 orig_blen_bytes = blen;
1855 doing_utf8 = DO_UTF8(bufsv);
1857 if (PerlIO_isutf8(IoIFP(io))) {
1858 if (!SvUTF8(bufsv)) {
1859 /* We don't modify the original scalar. */
1860 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1861 buffer = (char *) tmpbuf;
1865 else if (doing_utf8) {
1866 STRLEN tmplen = blen;
1867 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1870 buffer = (char *) tmpbuf;
1874 assert((char *)result == buffer);
1875 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1879 if (op_type == OP_SYSWRITE) {
1880 Size_t length = 0; /* This length is in characters. */
1886 /* The SV is bytes, and we've had to upgrade it. */
1887 blen_chars = orig_blen_bytes;
1889 /* The SV really is UTF-8. */
1890 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1891 /* Don't call sv_len_utf8 again because it will call magic
1892 or overloading a second time, and we might get back a
1893 different result. */
1894 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1896 /* It's safe, and it may well be cached. */
1897 blen_chars = sv_len_utf8(bufsv);
1905 length = blen_chars;
1907 #if Size_t_size > IVSIZE
1908 length = (Size_t)SvNVx(*++MARK);
1910 length = (Size_t)SvIVx(*++MARK);
1912 if ((SSize_t)length < 0) {
1914 DIE(aTHX_ "Negative length");
1919 offset = SvIVx(*++MARK);
1921 if (-offset > (IV)blen_chars) {
1923 DIE(aTHX_ "Offset outside string");
1925 offset += blen_chars;
1926 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1928 DIE(aTHX_ "Offset outside string");
1932 if (length > blen_chars - offset)
1933 length = blen_chars - offset;
1935 /* Here we convert length from characters to bytes. */
1936 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1937 /* Either we had to convert the SV, or the SV is magical, or
1938 the SV has overloading, in which case we can't or mustn't
1939 or mustn't call it again. */
1941 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1942 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1944 /* It's a real UTF-8 SV, and it's not going to change under
1945 us. Take advantage of any cache. */
1947 I32 len_I32 = length;
1949 /* Convert the start and end character positions to bytes.
1950 Remember that the second argument to sv_pos_u2b is relative
1952 sv_pos_u2b(bufsv, &start, &len_I32);
1959 buffer = buffer+offset;
1961 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1962 if (IoTYPE(io) == IoTYPE_SOCKET) {
1963 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1969 /* See the note at doio.c:do_print about filesize limits. --jhi */
1970 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1976 const int flags = SvIVx(*++MARK);
1979 char * const sockbuf = SvPVx(*++MARK, mlen);
1980 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1981 flags, (struct sockaddr *)sockbuf, mlen);
1985 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1990 DIE(aTHX_ PL_no_sock_func, "send");
1997 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2000 #if Size_t_size > IVSIZE
2019 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
2021 gv = PL_last_in_gv = GvEGV(PL_argvgv);
2023 if (io && !IoIFP(io)) {
2024 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2026 IoFLAGS(io) &= ~IOf_START;
2027 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2028 sv_setpvn(GvSV(gv), "-", 1);
2029 SvSETMAGIC(GvSV(gv));
2031 else if (!nextargv(gv))
2036 gv = PL_last_in_gv; /* eof */
2039 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
2042 IO * const io = GvIO(gv);
2044 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
2046 XPUSHs(SvTIED_obj((SV*)io, mg));
2049 call_method("EOF", G_SCALAR);
2056 PUSHs(boolSV(!gv || do_eof(gv)));
2067 PL_last_in_gv = (GV*)POPs;
2070 if (gv && (io = GvIO(gv))) {
2071 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2074 XPUSHs(SvTIED_obj((SV*)io, mg));
2077 call_method("TELL", G_SCALAR);
2084 #if LSEEKSIZE > IVSIZE
2085 PUSHn( do_tell(gv) );
2087 PUSHi( do_tell(gv) );
2095 const int whence = POPi;
2096 #if LSEEKSIZE > IVSIZE
2097 const Off_t offset = (Off_t)SvNVx(POPs);
2099 const Off_t offset = (Off_t)SvIVx(POPs);
2102 GV * const gv = PL_last_in_gv = (GV*)POPs;
2105 if (gv && (io = GvIO(gv))) {
2106 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2109 XPUSHs(SvTIED_obj((SV*)io, mg));
2110 #if LSEEKSIZE > IVSIZE
2111 XPUSHs(sv_2mortal(newSVnv((NV) offset)));
2113 XPUSHs(sv_2mortal(newSViv(offset)));
2115 XPUSHs(sv_2mortal(newSViv(whence)));
2118 call_method("SEEK", G_SCALAR);
2125 if (PL_op->op_type == OP_SEEK)
2126 PUSHs(boolSV(do_seek(gv, offset, whence)));
2128 const Off_t sought = do_sysseek(gv, offset, whence);
2130 PUSHs(&PL_sv_undef);
2132 SV* const sv = sought ?
2133 #if LSEEKSIZE > IVSIZE
2138 : newSVpvn(zero_but_true, ZBTLEN);
2139 PUSHs(sv_2mortal(sv));
2149 /* There seems to be no consensus on the length type of truncate()
2150 * and ftruncate(), both off_t and size_t have supporters. In
2151 * general one would think that when using large files, off_t is
2152 * at least as wide as size_t, so using an off_t should be okay. */
2153 /* XXX Configure probe for the length type of *truncate() needed XXX */
2156 #if Off_t_size > IVSIZE
2161 /* Checking for length < 0 is problematic as the type might or
2162 * might not be signed: if it is not, clever compilers will moan. */
2163 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2170 if (PL_op->op_flags & OPf_SPECIAL) {
2171 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2180 TAINT_PROPER("truncate");
2181 if (!(fp = IoIFP(io))) {
2187 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2189 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2196 SV * const sv = POPs;
2199 if (SvTYPE(sv) == SVt_PVGV) {
2200 tmpgv = (GV*)sv; /* *main::FRED for example */
2201 goto do_ftruncate_gv;
2203 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2204 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
2205 goto do_ftruncate_gv;
2207 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2208 io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
2209 goto do_ftruncate_io;
2212 name = SvPV_nolen_const(sv);
2213 TAINT_PROPER("truncate");
2215 if (truncate(name, len) < 0)
2219 const int tmpfd = PerlLIO_open(name, O_RDWR);
2224 if (my_chsize(tmpfd, len) < 0)
2226 PerlLIO_close(tmpfd);
2235 SETERRNO(EBADF,RMS_IFI);
2243 SV * const argsv = POPs;
2244 const unsigned int func = POPu;
2245 const int optype = PL_op->op_type;
2246 GV * const gv = (GV*)POPs;
2247 IO * const io = gv ? GvIOn(gv) : NULL;
2251 if (!io || !argsv || !IoIFP(io)) {
2252 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2253 report_evil_fh(gv, io, PL_op->op_type);
2254 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2258 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2261 s = SvPV_force(argsv, len);
2262 need = IOCPARM_LEN(func);
2264 s = Sv_Grow(argsv, need + 1);
2265 SvCUR_set(argsv, need);
2268 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2271 retval = SvIV(argsv);
2272 s = INT2PTR(char*,retval); /* ouch */
2275 TAINT_PROPER(PL_op_desc[optype]);
2277 if (optype == OP_IOCTL)
2279 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2281 DIE(aTHX_ "ioctl is not implemented");
2285 DIE(aTHX_ "fcntl is not implemented");
2287 #if defined(OS2) && defined(__EMX__)
2288 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2290 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2294 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2296 if (s[SvCUR(argsv)] != 17)
2297 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2299 s[SvCUR(argsv)] = 0; /* put our null back */
2300 SvSETMAGIC(argsv); /* Assume it has changed */
2309 PUSHp(zero_but_true, ZBTLEN);
2322 const int argtype = POPi;
2323 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
2325 if (gv && (io = GvIO(gv)))
2331 /* XXX Looks to me like io is always NULL at this point */
2333 (void)PerlIO_flush(fp);
2334 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2337 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2338 report_evil_fh(gv, io, PL_op->op_type);
2340 SETERRNO(EBADF,RMS_IFI);
2345 DIE(aTHX_ PL_no_func, "flock()");
2355 const int protocol = POPi;
2356 const int type = POPi;
2357 const int domain = POPi;
2358 GV * const gv = (GV*)POPs;
2359 register IO * const io = gv ? GvIOn(gv) : NULL;
2363 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2364 report_evil_fh(gv, io, PL_op->op_type);
2365 if (io && IoIFP(io))
2366 do_close(gv, FALSE);
2367 SETERRNO(EBADF,LIB_INVARG);
2372 do_close(gv, FALSE);
2374 TAINT_PROPER("socket");
2375 fd = PerlSock_socket(domain, type, protocol);
2378 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2379 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2380 IoTYPE(io) = IoTYPE_SOCKET;
2381 if (!IoIFP(io) || !IoOFP(io)) {
2382 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2383 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2384 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2387 #if defined(HAS_FCNTL) && defined(F_SETFD)
2388 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2392 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2397 DIE(aTHX_ PL_no_sock_func, "socket");
2403 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2405 const int protocol = POPi;
2406 const int type = POPi;
2407 const int domain = POPi;
2408 GV * const gv2 = (GV*)POPs;
2409 GV * const gv1 = (GV*)POPs;
2410 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2411 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2414 if (!gv1 || !gv2 || !io1 || !io2) {
2415 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2417 report_evil_fh(gv1, io1, PL_op->op_type);
2419 report_evil_fh(gv1, io2, PL_op->op_type);
2421 if (io1 && IoIFP(io1))
2422 do_close(gv1, FALSE);
2423 if (io2 && IoIFP(io2))
2424 do_close(gv2, FALSE);
2429 do_close(gv1, FALSE);
2431 do_close(gv2, FALSE);
2433 TAINT_PROPER("socketpair");
2434 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2436 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2437 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2438 IoTYPE(io1) = IoTYPE_SOCKET;
2439 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2440 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2441 IoTYPE(io2) = IoTYPE_SOCKET;
2442 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2443 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2444 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2445 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2446 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2447 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2448 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2451 #if defined(HAS_FCNTL) && defined(F_SETFD)
2452 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2453 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2458 DIE(aTHX_ PL_no_sock_func, "socketpair");
2466 SV * const addrsv = POPs;
2467 /* OK, so on what platform does bind modify addr? */
2469 GV * const gv = (GV*)POPs;
2470 register IO * const io = GvIOn(gv);
2473 if (!io || !IoIFP(io))
2476 addr = SvPV_const(addrsv, len);
2477 TAINT_PROPER("bind");
2478 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2484 if (ckWARN(WARN_CLOSED))
2485 report_evil_fh(gv, io, PL_op->op_type);
2486 SETERRNO(EBADF,SS_IVCHAN);
2489 DIE(aTHX_ PL_no_sock_func, "bind");
2497 SV * const addrsv = POPs;
2498 GV * const gv = (GV*)POPs;
2499 register IO * const io = GvIOn(gv);
2503 if (!io || !IoIFP(io))
2506 addr = SvPV_const(addrsv, len);
2507 TAINT_PROPER("connect");
2508 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2514 if (ckWARN(WARN_CLOSED))
2515 report_evil_fh(gv, io, PL_op->op_type);
2516 SETERRNO(EBADF,SS_IVCHAN);
2519 DIE(aTHX_ PL_no_sock_func, "connect");
2527 const int backlog = POPi;
2528 GV * const gv = (GV*)POPs;
2529 register IO * const io = gv ? GvIOn(gv) : NULL;
2531 if (!gv || !io || !IoIFP(io))
2534 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2540 if (ckWARN(WARN_CLOSED))
2541 report_evil_fh(gv, io, PL_op->op_type);
2542 SETERRNO(EBADF,SS_IVCHAN);
2545 DIE(aTHX_ PL_no_sock_func, "listen");
2555 char namebuf[MAXPATHLEN];
2556 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2557 Sock_size_t len = sizeof (struct sockaddr_in);
2559 Sock_size_t len = sizeof namebuf;
2561 GV * const ggv = (GV*)POPs;
2562 GV * const ngv = (GV*)POPs;
2571 if (!gstio || !IoIFP(gstio))
2575 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2578 /* Some platforms indicate zero length when an AF_UNIX client is
2579 * not bound. Simulate a non-zero-length sockaddr structure in
2581 namebuf[0] = 0; /* sun_len */
2582 namebuf[1] = AF_UNIX; /* sun_family */
2590 do_close(ngv, FALSE);
2591 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2592 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2593 IoTYPE(nstio) = IoTYPE_SOCKET;
2594 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2595 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2596 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2597 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2600 #if defined(HAS_FCNTL) && defined(F_SETFD)
2601 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2605 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2606 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2608 #ifdef __SCO_VERSION__
2609 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2612 PUSHp(namebuf, len);
2616 if (ckWARN(WARN_CLOSED))
2617 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2618 SETERRNO(EBADF,SS_IVCHAN);
2624 DIE(aTHX_ PL_no_sock_func, "accept");
2632 const int how = POPi;
2633 GV * const gv = (GV*)POPs;
2634 register IO * const io = GvIOn(gv);
2636 if (!io || !IoIFP(io))
2639 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2643 if (ckWARN(WARN_CLOSED))
2644 report_evil_fh(gv, io, PL_op->op_type);
2645 SETERRNO(EBADF,SS_IVCHAN);
2648 DIE(aTHX_ PL_no_sock_func, "shutdown");
2656 const int optype = PL_op->op_type;
2657 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2658 const unsigned int optname = (unsigned int) POPi;
2659 const unsigned int lvl = (unsigned int) POPi;
2660 GV * const gv = (GV*)POPs;
2661 register IO * const io = GvIOn(gv);
2665 if (!io || !IoIFP(io))
2668 fd = PerlIO_fileno(IoIFP(io));
2672 (void)SvPOK_only(sv);
2676 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2683 #if defined(__SYMBIAN32__)
2684 # define SETSOCKOPT_OPTION_VALUE_T void *
2686 # define SETSOCKOPT_OPTION_VALUE_T const char *
2688 /* XXX TODO: We need to have a proper type (a Configure probe,
2689 * etc.) for what the C headers think of the third argument of
2690 * setsockopt(), the option_value read-only buffer: is it
2691 * a "char *", or a "void *", const or not. Some compilers
2692 * don't take kindly to e.g. assuming that "char *" implicitly
2693 * promotes to a "void *", or to explicitly promoting/demoting
2694 * consts to non/vice versa. The "const void *" is the SUS
2695 * definition, but that does not fly everywhere for the above
2697 SETSOCKOPT_OPTION_VALUE_T buf;
2701 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2705 aint = (int)SvIV(sv);
2706 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2709 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2718 if (ckWARN(WARN_CLOSED))
2719 report_evil_fh(gv, io, optype);
2720 SETERRNO(EBADF,SS_IVCHAN);
2725 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2733 const int optype = PL_op->op_type;
2734 GV * const gv = (GV*)POPs;
2735 register IO * const io = GvIOn(gv);
2740 if (!io || !IoIFP(io))
2743 sv = sv_2mortal(newSV(257));
2744 (void)SvPOK_only(sv);
2748 fd = PerlIO_fileno(IoIFP(io));
2750 case OP_GETSOCKNAME:
2751 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2754 case OP_GETPEERNAME:
2755 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2757 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2759 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";
2760 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2761 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2762 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2763 sizeof(u_short) + sizeof(struct in_addr))) {
2770 #ifdef BOGUS_GETNAME_RETURN
2771 /* Interactive Unix, getpeername() and getsockname()
2772 does not return valid namelen */
2773 if (len == BOGUS_GETNAME_RETURN)
2774 len = sizeof(struct sockaddr);
2782 if (ckWARN(WARN_CLOSED))
2783 report_evil_fh(gv, io, optype);
2784 SETERRNO(EBADF,SS_IVCHAN);
2789 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2804 if (PL_op->op_flags & OPf_REF) {
2806 if (PL_op->op_type == OP_LSTAT) {
2807 if (gv != PL_defgv) {
2808 do_fstat_warning_check:
2809 if (ckWARN(WARN_IO))
2810 Perl_warner(aTHX_ packWARN(WARN_IO),
2811 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2812 } else if (PL_laststype != OP_LSTAT)
2813 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2817 if (gv != PL_defgv) {
2818 PL_laststype = OP_STAT;
2820 sv_setpvn(PL_statname, "", 0);
2827 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2828 } else if (IoDIRP(io)) {
2830 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2832 PL_laststatval = -1;
2838 if (PL_laststatval < 0) {
2839 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2840 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2845 SV* const sv = POPs;
2846 if (SvTYPE(sv) == SVt_PVGV) {
2849 } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2851 if (PL_op->op_type == OP_LSTAT)
2852 goto do_fstat_warning_check;
2854 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2856 if (PL_op->op_type == OP_LSTAT)
2857 goto do_fstat_warning_check;
2858 goto do_fstat_have_io;
2861 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2863 PL_laststype = PL_op->op_type;
2864 if (PL_op->op_type == OP_LSTAT)
2865 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2867 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2868 if (PL_laststatval < 0) {
2869 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2870 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2876 if (gimme != G_ARRAY) {
2877 if (gimme != G_VOID)
2878 XPUSHs(boolSV(max));
2884 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2885 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2886 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2887 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2888 #if Uid_t_size > IVSIZE
2889 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2891 # if Uid_t_sign <= 0
2892 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2894 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2897 #if Gid_t_size > IVSIZE
2898 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2900 # if Gid_t_sign <= 0
2901 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2903 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2906 #ifdef USE_STAT_RDEV
2907 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2909 PUSHs(sv_2mortal(newSVpvs("")));
2911 #if Off_t_size > IVSIZE
2912 PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
2914 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2917 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2918 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2919 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2921 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_atime)));
2922 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_mtime)));
2923 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_ctime)));
2925 #ifdef USE_STAT_BLOCKS
2926 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2927 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2929 PUSHs(sv_2mortal(newSVpvs("")));
2930 PUSHs(sv_2mortal(newSVpvs("")));
2936 /* This macro is used by the stacked filetest operators :
2937 * if the previous filetest failed, short-circuit and pass its value.
2938 * Else, discard it from the stack and continue. --rgs
2940 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2941 if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
2942 else { (void)POPs; PUTBACK; } \
2949 /* Not const, because things tweak this below. Not bool, because there's
2950 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2951 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2952 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2953 /* Giving some sort of initial value silences compilers. */
2955 int access_mode = R_OK;
2957 int access_mode = 0;
2960 /* access_mode is never used, but leaving use_access in makes the
2961 conditional compiling below much clearer. */
2964 int stat_mode = S_IRUSR;
2966 bool effective = FALSE;
2969 STACKED_FTEST_CHECK;
2971 switch (PL_op->op_type) {
2973 #if !(defined(HAS_ACCESS) && defined(R_OK))
2979 #if defined(HAS_ACCESS) && defined(W_OK)
2984 stat_mode = S_IWUSR;
2988 #if defined(HAS_ACCESS) && defined(X_OK)
2993 stat_mode = S_IXUSR;
2997 #ifdef PERL_EFF_ACCESS
3000 stat_mode = S_IWUSR;
3004 #ifndef PERL_EFF_ACCESS
3012 #ifdef PERL_EFF_ACCESS
3017 stat_mode = S_IXUSR;
3023 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3024 const char *name = POPpx;
3026 # ifdef PERL_EFF_ACCESS
3027 result = PERL_EFF_ACCESS(name, access_mode);
3029 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3035 result = access(name, access_mode);
3037 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3052 if (cando(stat_mode, effective, &PL_statcache))
3061 const int op_type = PL_op->op_type;
3063 STACKED_FTEST_CHECK;
3068 if (op_type == OP_FTIS)
3071 /* You can't dTARGET inside OP_FTIS, because you'll get
3072 "panic: pad_sv po" - the op is not flagged to have a target. */
3076 #if Off_t_size > IVSIZE
3077 PUSHn(PL_statcache.st_size);
3079 PUSHi(PL_statcache.st_size);
3083 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3086 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3089 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3102 /* I believe that all these three are likely to be defined on most every
3103 system these days. */
3105 if(PL_op->op_type == OP_FTSUID)
3109 if(PL_op->op_type == OP_FTSGID)
3113 if(PL_op->op_type == OP_FTSVTX)
3117 STACKED_FTEST_CHECK;
3122 switch (PL_op->op_type) {
3124 if (PL_statcache.st_uid == PL_uid)
3128 if (PL_statcache.st_uid == PL_euid)
3132 if (PL_statcache.st_size == 0)
3136 if (S_ISSOCK(PL_statcache.st_mode))
3140 if (S_ISCHR(PL_statcache.st_mode))
3144 if (S_ISBLK(PL_statcache.st_mode))
3148 if (S_ISREG(PL_statcache.st_mode))
3152 if (S_ISDIR(PL_statcache.st_mode))
3156 if (S_ISFIFO(PL_statcache.st_mode))
3161 if (PL_statcache.st_mode & S_ISUID)
3167 if (PL_statcache.st_mode & S_ISGID)
3173 if (PL_statcache.st_mode & S_ISVTX)
3184 I32 result = my_lstat();
3188 if (S_ISLNK(PL_statcache.st_mode))
3201 STACKED_FTEST_CHECK;
3203 if (PL_op->op_flags & OPf_REF)
3205 else if (isGV(TOPs))
3207 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3208 gv = (GV*)SvRV(POPs);
3210 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3212 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3213 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3214 else if (tmpsv && SvOK(tmpsv)) {
3215 const char *tmps = SvPV_nolen_const(tmpsv);
3223 if (PerlLIO_isatty(fd))
3228 #if defined(atarist) /* this will work with atariST. Configure will
3229 make guesses for other systems. */
3230 # define FILE_base(f) ((f)->_base)
3231 # define FILE_ptr(f) ((f)->_ptr)
3232 # define FILE_cnt(f) ((f)->_cnt)
3233 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3244 register STDCHAR *s;
3250 STACKED_FTEST_CHECK;
3252 if (PL_op->op_flags & OPf_REF)
3254 else if (isGV(TOPs))
3256 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3257 gv = (GV*)SvRV(POPs);
3263 if (gv == PL_defgv) {
3265 io = GvIO(PL_statgv);
3268 goto really_filename;
3273 PL_laststatval = -1;
3274 sv_setpvn(PL_statname, "", 0);
3275 io = GvIO(PL_statgv);
3277 if (io && IoIFP(io)) {
3278 if (! PerlIO_has_base(IoIFP(io)))
3279 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3281 if (PL_laststatval < 0)
3283 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3284 if (PL_op->op_type == OP_FTTEXT)
3289 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3290 i = PerlIO_getc(IoIFP(io));
3292 (void)PerlIO_ungetc(IoIFP(io),i);
3294 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3296 len = PerlIO_get_bufsiz(IoIFP(io));
3297 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3298 /* sfio can have large buffers - limit to 512 */
3303 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3305 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3307 SETERRNO(EBADF,RMS_IFI);
3315 PL_laststype = OP_STAT;
3316 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3317 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3318 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3320 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3323 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3324 if (PL_laststatval < 0) {
3325 (void)PerlIO_close(fp);
3328 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3329 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3330 (void)PerlIO_close(fp);
3332 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3333 RETPUSHNO; /* special case NFS directories */
3334 RETPUSHYES; /* null file is anything */
3339 /* now scan s to look for textiness */
3340 /* XXX ASCII dependent code */
3342 #if defined(DOSISH) || defined(USEMYBINMODE)
3343 /* ignore trailing ^Z on short files */
3344 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3348 for (i = 0; i < len; i++, s++) {
3349 if (!*s) { /* null never allowed in text */
3354 else if (!(isPRINT(*s) || isSPACE(*s)))
3357 else if (*s & 128) {
3359 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3362 /* utf8 characters don't count as odd */
3363 if (UTF8_IS_START(*s)) {
3364 int ulen = UTF8SKIP(s);
3365 if (ulen < len - i) {
3367 for (j = 1; j < ulen; j++) {
3368 if (!UTF8_IS_CONTINUATION(s[j]))
3371 --ulen; /* loop does extra increment */
3381 *s != '\n' && *s != '\r' && *s != '\b' &&
3382 *s != '\t' && *s != '\f' && *s != 27)
3387 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3398 const char *tmps = NULL;
3402 SV * const sv = POPs;
3403 if (PL_op->op_flags & OPf_SPECIAL) {
3404 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3406 else if (SvTYPE(sv) == SVt_PVGV) {
3409 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
3413 tmps = SvPV_nolen_const(sv);
3417 if( !gv && (!tmps || !*tmps) ) {
3418 HV * const table = GvHVn(PL_envgv);
3421 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3422 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3424 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3429 deprecate("chdir('') or chdir(undef) as chdir()");
3430 tmps = SvPV_nolen_const(*svp);
3434 TAINT_PROPER("chdir");
3439 TAINT_PROPER("chdir");
3442 IO* const io = GvIO(gv);
3445 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3446 } else if (IoIFP(io)) {
3447 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3450 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3451 report_evil_fh(gv, io, PL_op->op_type);
3452 SETERRNO(EBADF, RMS_IFI);
3457 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3458 report_evil_fh(gv, io, PL_op->op_type);
3459 SETERRNO(EBADF,RMS_IFI);
3463 DIE(aTHX_ PL_no_func, "fchdir");
3467 PUSHi( PerlDir_chdir(tmps) >= 0 );
3469 /* Clear the DEFAULT element of ENV so we'll get the new value
3471 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3478 dVAR; dSP; dMARK; dTARGET;
3479 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3490 char * const tmps = POPpx;
3491 TAINT_PROPER("chroot");
3492 PUSHi( chroot(tmps) >= 0 );
3495 DIE(aTHX_ PL_no_func, "chroot");
3503 const char * const tmps2 = POPpconstx;
3504 const char * const tmps = SvPV_nolen_const(TOPs);
3505 TAINT_PROPER("rename");
3507 anum = PerlLIO_rename(tmps, tmps2);
3509 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3510 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3513 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3514 (void)UNLINK(tmps2);
3515 if (!(anum = link(tmps, tmps2)))
3516 anum = UNLINK(tmps);
3524 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3528 const int op_type = PL_op->op_type;
3532 if (op_type == OP_LINK)
3533 DIE(aTHX_ PL_no_func, "link");
3535 # ifndef HAS_SYMLINK
3536 if (op_type == OP_SYMLINK)
3537 DIE(aTHX_ PL_no_func, "symlink");
3541 const char * const tmps2 = POPpconstx;
3542 const char * const tmps = SvPV_nolen_const(TOPs);
3543 TAINT_PROPER(PL_op_desc[op_type]);
3545 # if defined(HAS_LINK)
3546 # if defined(HAS_SYMLINK)
3547 /* Both present - need to choose which. */
3548 (op_type == OP_LINK) ?
3549 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3551 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3552 PerlLIO_link(tmps, tmps2);
3555 # if defined(HAS_SYMLINK)
3556 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3557 symlink(tmps, tmps2);
3562 SETi( result >= 0 );
3569 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3580 char buf[MAXPATHLEN];
3583 #ifndef INCOMPLETE_TAINTS
3587 len = readlink(tmps, buf, sizeof(buf) - 1);
3595 RETSETUNDEF; /* just pretend it's a normal file */
3599 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3601 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3603 char * const save_filename = filename;
3608 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3610 Newx(cmdline, size, char);
3611 my_strlcpy(cmdline, cmd, size);
3612 my_strlcat(cmdline, " ", size);
3613 for (s = cmdline + strlen(cmdline); *filename; ) {
3617 if (s - cmdline < size)
3618 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3619 myfp = PerlProc_popen(cmdline, "r");
3623 SV * const tmpsv = sv_newmortal();
3624 /* Need to save/restore 'PL_rs' ?? */
3625 s = sv_gets(tmpsv, myfp, 0);
3626 (void)PerlProc_pclose(myfp);
3630 #ifdef HAS_SYS_ERRLIST
3635 /* you don't see this */
3636 const char * const errmsg =
3637 #ifdef HAS_SYS_ERRLIST
3645 if (instr(s, errmsg)) {
3652 #define EACCES EPERM
3654 if (instr(s, "cannot make"))
3655 SETERRNO(EEXIST,RMS_FEX);
3656 else if (instr(s, "existing file"))
3657 SETERRNO(EEXIST,RMS_FEX);
3658 else if (instr(s, "ile exists"))
3659 SETERRNO(EEXIST,RMS_FEX);
3660 else if (instr(s, "non-exist"))
3661 SETERRNO(ENOENT,RMS_FNF);
3662 else if (instr(s, "does not exist"))
3663 SETERRNO(ENOENT,RMS_FNF);
3664 else if (instr(s, "not empty"))
3665 SETERRNO(EBUSY,SS_DEVOFFLINE);
3666 else if (instr(s, "cannot access"))
3667 SETERRNO(EACCES,RMS_PRV);
3669 SETERRNO(EPERM,RMS_PRV);
3672 else { /* some mkdirs return no failure indication */
3673 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3674 if (PL_op->op_type == OP_RMDIR)
3679 SETERRNO(EACCES,RMS_PRV); /* a guess */
3688 /* This macro removes trailing slashes from a directory name.
3689 * Different operating and file systems take differently to
3690 * trailing slashes. According to POSIX 1003.1 1996 Edition
3691 * any number of trailing slashes should be allowed.
3692 * Thusly we snip them away so that even non-conforming
3693 * systems are happy.
3694 * We should probably do this "filtering" for all
3695 * the functions that expect (potentially) directory names:
3696 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3697 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3699 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3700 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3703 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3704 (tmps) = savepvn((tmps), (len)); \
3714 const int mode = (MAXARG > 1) ? POPi : 0777;
3716 TRIMSLASHES(tmps,len,copy);
3718 TAINT_PROPER("mkdir");
3720 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3724 SETi( dooneliner("mkdir", tmps) );
3725 oldumask = PerlLIO_umask(0);
3726 PerlLIO_umask(oldumask);
3727 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3742 TRIMSLASHES(tmps,len,copy);
3743 TAINT_PROPER("rmdir");
3745 SETi( PerlDir_rmdir(tmps) >= 0 );
3747 SETi( dooneliner("rmdir", tmps) );
3754 /* Directory calls. */
3758 #if defined(Direntry_t) && defined(HAS_READDIR)
3760 const char * const dirname = POPpconstx;
3761 GV * const gv = (GV*)POPs;
3762 register IO * const io = GvIOn(gv);
3767 if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED))
3768 Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3769 "Opening filehandle %s also as a directory", GvENAME(gv));
3771 PerlDir_close(IoDIRP(io));
3772 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3778 SETERRNO(EBADF,RMS_DIR);
3781 DIE(aTHX_ PL_no_dir_func, "opendir");
3787 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3788 DIE(aTHX_ PL_no_dir_func, "readdir");
3790 #if !defined(I_DIRENT) && !defined(VMS)
3791 Direntry_t *readdir (DIR *);
3797 const I32 gimme = GIMME;
3798 GV * const gv = (GV *)POPs;
3799 register const Direntry_t *dp;
3800 register IO * const io = GvIOn(gv);
3802 if (!io || !IoDIRP(io)) {
3803 if(ckWARN(WARN_IO)) {
3804 Perl_warner(aTHX_ packWARN(WARN_IO),
3805 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3811 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3815 sv = newSVpvn(dp->d_name, dp->d_namlen);
3817 sv = newSVpv(dp->d_name, 0);
3819 #ifndef INCOMPLETE_TAINTS
3820 if (!(IoFLAGS(io) & IOf_UNTAINT))
3823 XPUSHs(sv_2mortal(sv));
3824 } while (gimme == G_ARRAY);
3826 if (!dp && gimme != G_ARRAY)
3833 SETERRNO(EBADF,RMS_ISI);
3834 if (GIMME == G_ARRAY)
3843 #if defined(HAS_TELLDIR) || defined(telldir)
3845 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3846 /* XXX netbsd still seemed to.
3847 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3848 --JHI 1999-Feb-02 */
3849 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3850 long telldir (DIR *);
3852 GV * const gv = (GV*)POPs;
3853 register IO * const io = GvIOn(gv);
3855 if (!io || !IoDIRP(io)) {
3856 if(ckWARN(WARN_IO)) {
3857 Perl_warner(aTHX_ packWARN(WARN_IO),
3858 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3863 PUSHi( PerlDir_tell(IoDIRP(io)) );
3867 SETERRNO(EBADF,RMS_ISI);
3870 DIE(aTHX_ PL_no_dir_func, "telldir");
3876 #if defined(HAS_SEEKDIR) || defined(seekdir)
3878 const long along = POPl;
3879 GV * const gv = (GV*)POPs;
3880 register IO * const io = GvIOn(gv);
3882 if (!io || !IoDIRP(io)) {
3883 if(ckWARN(WARN_IO)) {
3884 Perl_warner(aTHX_ packWARN(WARN_IO),
3885 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3889 (void)PerlDir_seek(IoDIRP(io), along);
3894 SETERRNO(EBADF,RMS_ISI);
3897 DIE(aTHX_ PL_no_dir_func, "seekdir");
3903 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3905 GV * const gv = (GV*)POPs;
3906 register IO * const io = GvIOn(gv);
3908 if (!io || !IoDIRP(io)) {
3909 if(ckWARN(WARN_IO)) {
3910 Perl_warner(aTHX_ packWARN(WARN_IO),
3911 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3915 (void)PerlDir_rewind(IoDIRP(io));
3919 SETERRNO(EBADF,RMS_ISI);
3922 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3928 #if defined(Direntry_t) && defined(HAS_READDIR)
3930 GV * const gv = (GV*)POPs;
3931 register IO * const io = GvIOn(gv);
3933 if (!io || !IoDIRP(io)) {
3934 if(ckWARN(WARN_IO)) {
3935 Perl_warner(aTHX_ packWARN(WARN_IO),
3936 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3940 #ifdef VOID_CLOSEDIR
3941 PerlDir_close(IoDIRP(io));
3943 if (PerlDir_close(IoDIRP(io)) < 0) {
3944 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3953 SETERRNO(EBADF,RMS_IFI);
3956 DIE(aTHX_ PL_no_dir_func, "closedir");
3960 /* Process control. */
3969 PERL_FLUSHALL_FOR_CHILD;
3970 childpid = PerlProc_fork();
3974 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3976 SvREADONLY_off(GvSV(tmpgv));
3977 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3978 SvREADONLY_on(GvSV(tmpgv));
3980 #ifdef THREADS_HAVE_PIDS
3981 PL_ppid = (IV)getppid();
3983 #ifdef PERL_USES_PL_PIDSTATUS
3984 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3990 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3995 PERL_FLUSHALL_FOR_CHILD;
3996 childpid = PerlProc_fork();
4002 DIE(aTHX_ PL_no_func, "fork");
4009 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4014 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4015 childpid = wait4pid(-1, &argflags, 0);
4017 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4022 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4023 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4024 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4026 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4031 DIE(aTHX_ PL_no_func, "wait");
4037 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4039 const int optype = POPi;
4040 const Pid_t pid = TOPi;
4044 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4045 result = wait4pid(pid, &argflags, optype);
4047 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4052 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4053 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4054 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4056 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4061 DIE(aTHX_ PL_no_func, "waitpid");
4067 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4068 #if defined(__LIBCATAMOUNT__)
4069 PL_statusvalue = -1;
4078 while (++MARK <= SP) {
4079 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4084 TAINT_PROPER("system");
4086 PERL_FLUSHALL_FOR_CHILD;
4087 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4093 if (PerlProc_pipe(pp) >= 0)
4095 while ((childpid = PerlProc_fork()) == -1) {
4096 if (errno != EAGAIN) {
4101 PerlLIO_close(pp[0]);
4102 PerlLIO_close(pp[1]);
4109 Sigsave_t ihand,qhand; /* place to save signals during system() */
4113 PerlLIO_close(pp[1]);
4115 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4116 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4119 result = wait4pid(childpid, &status, 0);
4120 } while (result == -1 && errno == EINTR);
4122 (void)rsignal_restore(SIGINT, &ihand);
4123 (void)rsignal_restore(SIGQUIT, &qhand);
4125 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4126 do_execfree(); /* free any memory child malloced on fork */
4133 while (n < sizeof(int)) {
4134 n1 = PerlLIO_read(pp[0],
4135 (void*)(((char*)&errkid)+n),
4141 PerlLIO_close(pp[0]);
4142 if (n) { /* Error */
4143 if (n != sizeof(int))
4144 DIE(aTHX_ "panic: kid popen errno read");
4145 errno = errkid; /* Propagate errno from kid */
4146 STATUS_NATIVE_CHILD_SET(-1);
4149 XPUSHi(STATUS_CURRENT);
4153 PerlLIO_close(pp[0]);
4154 #if defined(HAS_FCNTL) && defined(F_SETFD)
4155 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4158 if (PL_op->op_flags & OPf_STACKED) {
4159 SV * const really = *++MARK;
4160 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4162 else if (SP - MARK != 1)
4163 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4165 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4169 #else /* ! FORK or VMS or OS/2 */
4172 if (PL_op->op_flags & OPf_STACKED) {
4173 SV * const really = *++MARK;
4174 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4175 value = (I32)do_aspawn(really, MARK, SP);
4177 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4180 else if (SP - MARK != 1) {
4181 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4182 value = (I32)do_aspawn(NULL, MARK, SP);
4184 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4188 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4190 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4192 STATUS_NATIVE_CHILD_SET(value);
4195 XPUSHi(result ? value : STATUS_CURRENT);
4196 #endif /* !FORK or VMS or OS/2 */
4203 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4208 while (++MARK <= SP) {
4209 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4214 TAINT_PROPER("exec");
4216 PERL_FLUSHALL_FOR_CHILD;
4217 if (PL_op->op_flags & OPf_STACKED) {
4218 SV * const really = *++MARK;
4219 value = (I32)do_aexec(really, MARK, SP);
4221 else if (SP - MARK != 1)
4223 value = (I32)vms_do_aexec(NULL, MARK, SP);
4227 (void ) do_aspawn(NULL, MARK, SP);
4231 value = (I32)do_aexec(NULL, MARK, SP);
4236 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4239 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4242 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4256 # ifdef THREADS_HAVE_PIDS
4257 if (PL_ppid != 1 && getppid() == 1)
4258 /* maybe the parent process has died. Refresh ppid cache */
4262 XPUSHi( getppid() );
4266 DIE(aTHX_ PL_no_func, "getppid");
4275 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4278 pgrp = (I32)BSD_GETPGRP(pid);
4280 if (pid != 0 && pid != PerlProc_getpid())
4281 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4287 DIE(aTHX_ PL_no_func, "getpgrp()");
4306 TAINT_PROPER("setpgrp");
4308 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4310 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4311 || (pid != 0 && pid != PerlProc_getpid()))
4313 DIE(aTHX_ "setpgrp can't take arguments");
4315 SETi( setpgrp() >= 0 );
4316 #endif /* USE_BSDPGRP */
4319 DIE(aTHX_ PL_no_func, "setpgrp()");
4325 #ifdef HAS_GETPRIORITY
4327 const int who = POPi;
4328 const int which = TOPi;
4329 SETi( getpriority(which, who) );
4332 DIE(aTHX_ PL_no_func, "getpriority()");
4338 #ifdef HAS_SETPRIORITY
4340 const int niceval = POPi;
4341 const int who = POPi;
4342 const int which = TOPi;
4343 TAINT_PROPER("setpriority");
4344 SETi( setpriority(which, who, niceval) >= 0 );
4347 DIE(aTHX_ PL_no_func, "setpriority()");
4357 XPUSHn( time(NULL) );
4359 XPUSHi( time(NULL) );
4371 (void)PerlProc_times(&PL_timesbuf);
4373 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4374 /* struct tms, though same data */
4378 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
4379 if (GIMME == G_ARRAY) {
4380 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
4381 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
4382 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
4388 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4390 if (GIMME == G_ARRAY) {
4391 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4392 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4393 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4397 DIE(aTHX_ "times not implemented");
4399 #endif /* HAS_TIMES */
4402 #ifdef LOCALTIME_EDGECASE_BROKEN
4403 static struct tm *S_my_localtime (pTHX_ Time_t *tp)
4408 /* No workarounds in the valid range */
4409 if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4410 return (localtime (tp));
4412 /* This edge case is to workaround the undefined behaviour, where the
4413 * TIMEZONE makes the time go beyond the defined range.
4414 * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4415 * If there is a negative offset in TZ, like MET-1METDST, some broken
4416 * implementations of localtime () (like AIX 5.2) barf with bogus
4418 * 0x7fffffff gmtime 2038-01-19 03:14:07
4419 * 0x7fffffff localtime 1901-12-13 21:45:51
4420 * 0x7fffffff mylocaltime 2038-01-19 04:14:07
4421 * 0x3c19137f gmtime 2001-12-13 20:45:51
4422 * 0x3c19137f localtime 2001-12-13 21:45:51
4423 * 0x3c19137f mylocaltime 2001-12-13 21:45:51
4424 * Given that legal timezones are typically between GMT-12 and GMT+12
4425 * we turn back the clock 23 hours before calling the localtime
4426 * function, and add those to the return value. This will never cause
4427 * day wrapping problems, since the edge case is Tue Jan *19*
4429 T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4432 if (P->tm_hour >= 24) {
4434 P->tm_mday++; /* 18 -> 19 */
4435 P->tm_wday++; /* Mon -> Tue */
4436 P->tm_yday++; /* 18 -> 19 */
4439 } /* S_my_localtime */
4447 const struct tm *tmbuf;
4448 static const char * const dayname[] =
4449 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4450 static const char * const monname[] =
4451 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4452 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4458 when = (Time_t)SvNVx(POPs);
4460 when = (Time_t)SvIVx(POPs);
4463 if (PL_op->op_type == OP_LOCALTIME)
4464 #ifdef LOCALTIME_EDGECASE_BROKEN
4465 tmbuf = S_my_localtime(aTHX_ &when);
4467 tmbuf = localtime(&when);
4470 tmbuf = gmtime(&when);
4472 if (GIMME != G_ARRAY) {
4478 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4479 dayname[tmbuf->tm_wday],
4480 monname[tmbuf->tm_mon],
4485 tmbuf->tm_year + 1900);
4486 PUSHs(sv_2mortal(tsv));
4491 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4492 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4493 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4494 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4495 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4496 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4497 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4498 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4499 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4510 anum = alarm((unsigned int)anum);
4517 DIE(aTHX_ PL_no_func, "alarm");
4528 (void)time(&lasttime);
4533 PerlProc_sleep((unsigned int)duration);
4536 XPUSHi(when - lasttime);
4540 /* Shared memory. */
4541 /* Merged with some message passing. */
4545 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4546 dVAR; dSP; dMARK; dTARGET;
4547 const int op_type = PL_op->op_type;
4552 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4555 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4558 value = (I32)(do_semop(MARK, SP) >= 0);
4561 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4577 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4578 dVAR; dSP; dMARK; dTARGET;
4579 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4586 DIE(aTHX_ "System V IPC is not implemented on this machine");
4592 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4593 dVAR; dSP; dMARK; dTARGET;
4594 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4602 PUSHp(zero_but_true, ZBTLEN);
4610 /* I can't const this further without getting warnings about the types of
4611 various arrays passed in from structures. */
4613 S_space_join_names_mortal(pTHX_ char *const *array)
4617 if (array && *array) {
4618 target = sv_2mortal(newSVpvs(""));
4620 sv_catpv(target, *array);
4623 sv_catpvs(target, " ");
4626 target = sv_mortalcopy(&PL_sv_no);
4631 /* Get system info. */
4635 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4637 I32 which = PL_op->op_type;
4638 register char **elem;
4640 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4641 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4642 struct hostent *gethostbyname(Netdb_name_t);
4643 struct hostent *gethostent(void);
4645 struct hostent *hent;
4649 if (which == OP_GHBYNAME) {
4650 #ifdef HAS_GETHOSTBYNAME
4651 const char* const name = POPpbytex;
4652 hent = PerlSock_gethostbyname(name);
4654 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4657 else if (which == OP_GHBYADDR) {
4658 #ifdef HAS_GETHOSTBYADDR
4659 const int addrtype = POPi;
4660 SV * const addrsv = POPs;
4662 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4664 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4666 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4670 #ifdef HAS_GETHOSTENT
4671 hent = PerlSock_gethostent();
4673 DIE(aTHX_ PL_no_sock_func, "gethostent");
4676 #ifdef HOST_NOT_FOUND
4678 #ifdef USE_REENTRANT_API
4679 # ifdef USE_GETHOSTENT_ERRNO
4680 h_errno = PL_reentrant_buffer->_gethostent_errno;
4683 STATUS_UNIX_SET(h_errno);
4687 if (GIMME != G_ARRAY) {
4688 PUSHs(sv = sv_newmortal());
4690 if (which == OP_GHBYNAME) {
4692 sv_setpvn(sv, hent->h_addr, hent->h_length);
4695 sv_setpv(sv, (char*)hent->h_name);
4701 PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
4702 PUSHs(space_join_names_mortal(hent->h_aliases));
4703 PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
4704 len = hent->h_length;
4705 PUSHs(sv_2mortal(newSViv((IV)len)));
4707 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4708 XPUSHs(sv_2mortal(newSVpvn(*elem, len)));
4712 PUSHs(newSVpvn(hent->h_addr, len));
4714 PUSHs(sv_mortalcopy(&PL_sv_no));
4719 DIE(aTHX_ PL_no_sock_func, "gethostent");
4725 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4727 I32 which = PL_op->op_type;
4729 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4730 struct netent *getnetbyaddr(Netdb_net_t, int);
4731 struct netent *getnetbyname(Netdb_name_t);
4732 struct netent *getnetent(void);
4734 struct netent *nent;
4736 if (which == OP_GNBYNAME){
4737 #ifdef HAS_GETNETBYNAME
4738 const char * const name = POPpbytex;
4739 nent = PerlSock_getnetbyname(name);
4741 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4744 else if (which == OP_GNBYADDR) {
4745 #ifdef HAS_GETNETBYADDR
4746 const int addrtype = POPi;
4747 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4748 nent = PerlSock_getnetbyaddr(addr, addrtype);
4750 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4754 #ifdef HAS_GETNETENT
4755 nent = PerlSock_getnetent();
4757 DIE(aTHX_ PL_no_sock_func, "getnetent");
4760 #ifdef HOST_NOT_FOUND
4762 #ifdef USE_REENTRANT_API
4763 # ifdef USE_GETNETENT_ERRNO
4764 h_errno = PL_reentrant_buffer->_getnetent_errno;
4767 STATUS_UNIX_SET(h_errno);
4772 if (GIMME != G_ARRAY) {
4773 PUSHs(sv = sv_newmortal());
4775 if (which == OP_GNBYNAME)
4776 sv_setiv(sv, (IV)nent->n_net);
4778 sv_setpv(sv, nent->n_name);
4784 PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
4785 PUSHs(space_join_names_mortal(nent->n_aliases));
4786 PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
4787 PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
4792 DIE(aTHX_ PL_no_sock_func, "getnetent");
4798 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4800 I32 which = PL_op->op_type;
4802 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4803 struct protoent *getprotobyname(Netdb_name_t);
4804 struct protoent *getprotobynumber(int);
4805 struct protoent *getprotoent(void);
4807 struct protoent *pent;
4809 if (which == OP_GPBYNAME) {
4810 #ifdef HAS_GETPROTOBYNAME
4811 const char* const name = POPpbytex;
4812 pent = PerlSock_getprotobyname(name);
4814 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4817 else if (which == OP_GPBYNUMBER) {
4818 #ifdef HAS_GETPROTOBYNUMBER
4819 const int number = POPi;
4820 pent = PerlSock_getprotobynumber(number);
4822 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4826 #ifdef HAS_GETPROTOENT
4827 pent = PerlSock_getprotoent();
4829 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4833 if (GIMME != G_ARRAY) {
4834 PUSHs(sv = sv_newmortal());
4836 if (which == OP_GPBYNAME)
4837 sv_setiv(sv, (IV)pent->p_proto);
4839 sv_setpv(sv, pent->p_name);
4845 PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
4846 PUSHs(space_join_names_mortal(pent->p_aliases));
4847 PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
4852 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4858 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4860 I32 which = PL_op->op_type;
4862 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4863 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4864 struct servent *getservbyport(int, Netdb_name_t);
4865 struct servent *getservent(void);
4867 struct servent *sent;
4869 if (which == OP_GSBYNAME) {
4870 #ifdef HAS_GETSERVBYNAME
4871 const char * const proto = POPpbytex;
4872 const char * const name = POPpbytex;
4873 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4875 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4878 else if (which == OP_GSBYPORT) {
4879 #ifdef HAS_GETSERVBYPORT
4880 const char * const proto = POPpbytex;
4881 unsigned short port = (unsigned short)POPu;
4883 port = PerlSock_htons(port);
4885 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4887 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4891 #ifdef HAS_GETSERVENT
4892 sent = PerlSock_getservent();
4894 DIE(aTHX_ PL_no_sock_func, "getservent");
4898 if (GIMME != G_ARRAY) {
4899 PUSHs(sv = sv_newmortal());
4901 if (which == OP_GSBYNAME) {
4903 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4905 sv_setiv(sv, (IV)(sent->s_port));
4909 sv_setpv(sv, sent->s_name);
4915 PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
4916 PUSHs(space_join_names_mortal(sent->s_aliases));
4918 PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
4920 PUSHs(sv_2mortal(newSViv((IV)(sent->s_port))));
4922 PUSHs(sv_2mortal(newSVpv(sent->s_proto, 0)));
4927 DIE(aTHX_ PL_no_sock_func, "getservent");
4933 #ifdef HAS_SETHOSTENT
4935 PerlSock_sethostent(TOPi);
4938 DIE(aTHX_ PL_no_sock_func, "sethostent");
4944 #ifdef HAS_SETNETENT
4946 PerlSock_setnetent(TOPi);
4949 DIE(aTHX_ PL_no_sock_func, "setnetent");
4955 #ifdef HAS_SETPROTOENT
4957 PerlSock_setprotoent(TOPi);
4960 DIE(aTHX_ PL_no_sock_func, "setprotoent");
4966 #ifdef HAS_SETSERVENT
4968 PerlSock_setservent(TOPi);
4971 DIE(aTHX_ PL_no_sock_func, "setservent");
4977 #ifdef HAS_ENDHOSTENT
4979 PerlSock_endhostent();
4983 DIE(aTHX_ PL_no_sock_func, "endhostent");
4989 #ifdef HAS_ENDNETENT
4991 PerlSock_endnetent();
4995 DIE(aTHX_ PL_no_sock_func, "endnetent");
5001 #ifdef HAS_ENDPROTOENT
5003 PerlSock_endprotoent();
5007 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5013 #ifdef HAS_ENDSERVENT
5015 PerlSock_endservent();
5019 DIE(aTHX_ PL_no_sock_func, "endservent");
5027 I32 which = PL_op->op_type;
5029 struct passwd *pwent = NULL;
5031 * We currently support only the SysV getsp* shadow password interface.
5032 * The interface is declared in <shadow.h> and often one needs to link
5033 * with -lsecurity or some such.
5034 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5037 * AIX getpwnam() is clever enough to return the encrypted password
5038 * only if the caller (euid?) is root.
5040 * There are at least three other shadow password APIs. Many platforms
5041 * seem to contain more than one interface for accessing the shadow
5042 * password databases, possibly for compatibility reasons.
5043 * The getsp*() is by far he simplest one, the other two interfaces
5044 * are much more complicated, but also very similar to each other.
5049 * struct pr_passwd *getprpw*();
5050 * The password is in
5051 * char getprpw*(...).ufld.fd_encrypt[]
5052 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5057 * struct es_passwd *getespw*();
5058 * The password is in
5059 * char *(getespw*(...).ufld.fd_encrypt)
5060 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5063 * struct userpw *getuserpw();
5064 * The password is in
5065 * char *(getuserpw(...)).spw_upw_passwd
5066 * (but the de facto standard getpwnam() should work okay)
5068 * Mention I_PROT here so that Configure probes for it.
5070 * In HP-UX for getprpw*() the manual page claims that one should include
5071 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5072 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5073 * and pp_sys.c already includes <shadow.h> if there is such.
5075 * Note that <sys/security.h> is already probed for, but currently
5076 * it is only included in special cases.
5078 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5079 * be preferred interface, even though also the getprpw*() interface
5080 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5081 * One also needs to call set_auth_parameters() in main() before
5082 * doing anything else, whether one is using getespw*() or getprpw*().
5084 * Note that accessing the shadow databases can be magnitudes
5085 * slower than accessing the standard databases.
5090 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5091 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5092 * the pw_comment is left uninitialized. */
5093 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5099 const char* const name = POPpbytex;
5100 pwent = getpwnam(name);
5106 pwent = getpwuid(uid);
5110 # ifdef HAS_GETPWENT
5112 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5113 if (pwent) pwent = getpwnam(pwent->pw_name);
5116 DIE(aTHX_ PL_no_func, "getpwent");
5122 if (GIMME != G_ARRAY) {
5123 PUSHs(sv = sv_newmortal());
5125 if (which == OP_GPWNAM)
5126 # if Uid_t_sign <= 0
5127 sv_setiv(sv, (IV)pwent->pw_uid);
5129 sv_setuv(sv, (UV)pwent->pw_uid);
5132 sv_setpv(sv, pwent->pw_name);
5138 PUSHs(sv_2mortal(newSVpv(pwent->pw_name, 0)));
5140 PUSHs(sv = sv_2mortal(newSViv(0)));
5141 /* If we have getspnam(), we try to dig up the shadow
5142 * password. If we are underprivileged, the shadow
5143 * interface will set the errno to EACCES or similar,
5144 * and return a null pointer. If this happens, we will
5145 * use the dummy password (usually "*" or "x") from the
5146 * standard password database.
5148 * In theory we could skip the shadow call completely
5149 * if euid != 0 but in practice we cannot know which
5150 * security measures are guarding the shadow databases
5151 * on a random platform.
5153 * Resist the urge to use additional shadow interfaces.
5154 * Divert the urge to writing an extension instead.
5157 /* Some AIX setups falsely(?) detect some getspnam(), which
5158 * has a different API than the Solaris/IRIX one. */
5159 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5161 const int saverrno = errno;
5162 const struct spwd * const spwent = getspnam(pwent->pw_name);
5163 /* Save and restore errno so that
5164 * underprivileged attempts seem
5165 * to have never made the unsccessful
5166 * attempt to retrieve the shadow password. */
5168 if (spwent && spwent->sp_pwdp)
5169 sv_setpv(sv, spwent->sp_pwdp);
5173 if (!SvPOK(sv)) /* Use the standard password, then. */
5174 sv_setpv(sv, pwent->pw_passwd);
5177 # ifndef INCOMPLETE_TAINTS
5178 /* passwd is tainted because user himself can diddle with it.
5179 * admittedly not much and in a very limited way, but nevertheless. */
5183 # if Uid_t_sign <= 0
5184 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_uid)));
5186 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_uid)));
5189 # if Uid_t_sign <= 0
5190 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_gid)));
5192 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_gid)));
5194 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5195 * because of the poor interface of the Perl getpw*(),
5196 * not because there's some standard/convention saying so.
5197 * A better interface would have been to return a hash,
5198 * but we are accursed by our history, alas. --jhi. */
5200 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_change)));
5203 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_quota)));
5206 PUSHs(sv_2mortal(newSVpv(pwent->pw_age, 0)));
5208 /* I think that you can never get this compiled, but just in case. */
5209 PUSHs(sv_mortalcopy(&PL_sv_no));
5214 /* pw_class and pw_comment are mutually exclusive--.
5215 * see the above note for pw_change, pw_quota, and pw_age. */
5217 PUSHs(sv_2mortal(newSVpv(pwent->pw_class, 0)));
5220 PUSHs(sv_2mortal(newSVpv(pwent->pw_comment, 0)));
5222 /* I think that you can never get this compiled, but just in case. */
5223 PUSHs(sv_mortalcopy(&PL_sv_no));
5228 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5230 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5232 # ifndef INCOMPLETE_TAINTS
5233 /* pw_gecos is tainted because user himself can diddle with it. */
5237 PUSHs(sv_2mortal(newSVpv(pwent->pw_dir, 0)));
5239 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5240 # ifndef INCOMPLETE_TAINTS
5241 /* pw_shell is tainted because user himself can diddle with it. */
5246 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_expire)));
5251 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5257 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5262 DIE(aTHX_ PL_no_func, "setpwent");
5268 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5273 DIE(aTHX_ PL_no_func, "endpwent");
5281 const I32 which = PL_op->op_type;
5282 const struct group *grent;
5284 if (which == OP_GGRNAM) {
5285 const char* const name = POPpbytex;
5286 grent = (const struct group *)getgrnam(name);
5288 else if (which == OP_GGRGID) {
5289 const Gid_t gid = POPi;
5290 grent = (const struct group *)getgrgid(gid);
5294 grent = (struct group *)getgrent();
5296 DIE(aTHX_ PL_no_func, "getgrent");
5300 if (GIMME != G_ARRAY) {
5301 SV * const sv = sv_newmortal();
5305 if (which == OP_GGRNAM)
5306 sv_setiv(sv, (IV)grent->gr_gid);
5308 sv_setpv(sv, grent->gr_name);
5314 PUSHs(sv_2mortal(newSVpv(grent->gr_name, 0)));
5317 PUSHs(sv_2mortal(newSVpv(grent->gr_passwd, 0)));
5319 PUSHs(sv_mortalcopy(&PL_sv_no));
5322 PUSHs(sv_2mortal(newSViv((IV)grent->gr_gid)));
5324 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5325 /* In UNICOS/mk (_CRAYMPP) the multithreading
5326 * versions (getgrnam_r, getgrgid_r)
5327 * seem to return an illegal pointer
5328 * as the group members list, gr_mem.
5329 * getgrent() doesn't even have a _r version
5330 * but the gr_mem is poisonous anyway.
5331 * So yes, you cannot get the list of group
5332 * members if building multithreaded in UNICOS/mk. */
5333 PUSHs(space_join_names_mortal(grent->gr_mem));
5339 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5345 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5350 DIE(aTHX_ PL_no_func, "setgrent");
5356 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5361 DIE(aTHX_ PL_no_func, "endgrent");
5371 if (!(tmps = PerlProc_getlogin()))
5373 PUSHp(tmps, strlen(tmps));
5376 DIE(aTHX_ PL_no_func, "getlogin");
5380 /* Miscellaneous. */
5385 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5386 register I32 items = SP - MARK;
5387 unsigned long a[20];
5392 while (++MARK <= SP) {
5393 if (SvTAINTED(*MARK)) {
5399 TAINT_PROPER("syscall");
5402 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5403 * or where sizeof(long) != sizeof(char*). But such machines will
5404 * not likely have syscall implemented either, so who cares?
5406 while (++MARK <= SP) {
5407 if (SvNIOK(*MARK) || !i)
5408 a[i++] = SvIV(*MARK);
5409 else if (*MARK == &PL_sv_undef)
5412 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5418 DIE(aTHX_ "Too many args to syscall");
5420 DIE(aTHX_ "Too few args to syscall");
5422 retval = syscall(a[0]);
5425 retval = syscall(a[0],a[1]);
5428 retval = syscall(a[0],a[1],a[2]);
5431 retval = syscall(a[0],a[1],a[2],a[3]);
5434 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5437 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5440 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5443 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5447 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5450 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5453 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5457 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5461 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5465 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5466 a[10],a[11],a[12],a[13]);
5468 #endif /* atarist */
5474 DIE(aTHX_ PL_no_func, "syscall");
5478 #ifdef FCNTL_EMULATE_FLOCK
5480 /* XXX Emulate flock() with fcntl().
5481 What's really needed is a good file locking module.
5485 fcntl_emulate_flock(int fd, int operation)
5489 switch (operation & ~LOCK_NB) {
5491 flock.l_type = F_RDLCK;
5494 flock.l_type = F_WRLCK;
5497 flock.l_type = F_UNLCK;
5503 flock.l_whence = SEEK_SET;
5504 flock.l_start = flock.l_len = (Off_t)0;
5506 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5509 #endif /* FCNTL_EMULATE_FLOCK */
5511 #ifdef LOCKF_EMULATE_FLOCK
5513 /* XXX Emulate flock() with lockf(). This is just to increase
5514 portability of scripts. The calls are not completely
5515 interchangeable. What's really needed is a good file
5519 /* The lockf() constants might have been defined in <unistd.h>.
5520 Unfortunately, <unistd.h> causes troubles on some mixed
5521 (BSD/POSIX) systems, such as SunOS 4.1.3.
5523 Further, the lockf() constants aren't POSIX, so they might not be
5524 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5525 just stick in the SVID values and be done with it. Sigh.
5529 # define F_ULOCK 0 /* Unlock a previously locked region */
5532 # define F_LOCK 1 /* Lock a region for exclusive use */
5535 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5538 # define F_TEST 3 /* Test a region for other processes locks */
5542 lockf_emulate_flock(int fd, int operation)
5545 const int save_errno = errno;
5548 /* flock locks entire file so for lockf we need to do the same */
5549 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5550 if (pos > 0) /* is seekable and needs to be repositioned */
5551 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5552 pos = -1; /* seek failed, so don't seek back afterwards */
5555 switch (operation) {
5557 /* LOCK_SH - get a shared lock */
5559 /* LOCK_EX - get an exclusive lock */
5561 i = lockf (fd, F_LOCK, 0);
5564 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5565 case LOCK_SH|LOCK_NB:
5566 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5567 case LOCK_EX|LOCK_NB:
5568 i = lockf (fd, F_TLOCK, 0);
5570 if ((errno == EAGAIN) || (errno == EACCES))
5571 errno = EWOULDBLOCK;
5574 /* LOCK_UN - unlock (non-blocking is a no-op) */
5576 case LOCK_UN|LOCK_NB:
5577 i = lockf (fd, F_ULOCK, 0);
5580 /* Default - can't decipher operation */
5587 if (pos > 0) /* need to restore position of the handle */
5588 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5593 #endif /* LOCKF_EMULATE_FLOCK */
5597 * c-indentation-style: bsd
5599 * indent-tabs-mode: t
5602 * ex: set ts=8 sts=4 sw=4 noet: