3 * Copyright (C) 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * But only a short way ahead its floor and the walls on either side were
13 * cloven by a great fissure, out of which the red glare came, now leaping
14 * up, now dying down into darkness; and all the while far below there was
15 * a rumour and a trouble as of great engines throbbing and labouring.
18 /* This file contains system pp ("push/pop") functions that
19 * execute the opcodes that make up a perl program. A typical pp function
20 * expects to find its arguments on the stack, and usually pushes its
21 * results onto the stack, hence the 'pp' terminology. Each OP structure
22 * contains a pointer to the relevant pp_foo() function.
24 * By 'system', we mean ops which interact with the OS, such as pp_open().
28 #define PERL_IN_PP_SYS_C
32 /* Shadow password support for solaris - pdo@cs.umd.edu
33 * Not just Solaris: at least HP-UX, IRIX, Linux.
34 * The API is from SysV.
36 * There are at least two more shadow interfaces,
37 * see the comments in pp_gpwent().
41 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
42 * and another MAXINT from "perl.h" <- <sys/param.h>. */
49 # include <sys/wait.h>
53 # include <sys/resource.h>
62 # include <sys/select.h>
66 /* XXX Configure test needed.
67 h_errno might not be a simple 'int', especially for multi-threaded
68 applications, see "extern int errno in perl.h". Creating such
69 a test requires taking into account the differences between
70 compiling multithreaded and singlethreaded ($ccflags et al).
71 HOST_NOT_FOUND is typically defined in <netdb.h>.
73 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
82 struct passwd *getpwnam (char *);
83 struct passwd *getpwuid (Uid_t);
88 struct passwd *getpwent (void);
89 #elif defined (VMS) && defined (my_getpwent)
90 struct passwd *Perl_my_getpwent (pTHX);
99 struct group *getgrnam (char *);
100 struct group *getgrgid (Gid_t);
104 struct group *getgrent (void);
110 # if defined(_MSC_VER) || defined(__MINGW32__)
111 # include <sys/utime.h>
118 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
121 # define my_chsize PerlLIO_chsize
124 # define my_chsize PerlLIO_chsize
126 I32 my_chsize(int fd, Off_t length);
132 #else /* no flock() */
134 /* fcntl.h might not have been included, even if it exists, because
135 the current Configure only sets I_FCNTL if it's needed to pick up
136 the *_OK constants. Make sure it has been included before testing
137 the fcntl() locking constants. */
138 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
142 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
143 # define FLOCK fcntl_emulate_flock
144 # define FCNTL_EMULATE_FLOCK
145 # else /* no flock() or fcntl(F_SETLK,...) */
147 # define FLOCK lockf_emulate_flock
148 # define LOCKF_EMULATE_FLOCK
150 # endif /* no flock() or fcntl(F_SETLK,...) */
153 static int FLOCK (int, int);
156 * These are the flock() constants. Since this sytems doesn't have
157 * flock(), the values of the constants are probably not available.
171 # endif /* emulating flock() */
173 #endif /* no flock() */
176 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
178 #if defined(I_SYS_ACCESS) && !defined(R_OK)
179 # include <sys/access.h>
182 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
183 # define FD_CLOEXEC 1 /* NeXT needs this */
189 /* Missing protos on LynxOS */
190 void sethostent(int);
191 void endhostent(void);
193 void endnetent(void);
194 void setprotoent(int);
195 void endprotoent(void);
196 void setservent(int);
197 void endservent(void);
200 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
202 /* AIX 5.2 and below use mktime for localtime, and defines the edge case
203 * for time 0x7fffffff to be valid only in UTC. AIX 5.3 provides localtime64
204 * available in the 32bit environment, which could warrant Configure
205 * checks in the future.
208 #define LOCALTIME_EDGECASE_BROKEN
211 /* F_OK unused: if stat() cannot find it... */
213 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
214 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
215 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
218 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
219 # ifdef I_SYS_SECURITY
220 # include <sys/security.h>
224 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
227 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
231 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
233 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
237 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
238 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
239 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
242 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
244 const Uid_t ruid = getuid();
245 const Uid_t euid = geteuid();
246 const Gid_t rgid = getgid();
247 const Gid_t egid = getegid();
251 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
252 Perl_croak(aTHX_ "switching effective uid is not implemented");
255 if (setreuid(euid, ruid))
258 if (setresuid(euid, ruid, (Uid_t)-1))
261 Perl_croak(aTHX_ "entering effective uid failed");
264 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
265 Perl_croak(aTHX_ "switching effective gid is not implemented");
268 if (setregid(egid, rgid))
271 if (setresgid(egid, rgid, (Gid_t)-1))
274 Perl_croak(aTHX_ "entering effective gid failed");
277 res = access(path, mode);
280 if (setreuid(ruid, euid))
283 if (setresuid(ruid, euid, (Uid_t)-1))
286 Perl_croak(aTHX_ "leaving effective uid failed");
289 if (setregid(rgid, egid))
292 if (setresgid(rgid, egid, (Gid_t)-1))
295 Perl_croak(aTHX_ "leaving effective gid failed");
300 # define PERL_EFF_ACCESS(p,f) (emulate_eaccess((p), (f)))
303 #if !defined(PERL_EFF_ACCESS)
304 /* With it or without it: anyway you get a warning: either that
305 it is unused, or it is declared static and never defined.
308 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
310 PERL_UNUSED_ARG(path);
311 PERL_UNUSED_ARG(mode);
312 Perl_croak(aTHX_ "switching effective uid is not implemented");
322 const char * const tmps = POPpconstx;
323 const I32 gimme = GIMME_V;
324 const char *mode = "r";
327 if (PL_op->op_private & OPpOPEN_IN_RAW)
329 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
331 fp = PerlProc_popen(tmps, mode);
333 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
335 PerlIO_apply_layers(aTHX_ fp,mode,type);
337 if (gimme == G_VOID) {
339 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
342 else if (gimme == G_SCALAR) {
345 PL_rs = &PL_sv_undef;
346 sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */
347 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
355 SV * const sv = newSV(79);
356 if (sv_gets(sv, fp, 0) == NULL) {
360 XPUSHs(sv_2mortal(sv));
361 if (SvLEN(sv) - SvCUR(sv) > 20) {
362 SvPV_shrink_to_cur(sv);
367 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
368 TAINT; /* "I believe that this is not gratuitous!" */
371 STATUS_NATIVE_CHILD_SET(-1);
372 if (gimme == G_SCALAR)
383 tryAMAGICunTARGET(iter, -1);
385 /* Note that we only ever get here if File::Glob fails to load
386 * without at the same time croaking, for some reason, or if
387 * perl was built with PERL_EXTERNAL_GLOB */
394 * The external globbing program may use things we can't control,
395 * so for security reasons we must assume the worst.
398 taint_proper(PL_no_security, "glob");
402 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
403 PL_last_in_gv = (GV*)*PL_stack_sp--;
405 SAVESPTR(PL_rs); /* This is not permanent, either. */
406 PL_rs = sv_2mortal(newSVpvs("\000"));
409 *SvPVX(PL_rs) = '\n';
413 result = do_readline();
421 PL_last_in_gv = cGVOP_gv;
422 return do_readline();
433 do_join(TARG, &PL_sv_no, MARK, SP);
437 else if (SP == MARK) {
444 tmps = SvPV_const(tmpsv, len);
445 if ((!tmps || !len) && PL_errgv) {
446 SV * const error = ERRSV;
447 SvUPGRADE(error, SVt_PV);
448 if (SvPOK(error) && SvCUR(error))
449 sv_catpvs(error, "\t...caught");
451 tmps = SvPV_const(tmpsv, len);
454 tmpsv = sv_2mortal(newSVpvs("Warning: something's wrong"));
456 Perl_warn(aTHX_ "%"SVf, (void*)tmpsv);
468 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
470 if (SP - MARK != 1) {
472 do_join(TARG, &PL_sv_no, MARK, SP);
474 tmps = SvPV_const(tmpsv, len);
480 tmps = SvROK(tmpsv) ? NULL : SvPV_const(tmpsv, len);
483 SV * const error = ERRSV;
484 SvUPGRADE(error, SVt_PV);
485 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
487 SvSetSV(error,tmpsv);
488 else if (sv_isobject(error)) {
489 HV * const stash = SvSTASH(SvRV(error));
490 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
492 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
493 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
500 call_sv((SV*)GvCV(gv),
501 G_SCALAR|G_EVAL|G_KEEPERR);
502 sv_setsv(error,*PL_stack_sp--);
508 if (SvPOK(error) && SvCUR(error))
509 sv_catpvs(error, "\t...propagated");
512 tmps = SvPV_const(tmpsv, len);
518 tmpsv = sv_2mortal(newSVpvs("Died"));
520 DIE(aTHX_ "%"SVf, (void*)tmpsv);
536 GV * const gv = (GV *)*++MARK;
539 DIE(aTHX_ PL_no_usym, "filehandle");
540 if ((io = GvIOp(gv))) {
542 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
544 mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
546 /* Method's args are same as ours ... */
547 /* ... except handle is replaced by the object */
548 *MARK-- = SvTIED_obj((SV*)io, mg);
552 call_method("OPEN", G_SCALAR);
566 tmps = SvPV_const(sv, len);
567 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
570 PUSHi( (I32)PL_forkprocess );
571 else if (PL_forkprocess == 0) /* we are a new child */
581 GV * const gv = (MAXARG == 0) ? PL_defoutgv : (GV*)POPs;
584 IO * const io = GvIO(gv);
586 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
589 XPUSHs(SvTIED_obj((SV*)io, mg));
592 call_method("CLOSE", G_SCALAR);
600 PUSHs(boolSV(do_close(gv, TRUE)));
613 GV * const wgv = (GV*)POPs;
614 GV * const rgv = (GV*)POPs;
619 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
620 DIE(aTHX_ PL_no_usym, "filehandle");
625 do_close(rgv, FALSE);
627 do_close(wgv, FALSE);
629 if (PerlProc_pipe(fd) < 0)
632 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
633 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
634 IoOFP(rstio) = IoIFP(rstio);
635 IoIFP(wstio) = IoOFP(wstio);
636 IoTYPE(rstio) = IoTYPE_RDONLY;
637 IoTYPE(wstio) = IoTYPE_WRONLY;
639 if (!IoIFP(rstio) || !IoOFP(wstio)) {
641 PerlIO_close(IoIFP(rstio));
643 PerlLIO_close(fd[0]);
645 PerlIO_close(IoOFP(wstio));
647 PerlLIO_close(fd[1]);
650 #if defined(HAS_FCNTL) && defined(F_SETFD)
651 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
652 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
659 DIE(aTHX_ PL_no_func, "pipe");
675 if (gv && (io = GvIO(gv))
676 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
679 XPUSHs(SvTIED_obj((SV*)io, mg));
682 call_method("FILENO", G_SCALAR);
688 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
689 /* Can't do this because people seem to do things like
690 defined(fileno($foo)) to check whether $foo is a valid fh.
691 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
692 report_evil_fh(gv, io, PL_op->op_type);
697 PUSHi(PerlIO_fileno(fp));
710 anum = PerlLIO_umask(0);
711 (void)PerlLIO_umask(anum);
714 anum = PerlLIO_umask(POPi);
715 TAINT_PROPER("umask");
718 /* Only DIE if trying to restrict permissions on "user" (self).
719 * Otherwise it's harmless and more useful to just return undef
720 * since 'group' and 'other' concepts probably don't exist here. */
721 if (MAXARG >= 1 && (POPi & 0700))
722 DIE(aTHX_ "umask not implemented");
723 XPUSHs(&PL_sv_undef);
744 if (gv && (io = GvIO(gv))) {
745 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
748 XPUSHs(SvTIED_obj((SV*)io, mg));
753 call_method("BINMODE", G_SCALAR);
761 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
762 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
763 report_evil_fh(gv, io, PL_op->op_type);
764 SETERRNO(EBADF,RMS_IFI);
770 const int mode = mode_from_discipline(discp);
771 const char *const d = (discp ? SvPV_nolen_const(discp) : NULL);
772 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
773 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
774 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
795 const I32 markoff = MARK - PL_stack_base;
796 const char *methname;
797 int how = PERL_MAGIC_tied;
801 switch(SvTYPE(varsv)) {
803 methname = "TIEHASH";
804 HvEITER_set((HV *)varsv, 0);
807 methname = "TIEARRAY";
810 #ifdef GV_UNIQUE_CHECK
811 if (GvUNIQUE((GV*)varsv)) {
812 Perl_croak(aTHX_ "Attempt to tie unique GV");
815 methname = "TIEHANDLE";
816 how = PERL_MAGIC_tiedscalar;
817 /* For tied filehandles, we apply tiedscalar magic to the IO
818 slot of the GP rather than the GV itself. AMS 20010812 */
820 GvIOp(varsv) = newIO();
821 varsv = (SV *)GvIOp(varsv);
824 methname = "TIESCALAR";
825 how = PERL_MAGIC_tiedscalar;
829 if (sv_isobject(*MARK)) {
831 PUSHSTACKi(PERLSI_MAGIC);
833 EXTEND(SP,(I32)items);
837 call_method(methname, G_SCALAR);
840 /* Not clear why we don't call call_method here too.
841 * perhaps to get different error message ?
843 stash = gv_stashsv(*MARK, FALSE);
844 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
845 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
846 methname, (void*)*MARK);
849 PUSHSTACKi(PERLSI_MAGIC);
851 EXTEND(SP,(I32)items);
855 call_sv((SV*)GvCV(gv), G_SCALAR);
861 if (sv_isobject(sv)) {
862 sv_unmagic(varsv, how);
863 /* Croak if a self-tie on an aggregate is attempted. */
864 if (varsv == SvRV(sv) &&
865 (SvTYPE(varsv) == SVt_PVAV ||
866 SvTYPE(varsv) == SVt_PVHV))
868 "Self-ties of arrays and hashes are not supported");
869 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
872 SP = PL_stack_base + markoff;
882 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
883 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
885 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
888 if ((mg = SvTIED_mg(sv, how))) {
889 SV * const obj = SvRV(SvTIED_obj(sv, mg));
891 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
893 if (gv && isGV(gv) && (cv = GvCV(gv))) {
895 XPUSHs(SvTIED_obj((SV*)gv, mg));
896 XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
899 call_sv((SV *)cv, G_VOID);
903 else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
904 Perl_warner(aTHX_ packWARN(WARN_UNTIE),
905 "untie attempted while %"UVuf" inner references still exist",
906 (UV)SvREFCNT(obj) - 1 ) ;
910 sv_unmagic(sv, how) ;
920 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
921 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
923 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
926 if ((mg = SvTIED_mg(sv, how))) {
927 SV *osv = SvTIED_obj(sv, mg);
928 if (osv == mg->mg_obj)
929 osv = sv_mortalcopy(osv);
943 HV * const hv = (HV*)POPs;
944 SV * const sv = sv_2mortal(newSVpvs("AnyDBM_File"));
945 stash = gv_stashsv(sv, FALSE);
946 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
948 require_pv("AnyDBM_File.pm");
950 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
951 DIE(aTHX_ "No dbm on this machine");
961 PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
963 PUSHs(sv_2mortal(newSVuv(O_RDWR)));
966 call_sv((SV*)GvCV(gv), G_SCALAR);
969 if (!sv_isobject(TOPs)) {
974 PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
977 call_sv((SV*)GvCV(gv), G_SCALAR);
981 if (sv_isobject(TOPs)) {
982 sv_unmagic((SV *) hv, PERL_MAGIC_tied);
983 sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, NULL, 0);
1000 struct timeval timebuf;
1001 struct timeval *tbuf = &timebuf;
1004 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1009 # if BYTEORDER & 0xf0000
1010 # define ORDERBYTE (0x88888888 - BYTEORDER)
1012 # define ORDERBYTE (0x4444 - BYTEORDER)
1018 for (i = 1; i <= 3; i++) {
1019 SV * const sv = SP[i];
1022 if (SvREADONLY(sv)) {
1024 sv_force_normal_flags(sv, 0);
1025 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1026 DIE(aTHX_ PL_no_modify);
1029 if (ckWARN(WARN_MISC))
1030 Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1031 SvPV_force_nolen(sv); /* force string conversion */
1038 /* little endians can use vecs directly */
1039 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1046 masksize = NFDBITS / NBBY;
1048 masksize = sizeof(long); /* documented int, everyone seems to use long */
1050 Zero(&fd_sets[0], 4, char*);
1053 # if SELECT_MIN_BITS == 1
1054 growsize = sizeof(fd_set);
1056 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1057 # undef SELECT_MIN_BITS
1058 # define SELECT_MIN_BITS __FD_SETSIZE
1060 /* If SELECT_MIN_BITS is greater than one we most probably will want
1061 * to align the sizes with SELECT_MIN_BITS/8 because for example
1062 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1063 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1064 * on (sets/tests/clears bits) is 32 bits. */
1065 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1073 timebuf.tv_sec = (long)value;
1074 value -= (NV)timebuf.tv_sec;
1075 timebuf.tv_usec = (long)(value * 1000000.0);
1080 for (i = 1; i <= 3; i++) {
1082 if (!SvOK(sv) || SvCUR(sv) == 0) {
1089 Sv_Grow(sv, growsize);
1093 while (++j <= growsize) {
1097 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1099 Newx(fd_sets[i], growsize, char);
1100 for (offset = 0; offset < growsize; offset += masksize) {
1101 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1102 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1105 fd_sets[i] = SvPVX(sv);
1109 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1110 /* Can't make just the (void*) conditional because that would be
1111 * cpp #if within cpp macro, and not all compilers like that. */
1112 nfound = PerlSock_select(
1114 (Select_fd_set_t) fd_sets[1],
1115 (Select_fd_set_t) fd_sets[2],
1116 (Select_fd_set_t) fd_sets[3],
1117 (void*) tbuf); /* Workaround for compiler bug. */
1119 nfound = PerlSock_select(
1121 (Select_fd_set_t) fd_sets[1],
1122 (Select_fd_set_t) fd_sets[2],
1123 (Select_fd_set_t) fd_sets[3],
1126 for (i = 1; i <= 3; i++) {
1129 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1131 for (offset = 0; offset < growsize; offset += masksize) {
1132 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1133 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1135 Safefree(fd_sets[i]);
1142 if (GIMME == G_ARRAY && tbuf) {
1143 value = (NV)(timebuf.tv_sec) +
1144 (NV)(timebuf.tv_usec) / 1000000.0;
1145 PUSHs(sv_2mortal(newSVnv(value)));
1149 DIE(aTHX_ "select not implemented");
1154 Perl_setdefout(pTHX_ GV *gv)
1157 SvREFCNT_inc_simple_void(gv);
1159 SvREFCNT_dec(PL_defoutgv);
1167 GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : NULL;
1168 GV * egv = GvEGV(PL_defoutgv);
1174 XPUSHs(&PL_sv_undef);
1176 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1177 if (gvp && *gvp == egv) {
1178 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1182 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1187 if (!GvIO(newdefout))
1188 gv_IOadd(newdefout);
1189 setdefout(newdefout);
1199 GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs;
1201 if (gv && (io = GvIO(gv))) {
1202 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1204 const I32 gimme = GIMME_V;
1206 XPUSHs(SvTIED_obj((SV*)io, mg));
1209 call_method("GETC", gimme);
1212 if (gimme == G_SCALAR)
1213 SvSetMagicSV_nosteal(TARG, TOPs);
1217 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1218 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1219 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1220 report_evil_fh(gv, io, PL_op->op_type);
1221 SETERRNO(EBADF,RMS_IFI);
1225 sv_setpvn(TARG, " ", 1);
1226 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1227 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1228 /* Find out how many bytes the char needs */
1229 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1232 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1233 SvCUR_set(TARG,1+len);
1242 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1245 register PERL_CONTEXT *cx;
1246 const I32 gimme = GIMME_V;
1251 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1253 cx->blk_sub.retop = retop;
1255 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1257 setdefout(gv); /* locally select filehandle so $% et al work */
1289 goto not_a_format_reference;
1294 tmpsv = sv_newmortal();
1295 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1296 name = SvPV_nolen_const(tmpsv);
1298 DIE(aTHX_ "Undefined format \"%s\" called", name);
1300 not_a_format_reference:
1301 DIE(aTHX_ "Not a format reference");
1304 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1306 IoFLAGS(io) &= ~IOf_DIDTOP;
1307 return doform(cv,gv,PL_op->op_next);
1313 GV * const gv = cxstack[cxstack_ix].blk_sub.gv;
1314 register IO * const io = GvIOp(gv);
1319 register PERL_CONTEXT *cx;
1321 if (!io || !(ofp = IoOFP(io)))
1324 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1325 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1327 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1328 PL_formtarget != PL_toptarget)
1332 if (!IoTOP_GV(io)) {
1335 if (!IoTOP_NAME(io)) {
1337 if (!IoFMT_NAME(io))
1338 IoFMT_NAME(io) = savepv(GvNAME(gv));
1339 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1340 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1341 if ((topgv && GvFORM(topgv)) ||
1342 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1343 IoTOP_NAME(io) = savesvpv(topname);
1345 IoTOP_NAME(io) = savepvs("top");
1347 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1348 if (!topgv || !GvFORM(topgv)) {
1349 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1352 IoTOP_GV(io) = topgv;
1354 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1355 I32 lines = IoLINES_LEFT(io);
1356 const char *s = SvPVX_const(PL_formtarget);
1357 if (lines <= 0) /* Yow, header didn't even fit!!! */
1359 while (lines-- > 0) {
1360 s = strchr(s, '\n');
1366 const STRLEN save = SvCUR(PL_formtarget);
1367 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1368 do_print(PL_formtarget, ofp);
1369 SvCUR_set(PL_formtarget, save);
1370 sv_chop(PL_formtarget, s);
1371 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1374 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1375 do_print(PL_formfeed, ofp);
1376 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1378 PL_formtarget = PL_toptarget;
1379 IoFLAGS(io) |= IOf_DIDTOP;
1382 DIE(aTHX_ "bad top format reference");
1385 SV * const sv = sv_newmortal();
1387 gv_efullname4(sv, fgv, NULL, FALSE);
1388 name = SvPV_nolen_const(sv);
1390 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1392 DIE(aTHX_ "Undefined top format called");
1394 if (cv && CvCLONE(cv))
1395 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1396 return doform(cv, gv, PL_op);
1400 POPBLOCK(cx,PL_curpm);
1406 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1408 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1409 else if (ckWARN(WARN_CLOSED))
1410 report_evil_fh(gv, io, PL_op->op_type);
1415 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1416 if (ckWARN(WARN_IO))
1417 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1419 if (!do_print(PL_formtarget, fp))
1422 FmLINES(PL_formtarget) = 0;
1423 SvCUR_set(PL_formtarget, 0);
1424 *SvEND(PL_formtarget) = '\0';
1425 if (IoFLAGS(io) & IOf_FLUSH)
1426 (void)PerlIO_flush(fp);
1431 PL_formtarget = PL_bodytarget;
1433 PERL_UNUSED_VAR(newsp);
1434 PERL_UNUSED_VAR(gimme);
1435 return cx->blk_sub.retop;
1440 dVAR; dSP; dMARK; dORIGMARK;
1445 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
1447 if (gv && (io = GvIO(gv))) {
1448 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1450 if (MARK == ORIGMARK) {
1453 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1457 *MARK = SvTIED_obj((SV*)io, mg);
1460 call_method("PRINTF", G_SCALAR);
1463 MARK = ORIGMARK + 1;
1471 if (!(io = GvIO(gv))) {
1472 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1473 report_evil_fh(gv, io, PL_op->op_type);
1474 SETERRNO(EBADF,RMS_IFI);
1477 else if (!(fp = IoOFP(io))) {
1478 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1480 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1481 else if (ckWARN(WARN_CLOSED))
1482 report_evil_fh(gv, io, PL_op->op_type);
1484 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1488 do_sprintf(sv, SP - MARK, MARK + 1);
1489 if (!do_print(sv, fp))
1492 if (IoFLAGS(io) & IOf_FLUSH)
1493 if (PerlIO_flush(fp) == EOF)
1504 PUSHs(&PL_sv_undef);
1512 const int perm = (MAXARG > 3) ? POPi : 0666;
1513 const int mode = POPi;
1514 SV * const sv = POPs;
1515 GV * const gv = (GV *)POPs;
1518 /* Need TIEHANDLE method ? */
1519 const char * const tmps = SvPV_const(sv, len);
1520 /* FIXME? do_open should do const */
1521 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1522 IoLINES(GvIOp(gv)) = 0;
1526 PUSHs(&PL_sv_undef);
1533 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1539 Sock_size_t bufsize;
1547 bool charstart = FALSE;
1548 STRLEN charskip = 0;
1551 GV * const gv = (GV*)*++MARK;
1552 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1553 && gv && (io = GvIO(gv)) )
1555 const MAGIC * mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1559 *MARK = SvTIED_obj((SV*)io, mg);
1561 call_method("READ", G_SCALAR);
1575 sv_setpvn(bufsv, "", 0);
1576 length = SvIVx(*++MARK);
1579 offset = SvIVx(*++MARK);
1583 if (!io || !IoIFP(io)) {
1584 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1585 report_evil_fh(gv, io, PL_op->op_type);
1586 SETERRNO(EBADF,RMS_IFI);
1589 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1590 buffer = SvPVutf8_force(bufsv, blen);
1591 /* UTF-8 may not have been set if they are all low bytes */
1596 buffer = SvPV_force(bufsv, blen);
1597 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1600 DIE(aTHX_ "Negative length");
1608 if (PL_op->op_type == OP_RECV) {
1609 char namebuf[MAXPATHLEN];
1610 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1611 bufsize = sizeof (struct sockaddr_in);
1613 bufsize = sizeof namebuf;
1615 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1619 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1620 /* 'offset' means 'flags' here */
1621 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1622 (struct sockaddr *)namebuf, &bufsize);
1626 /* Bogus return without padding */
1627 bufsize = sizeof (struct sockaddr_in);
1629 SvCUR_set(bufsv, count);
1630 *SvEND(bufsv) = '\0';
1631 (void)SvPOK_only(bufsv);
1635 /* This should not be marked tainted if the fp is marked clean */
1636 if (!(IoFLAGS(io) & IOf_UNTAINT))
1637 SvTAINTED_on(bufsv);
1639 sv_setpvn(TARG, namebuf, bufsize);
1644 if (PL_op->op_type == OP_RECV)
1645 DIE(aTHX_ PL_no_sock_func, "recv");
1647 if (DO_UTF8(bufsv)) {
1648 /* offset adjust in characters not bytes */
1649 blen = sv_len_utf8(bufsv);
1652 if (-offset > (int)blen)
1653 DIE(aTHX_ "Offset outside string");
1656 if (DO_UTF8(bufsv)) {
1657 /* convert offset-as-chars to offset-as-bytes */
1658 if (offset >= (int)blen)
1659 offset += SvCUR(bufsv) - blen;
1661 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1664 bufsize = SvCUR(bufsv);
1665 /* Allocating length + offset + 1 isn't perfect in the case of reading
1666 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1668 (should be 2 * length + offset + 1, or possibly something longer if
1669 PL_encoding is true) */
1670 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1671 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1672 Zero(buffer+bufsize, offset-bufsize, char);
1674 buffer = buffer + offset;
1676 read_target = bufsv;
1678 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1679 concatenate it to the current buffer. */
1681 /* Truncate the existing buffer to the start of where we will be
1683 SvCUR_set(bufsv, offset);
1685 read_target = sv_newmortal();
1686 SvUPGRADE(read_target, SVt_PV);
1687 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1690 if (PL_op->op_type == OP_SYSREAD) {
1691 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1692 if (IoTYPE(io) == IoTYPE_SOCKET) {
1693 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1699 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1704 #ifdef HAS_SOCKET__bad_code_maybe
1705 if (IoTYPE(io) == IoTYPE_SOCKET) {
1706 char namebuf[MAXPATHLEN];
1707 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1708 bufsize = sizeof (struct sockaddr_in);
1710 bufsize = sizeof namebuf;
1712 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1713 (struct sockaddr *)namebuf, &bufsize);
1718 count = PerlIO_read(IoIFP(io), buffer, length);
1719 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1720 if (count == 0 && PerlIO_error(IoIFP(io)))
1724 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1725 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1728 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1729 *SvEND(read_target) = '\0';
1730 (void)SvPOK_only(read_target);
1731 if (fp_utf8 && !IN_BYTES) {
1732 /* Look at utf8 we got back and count the characters */
1733 const char *bend = buffer + count;
1734 while (buffer < bend) {
1736 skip = UTF8SKIP(buffer);
1739 if (buffer - charskip + skip > bend) {
1740 /* partial character - try for rest of it */
1741 length = skip - (bend-buffer);
1742 offset = bend - SvPVX_const(bufsv);
1754 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1755 provided amount read (count) was what was requested (length)
1757 if (got < wanted && count == length) {
1758 length = wanted - got;
1759 offset = bend - SvPVX_const(bufsv);
1762 /* return value is character count */
1766 else if (buffer_utf8) {
1767 /* Let svcatsv upgrade the bytes we read in to utf8.
1768 The buffer is a mortal so will be freed soon. */
1769 sv_catsv_nomg(bufsv, read_target);
1772 /* This should not be marked tainted if the fp is marked clean */
1773 if (!(IoFLAGS(io) & IOf_UNTAINT))
1774 SvTAINTED_on(bufsv);
1786 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1792 STRLEN orig_blen_bytes;
1793 const int op_type = PL_op->op_type;
1797 GV *const gv = (GV*)*++MARK;
1798 if (PL_op->op_type == OP_SYSWRITE
1799 && gv && (io = GvIO(gv))) {
1800 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1804 if (MARK == SP - 1) {
1806 sv = sv_2mortal(newSViv(sv_len(*SP)));
1812 *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg);
1814 call_method("WRITE", G_SCALAR);
1830 if (!io || !IoIFP(io)) {
1832 if (ckWARN(WARN_CLOSED))
1833 report_evil_fh(gv, io, PL_op->op_type);
1834 SETERRNO(EBADF,RMS_IFI);
1838 /* Do this first to trigger any overloading. */
1839 buffer = SvPV_const(bufsv, blen);
1840 orig_blen_bytes = blen;
1841 doing_utf8 = DO_UTF8(bufsv);
1843 if (PerlIO_isutf8(IoIFP(io))) {
1844 if (!SvUTF8(bufsv)) {
1845 /* We don't modify the original scalar. */
1846 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1847 buffer = (char *) tmpbuf;
1851 else if (doing_utf8) {
1852 STRLEN tmplen = blen;
1853 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1856 buffer = (char *) tmpbuf;
1860 assert((char *)result == buffer);
1861 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1865 if (op_type == OP_SYSWRITE) {
1866 Size_t length = 0; /* This length is in characters. */
1872 /* The SV is bytes, and we've had to upgrade it. */
1873 blen_chars = orig_blen_bytes;
1875 /* The SV really is UTF-8. */
1876 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1877 /* Don't call sv_len_utf8 again because it will call magic
1878 or overloading a second time, and we might get back a
1879 different result. */
1880 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1882 /* It's safe, and it may well be cached. */
1883 blen_chars = sv_len_utf8(bufsv);
1891 length = blen_chars;
1893 #if Size_t_size > IVSIZE
1894 length = (Size_t)SvNVx(*++MARK);
1896 length = (Size_t)SvIVx(*++MARK);
1898 if ((SSize_t)length < 0) {
1900 DIE(aTHX_ "Negative length");
1905 offset = SvIVx(*++MARK);
1907 if (-offset > (IV)blen_chars) {
1909 DIE(aTHX_ "Offset outside string");
1911 offset += blen_chars;
1912 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1914 DIE(aTHX_ "Offset outside string");
1918 if (length > blen_chars - offset)
1919 length = blen_chars - offset;
1921 /* Here we convert length from characters to bytes. */
1922 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1923 /* Either we had to convert the SV, or the SV is magical, or
1924 the SV has overloading, in which case we can't or mustn't
1925 or mustn't call it again. */
1927 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1928 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1930 /* It's a real UTF-8 SV, and it's not going to change under
1931 us. Take advantage of any cache. */
1933 I32 len_I32 = length;
1935 /* Convert the start and end character positions to bytes.
1936 Remember that the second argument to sv_pos_u2b is relative
1938 sv_pos_u2b(bufsv, &start, &len_I32);
1945 buffer = buffer+offset;
1947 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1948 if (IoTYPE(io) == IoTYPE_SOCKET) {
1949 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1955 /* See the note at doio.c:do_print about filesize limits. --jhi */
1956 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1962 const int flags = SvIVx(*++MARK);
1965 char * const sockbuf = SvPVx(*++MARK, mlen);
1966 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1967 flags, (struct sockaddr *)sockbuf, mlen);
1971 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1976 DIE(aTHX_ PL_no_sock_func, "send");
1983 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
1986 #if Size_t_size > IVSIZE
2005 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
2007 gv = PL_last_in_gv = GvEGV(PL_argvgv);
2009 if (io && !IoIFP(io)) {
2010 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2012 IoFLAGS(io) &= ~IOf_START;
2013 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2014 sv_setpvn(GvSV(gv), "-", 1);
2015 SvSETMAGIC(GvSV(gv));
2017 else if (!nextargv(gv))
2022 gv = PL_last_in_gv; /* eof */
2025 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
2028 IO * const io = GvIO(gv);
2030 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
2032 XPUSHs(SvTIED_obj((SV*)io, mg));
2035 call_method("EOF", G_SCALAR);
2042 PUSHs(boolSV(!gv || do_eof(gv)));
2053 PL_last_in_gv = (GV*)POPs;
2056 if (gv && (io = GvIO(gv))) {
2057 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2060 XPUSHs(SvTIED_obj((SV*)io, mg));
2063 call_method("TELL", G_SCALAR);
2070 #if LSEEKSIZE > IVSIZE
2071 PUSHn( do_tell(gv) );
2073 PUSHi( do_tell(gv) );
2081 const int whence = POPi;
2082 #if LSEEKSIZE > IVSIZE
2083 const Off_t offset = (Off_t)SvNVx(POPs);
2085 const Off_t offset = (Off_t)SvIVx(POPs);
2088 GV * const gv = PL_last_in_gv = (GV*)POPs;
2091 if (gv && (io = GvIO(gv))) {
2092 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2095 XPUSHs(SvTIED_obj((SV*)io, mg));
2096 #if LSEEKSIZE > IVSIZE
2097 XPUSHs(sv_2mortal(newSVnv((NV) offset)));
2099 XPUSHs(sv_2mortal(newSViv(offset)));
2101 XPUSHs(sv_2mortal(newSViv(whence)));
2104 call_method("SEEK", G_SCALAR);
2111 if (PL_op->op_type == OP_SEEK)
2112 PUSHs(boolSV(do_seek(gv, offset, whence)));
2114 const Off_t sought = do_sysseek(gv, offset, whence);
2116 PUSHs(&PL_sv_undef);
2118 SV* const sv = sought ?
2119 #if LSEEKSIZE > IVSIZE
2124 : newSVpvn(zero_but_true, ZBTLEN);
2125 PUSHs(sv_2mortal(sv));
2135 /* There seems to be no consensus on the length type of truncate()
2136 * and ftruncate(), both off_t and size_t have supporters. In
2137 * general one would think that when using large files, off_t is
2138 * at least as wide as size_t, so using an off_t should be okay. */
2139 /* XXX Configure probe for the length type of *truncate() needed XXX */
2142 #if Off_t_size > IVSIZE
2147 /* Checking for length < 0 is problematic as the type might or
2148 * might not be signed: if it is not, clever compilers will moan. */
2149 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2156 if (PL_op->op_flags & OPf_SPECIAL) {
2157 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2166 TAINT_PROPER("truncate");
2167 if (!(fp = IoIFP(io))) {
2173 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2175 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2182 SV * const sv = POPs;
2185 if (SvTYPE(sv) == SVt_PVGV) {
2186 tmpgv = (GV*)sv; /* *main::FRED for example */
2187 goto do_ftruncate_gv;
2189 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2190 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
2191 goto do_ftruncate_gv;
2193 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2194 io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
2195 goto do_ftruncate_io;
2198 name = SvPV_nolen_const(sv);
2199 TAINT_PROPER("truncate");
2201 if (truncate(name, len) < 0)
2205 const int tmpfd = PerlLIO_open(name, O_RDWR);
2210 if (my_chsize(tmpfd, len) < 0)
2212 PerlLIO_close(tmpfd);
2221 SETERRNO(EBADF,RMS_IFI);
2229 SV * const argsv = POPs;
2230 const unsigned int func = POPu;
2231 const int optype = PL_op->op_type;
2232 GV * const gv = (GV*)POPs;
2233 IO * const io = gv ? GvIOn(gv) : NULL;
2237 if (!io || !argsv || !IoIFP(io)) {
2238 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2239 report_evil_fh(gv, io, PL_op->op_type);
2240 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2244 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2247 s = SvPV_force(argsv, len);
2248 need = IOCPARM_LEN(func);
2250 s = Sv_Grow(argsv, need + 1);
2251 SvCUR_set(argsv, need);
2254 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2257 retval = SvIV(argsv);
2258 s = INT2PTR(char*,retval); /* ouch */
2261 TAINT_PROPER(PL_op_desc[optype]);
2263 if (optype == OP_IOCTL)
2265 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2267 DIE(aTHX_ "ioctl is not implemented");
2271 DIE(aTHX_ "fcntl is not implemented");
2273 #if defined(OS2) && defined(__EMX__)
2274 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2276 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2280 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2282 if (s[SvCUR(argsv)] != 17)
2283 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2285 s[SvCUR(argsv)] = 0; /* put our null back */
2286 SvSETMAGIC(argsv); /* Assume it has changed */
2295 PUSHp(zero_but_true, ZBTLEN);
2308 const int argtype = POPi;
2309 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
2311 if (gv && (io = GvIO(gv)))
2317 /* XXX Looks to me like io is always NULL at this point */
2319 (void)PerlIO_flush(fp);
2320 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2323 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2324 report_evil_fh(gv, io, PL_op->op_type);
2326 SETERRNO(EBADF,RMS_IFI);
2331 DIE(aTHX_ PL_no_func, "flock()");
2341 const int protocol = POPi;
2342 const int type = POPi;
2343 const int domain = POPi;
2344 GV * const gv = (GV*)POPs;
2345 register IO * const io = gv ? GvIOn(gv) : NULL;
2349 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2350 report_evil_fh(gv, io, PL_op->op_type);
2351 if (io && IoIFP(io))
2352 do_close(gv, FALSE);
2353 SETERRNO(EBADF,LIB_INVARG);
2358 do_close(gv, FALSE);
2360 TAINT_PROPER("socket");
2361 fd = PerlSock_socket(domain, type, protocol);
2364 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2365 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2366 IoTYPE(io) = IoTYPE_SOCKET;
2367 if (!IoIFP(io) || !IoOFP(io)) {
2368 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2369 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2370 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2373 #if defined(HAS_FCNTL) && defined(F_SETFD)
2374 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2378 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2383 DIE(aTHX_ PL_no_sock_func, "socket");
2389 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2391 const int protocol = POPi;
2392 const int type = POPi;
2393 const int domain = POPi;
2394 GV * const gv2 = (GV*)POPs;
2395 GV * const gv1 = (GV*)POPs;
2396 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2397 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2400 if (!gv1 || !gv2 || !io1 || !io2) {
2401 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2403 report_evil_fh(gv1, io1, PL_op->op_type);
2405 report_evil_fh(gv1, io2, PL_op->op_type);
2407 if (io1 && IoIFP(io1))
2408 do_close(gv1, FALSE);
2409 if (io2 && IoIFP(io2))
2410 do_close(gv2, FALSE);
2415 do_close(gv1, FALSE);
2417 do_close(gv2, FALSE);
2419 TAINT_PROPER("socketpair");
2420 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2422 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2423 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2424 IoTYPE(io1) = IoTYPE_SOCKET;
2425 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2426 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2427 IoTYPE(io2) = IoTYPE_SOCKET;
2428 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2429 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2430 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2431 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2432 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2433 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2434 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2437 #if defined(HAS_FCNTL) && defined(F_SETFD)
2438 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2439 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2444 DIE(aTHX_ PL_no_sock_func, "socketpair");
2452 SV * const addrsv = POPs;
2453 /* OK, so on what platform does bind modify addr? */
2455 GV * const gv = (GV*)POPs;
2456 register IO * const io = GvIOn(gv);
2459 if (!io || !IoIFP(io))
2462 addr = SvPV_const(addrsv, len);
2463 TAINT_PROPER("bind");
2464 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2470 if (ckWARN(WARN_CLOSED))
2471 report_evil_fh(gv, io, PL_op->op_type);
2472 SETERRNO(EBADF,SS_IVCHAN);
2475 DIE(aTHX_ PL_no_sock_func, "bind");
2483 SV * const addrsv = POPs;
2484 GV * const gv = (GV*)POPs;
2485 register IO * const io = GvIOn(gv);
2489 if (!io || !IoIFP(io))
2492 addr = SvPV_const(addrsv, len);
2493 TAINT_PROPER("connect");
2494 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2500 if (ckWARN(WARN_CLOSED))
2501 report_evil_fh(gv, io, PL_op->op_type);
2502 SETERRNO(EBADF,SS_IVCHAN);
2505 DIE(aTHX_ PL_no_sock_func, "connect");
2513 const int backlog = POPi;
2514 GV * const gv = (GV*)POPs;
2515 register IO * const io = gv ? GvIOn(gv) : NULL;
2517 if (!gv || !io || !IoIFP(io))
2520 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2526 if (ckWARN(WARN_CLOSED))
2527 report_evil_fh(gv, io, PL_op->op_type);
2528 SETERRNO(EBADF,SS_IVCHAN);
2531 DIE(aTHX_ PL_no_sock_func, "listen");
2541 char namebuf[MAXPATHLEN];
2542 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2543 Sock_size_t len = sizeof (struct sockaddr_in);
2545 Sock_size_t len = sizeof namebuf;
2547 GV * const ggv = (GV*)POPs;
2548 GV * const ngv = (GV*)POPs;
2557 if (!gstio || !IoIFP(gstio))
2561 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2564 /* Some platforms indicate zero length when an AF_UNIX client is
2565 * not bound. Simulate a non-zero-length sockaddr structure in
2567 namebuf[0] = 0; /* sun_len */
2568 namebuf[1] = AF_UNIX; /* sun_family */
2576 do_close(ngv, FALSE);
2577 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2578 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2579 IoTYPE(nstio) = IoTYPE_SOCKET;
2580 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2581 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2582 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2583 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2586 #if defined(HAS_FCNTL) && defined(F_SETFD)
2587 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2591 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2592 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2594 #ifdef __SCO_VERSION__
2595 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2598 PUSHp(namebuf, len);
2602 if (ckWARN(WARN_CLOSED))
2603 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2604 SETERRNO(EBADF,SS_IVCHAN);
2610 DIE(aTHX_ PL_no_sock_func, "accept");
2618 const int how = POPi;
2619 GV * const gv = (GV*)POPs;
2620 register IO * const io = GvIOn(gv);
2622 if (!io || !IoIFP(io))
2625 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2629 if (ckWARN(WARN_CLOSED))
2630 report_evil_fh(gv, io, PL_op->op_type);
2631 SETERRNO(EBADF,SS_IVCHAN);
2634 DIE(aTHX_ PL_no_sock_func, "shutdown");
2642 const int optype = PL_op->op_type;
2643 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2644 const unsigned int optname = (unsigned int) POPi;
2645 const unsigned int lvl = (unsigned int) POPi;
2646 GV * const gv = (GV*)POPs;
2647 register IO * const io = GvIOn(gv);
2651 if (!io || !IoIFP(io))
2654 fd = PerlIO_fileno(IoIFP(io));
2658 (void)SvPOK_only(sv);
2662 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2669 #if defined(__SYMBIAN32__)
2670 # define SETSOCKOPT_OPTION_VALUE_T void *
2672 # define SETSOCKOPT_OPTION_VALUE_T const char *
2674 /* XXX TODO: We need to have a proper type (a Configure probe,
2675 * etc.) for what the C headers think of the third argument of
2676 * setsockopt(), the option_value read-only buffer: is it
2677 * a "char *", or a "void *", const or not. Some compilers
2678 * don't take kindly to e.g. assuming that "char *" implicitly
2679 * promotes to a "void *", or to explicitly promoting/demoting
2680 * consts to non/vice versa. The "const void *" is the SUS
2681 * definition, but that does not fly everywhere for the above
2683 SETSOCKOPT_OPTION_VALUE_T buf;
2687 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2691 aint = (int)SvIV(sv);
2692 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2695 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2704 if (ckWARN(WARN_CLOSED))
2705 report_evil_fh(gv, io, optype);
2706 SETERRNO(EBADF,SS_IVCHAN);
2711 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2719 const int optype = PL_op->op_type;
2720 GV * const gv = (GV*)POPs;
2721 register IO * const io = GvIOn(gv);
2726 if (!io || !IoIFP(io))
2729 sv = sv_2mortal(newSV(257));
2730 (void)SvPOK_only(sv);
2734 fd = PerlIO_fileno(IoIFP(io));
2736 case OP_GETSOCKNAME:
2737 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2740 case OP_GETPEERNAME:
2741 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2743 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2745 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";
2746 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2747 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2748 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2749 sizeof(u_short) + sizeof(struct in_addr))) {
2756 #ifdef BOGUS_GETNAME_RETURN
2757 /* Interactive Unix, getpeername() and getsockname()
2758 does not return valid namelen */
2759 if (len == BOGUS_GETNAME_RETURN)
2760 len = sizeof(struct sockaddr);
2768 if (ckWARN(WARN_CLOSED))
2769 report_evil_fh(gv, io, optype);
2770 SETERRNO(EBADF,SS_IVCHAN);
2775 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2790 if (PL_op->op_flags & OPf_REF) {
2792 if (PL_op->op_type == OP_LSTAT) {
2793 if (gv != PL_defgv) {
2794 do_fstat_warning_check:
2795 if (ckWARN(WARN_IO))
2796 Perl_warner(aTHX_ packWARN(WARN_IO),
2797 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2798 } else if (PL_laststype != OP_LSTAT)
2799 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2803 if (gv != PL_defgv) {
2804 PL_laststype = OP_STAT;
2806 sv_setpvn(PL_statname, "", 0);
2813 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2814 } else if (IoDIRP(io)) {
2817 PerlLIO_fstat(dirfd(IoDIRP(io)), &PL_statcache);
2819 DIE(aTHX_ PL_no_func, "dirfd");
2822 PL_laststatval = -1;
2828 if (PL_laststatval < 0) {
2829 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2830 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2835 SV* const sv = POPs;
2836 if (SvTYPE(sv) == SVt_PVGV) {
2839 } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2841 if (PL_op->op_type == OP_LSTAT)
2842 goto do_fstat_warning_check;
2844 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2846 if (PL_op->op_type == OP_LSTAT)
2847 goto do_fstat_warning_check;
2848 goto do_fstat_have_io;
2851 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2853 PL_laststype = PL_op->op_type;
2854 if (PL_op->op_type == OP_LSTAT)
2855 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2857 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2858 if (PL_laststatval < 0) {
2859 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2860 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2866 if (gimme != G_ARRAY) {
2867 if (gimme != G_VOID)
2868 XPUSHs(boolSV(max));
2874 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2875 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2876 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2877 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2878 #if Uid_t_size > IVSIZE
2879 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2881 # if Uid_t_sign <= 0
2882 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2884 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2887 #if Gid_t_size > IVSIZE
2888 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2890 # if Gid_t_sign <= 0
2891 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2893 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2896 #ifdef USE_STAT_RDEV
2897 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2899 PUSHs(sv_2mortal(newSVpvs("")));
2901 #if Off_t_size > IVSIZE
2902 PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
2904 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2907 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2908 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2909 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2911 PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2912 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2913 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
2915 #ifdef USE_STAT_BLOCKS
2916 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2917 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2919 PUSHs(sv_2mortal(newSVpvs("")));
2920 PUSHs(sv_2mortal(newSVpvs("")));
2926 /* This macro is used by the stacked filetest operators :
2927 * if the previous filetest failed, short-circuit and pass its value.
2928 * Else, discard it from the stack and continue. --rgs
2930 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2931 if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
2932 else { (void)POPs; PUTBACK; } \
2939 /* Not const, because things tweak this below. Not bool, because there's
2940 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2941 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2942 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2943 /* Giving some sort of initial value silences compilers. */
2945 int access_mode = R_OK;
2947 int access_mode = 0;
2950 /* access_mode is never used, but leaving use_access in makes the
2951 conditional compiling below much clearer. */
2954 int stat_mode = S_IRUSR;
2956 bool effective = FALSE;
2959 STACKED_FTEST_CHECK;
2961 switch (PL_op->op_type) {
2963 #if !(defined(HAS_ACCESS) && defined(R_OK))
2969 #if defined(HAS_ACCESS) && defined(W_OK)
2974 stat_mode = S_IWUSR;
2978 #if defined(HAS_ACCESS) && defined(X_OK)
2983 stat_mode = S_IXUSR;
2987 #ifdef PERL_EFF_ACCESS
2990 stat_mode = S_IWUSR;
2994 #ifndef PERL_EFF_ACCESS
3002 #ifdef PERL_EFF_ACCESS
3007 stat_mode = S_IXUSR;
3013 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3014 const char *const name = POPpx;
3016 # ifdef PERL_EFF_ACCESS
3017 result = PERL_EFF_ACCESS(name, access_mode);
3019 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3025 result = access(name, access_mode);
3027 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3042 if (cando(stat_mode, effective, &PL_statcache))
3051 const int op_type = PL_op->op_type;
3053 STACKED_FTEST_CHECK;
3058 if (op_type == OP_FTIS)
3061 /* You can't dTARGET inside OP_FTIS, because you'll get
3062 "panic: pad_sv po" - the op is not flagged to have a target. */
3066 #if Off_t_size > IVSIZE
3067 PUSHn(PL_statcache.st_size);
3069 PUSHi(PL_statcache.st_size);
3073 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3076 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3079 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3092 /* I believe that all these three are likely to be defined on most every
3093 system these days. */
3095 if(PL_op->op_type == OP_FTSUID)
3099 if(PL_op->op_type == OP_FTSGID)
3103 if(PL_op->op_type == OP_FTSVTX)
3107 STACKED_FTEST_CHECK;
3112 switch (PL_op->op_type) {
3114 if (PL_statcache.st_uid == PL_uid)
3118 if (PL_statcache.st_uid == PL_euid)
3122 if (PL_statcache.st_size == 0)
3126 if (S_ISSOCK(PL_statcache.st_mode))
3130 if (S_ISCHR(PL_statcache.st_mode))
3134 if (S_ISBLK(PL_statcache.st_mode))
3138 if (S_ISREG(PL_statcache.st_mode))
3142 if (S_ISDIR(PL_statcache.st_mode))
3146 if (S_ISFIFO(PL_statcache.st_mode))
3151 if (PL_statcache.st_mode & S_ISUID)
3157 if (PL_statcache.st_mode & S_ISGID)
3163 if (PL_statcache.st_mode & S_ISVTX)
3174 I32 result = my_lstat();
3178 if (S_ISLNK(PL_statcache.st_mode))
3191 STACKED_FTEST_CHECK;
3193 if (PL_op->op_flags & OPf_REF)
3195 else if (isGV(TOPs))
3197 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3198 gv = (GV*)SvRV(POPs);
3200 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3202 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3203 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3204 else if (tmpsv && SvOK(tmpsv)) {
3205 const char *tmps = SvPV_nolen_const(tmpsv);
3213 if (PerlLIO_isatty(fd))
3218 #if defined(atarist) /* this will work with atariST. Configure will
3219 make guesses for other systems. */
3220 # define FILE_base(f) ((f)->_base)
3221 # define FILE_ptr(f) ((f)->_ptr)
3222 # define FILE_cnt(f) ((f)->_cnt)
3223 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3234 register STDCHAR *s;
3240 STACKED_FTEST_CHECK;
3242 if (PL_op->op_flags & OPf_REF)
3244 else if (isGV(TOPs))
3246 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3247 gv = (GV*)SvRV(POPs);
3253 if (gv == PL_defgv) {
3255 io = GvIO(PL_statgv);
3258 goto really_filename;
3263 PL_laststatval = -1;
3264 sv_setpvn(PL_statname, "", 0);
3265 io = GvIO(PL_statgv);
3267 if (io && IoIFP(io)) {
3268 if (! PerlIO_has_base(IoIFP(io)))
3269 DIE(aTHX_ "-T and -B not implemented on filehandles");
3270 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3271 if (PL_laststatval < 0)
3273 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3274 if (PL_op->op_type == OP_FTTEXT)
3279 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3280 i = PerlIO_getc(IoIFP(io));
3282 (void)PerlIO_ungetc(IoIFP(io),i);
3284 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3286 len = PerlIO_get_bufsiz(IoIFP(io));
3287 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3288 /* sfio can have large buffers - limit to 512 */
3293 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3295 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3297 SETERRNO(EBADF,RMS_IFI);
3305 PL_laststype = OP_STAT;
3306 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3307 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3308 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3310 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3313 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3314 if (PL_laststatval < 0) {
3315 (void)PerlIO_close(fp);
3318 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3319 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3320 (void)PerlIO_close(fp);
3322 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3323 RETPUSHNO; /* special case NFS directories */
3324 RETPUSHYES; /* null file is anything */
3329 /* now scan s to look for textiness */
3330 /* XXX ASCII dependent code */
3332 #if defined(DOSISH) || defined(USEMYBINMODE)
3333 /* ignore trailing ^Z on short files */
3334 if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3338 for (i = 0; i < len; i++, s++) {
3339 if (!*s) { /* null never allowed in text */
3344 else if (!(isPRINT(*s) || isSPACE(*s)))
3347 else if (*s & 128) {
3349 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3352 /* utf8 characters don't count as odd */
3353 if (UTF8_IS_START(*s)) {
3354 int ulen = UTF8SKIP(s);
3355 if (ulen < len - i) {
3357 for (j = 1; j < ulen; j++) {
3358 if (!UTF8_IS_CONTINUATION(s[j]))
3361 --ulen; /* loop does extra increment */
3371 *s != '\n' && *s != '\r' && *s != '\b' &&
3372 *s != '\t' && *s != '\f' && *s != 27)
3377 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3388 const char *tmps = NULL;
3392 SV * const sv = POPs;
3393 if (PL_op->op_flags & OPf_SPECIAL) {
3394 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3396 else if (SvTYPE(sv) == SVt_PVGV) {
3399 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
3403 tmps = SvPVx_nolen_const(sv);
3407 if( !gv && (!tmps || !*tmps) ) {
3408 HV * const table = GvHVn(PL_envgv);
3411 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3412 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3414 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3419 deprecate("chdir('') or chdir(undef) as chdir()");
3420 tmps = SvPV_nolen_const(*svp);
3424 TAINT_PROPER("chdir");
3429 TAINT_PROPER("chdir");
3432 IO* const io = GvIO(gv);
3435 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3437 else if (IoDIRP(io)) {
3439 PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0);
3441 DIE(aTHX_ PL_no_func, "dirfd");
3445 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3446 report_evil_fh(gv, io, PL_op->op_type);
3447 SETERRNO(EBADF, RMS_IFI);
3452 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3453 report_evil_fh(gv, io, PL_op->op_type);
3454 SETERRNO(EBADF,RMS_IFI);
3458 DIE(aTHX_ PL_no_func, "fchdir");
3462 PUSHi( PerlDir_chdir(tmps) >= 0 );
3464 /* Clear the DEFAULT element of ENV so we'll get the new value
3466 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3473 dVAR; dSP; dMARK; dTARGET;
3474 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3485 char * const tmps = POPpx;
3486 TAINT_PROPER("chroot");
3487 PUSHi( chroot(tmps) >= 0 );
3490 DIE(aTHX_ PL_no_func, "chroot");
3498 const char * const tmps2 = POPpconstx;
3499 const char * const tmps = SvPV_nolen_const(TOPs);
3500 TAINT_PROPER("rename");
3502 anum = PerlLIO_rename(tmps, tmps2);
3504 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3505 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3508 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3509 (void)UNLINK(tmps2);
3510 if (!(anum = link(tmps, tmps2)))
3511 anum = UNLINK(tmps);
3519 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3523 const int op_type = PL_op->op_type;
3527 if (op_type == OP_LINK)
3528 DIE(aTHX_ PL_no_func, "link");
3530 # ifndef HAS_SYMLINK
3531 if (op_type == OP_SYMLINK)
3532 DIE(aTHX_ PL_no_func, "symlink");
3536 const char * const tmps2 = POPpconstx;
3537 const char * const tmps = SvPV_nolen_const(TOPs);
3538 TAINT_PROPER(PL_op_desc[op_type]);
3540 # if defined(HAS_LINK)
3541 # if defined(HAS_SYMLINK)
3542 /* Both present - need to choose which. */
3543 (op_type == OP_LINK) ?
3544 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3546 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3547 PerlLIO_link(tmps, tmps2);
3550 # if defined(HAS_SYMLINK)
3551 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3552 symlink(tmps, tmps2);
3557 SETi( result >= 0 );
3564 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3575 char buf[MAXPATHLEN];
3578 #ifndef INCOMPLETE_TAINTS
3582 len = readlink(tmps, buf, sizeof(buf) - 1);
3590 RETSETUNDEF; /* just pretend it's a normal file */
3594 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3596 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3598 char * const save_filename = filename;
3603 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3605 Newx(cmdline, size, char);
3606 my_strlcpy(cmdline, cmd, size);
3607 my_strlcat(cmdline, " ", size);
3608 for (s = cmdline + strlen(cmdline); *filename; ) {
3612 if (s - cmdline < size)
3613 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3614 myfp = PerlProc_popen(cmdline, "r");
3618 SV * const tmpsv = sv_newmortal();
3619 /* Need to save/restore 'PL_rs' ?? */
3620 s = sv_gets(tmpsv, myfp, 0);
3621 (void)PerlProc_pclose(myfp);
3625 #ifdef HAS_SYS_ERRLIST
3630 /* you don't see this */
3631 const char * const errmsg =
3632 #ifdef HAS_SYS_ERRLIST
3640 if (instr(s, errmsg)) {
3647 #define EACCES EPERM
3649 if (instr(s, "cannot make"))
3650 SETERRNO(EEXIST,RMS_FEX);
3651 else if (instr(s, "existing file"))
3652 SETERRNO(EEXIST,RMS_FEX);
3653 else if (instr(s, "ile exists"))
3654 SETERRNO(EEXIST,RMS_FEX);
3655 else if (instr(s, "non-exist"))
3656 SETERRNO(ENOENT,RMS_FNF);
3657 else if (instr(s, "does not exist"))
3658 SETERRNO(ENOENT,RMS_FNF);
3659 else if (instr(s, "not empty"))
3660 SETERRNO(EBUSY,SS_DEVOFFLINE);
3661 else if (instr(s, "cannot access"))
3662 SETERRNO(EACCES,RMS_PRV);
3664 SETERRNO(EPERM,RMS_PRV);
3667 else { /* some mkdirs return no failure indication */
3668 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3669 if (PL_op->op_type == OP_RMDIR)
3674 SETERRNO(EACCES,RMS_PRV); /* a guess */
3683 /* This macro removes trailing slashes from a directory name.
3684 * Different operating and file systems take differently to
3685 * trailing slashes. According to POSIX 1003.1 1996 Edition
3686 * any number of trailing slashes should be allowed.
3687 * Thusly we snip them away so that even non-conforming
3688 * systems are happy.
3689 * We should probably do this "filtering" for all
3690 * the functions that expect (potentially) directory names:
3691 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3692 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3694 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3695 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3698 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3699 (tmps) = savepvn((tmps), (len)); \
3709 const int mode = (MAXARG > 1) ? POPi : 0777;
3711 TRIMSLASHES(tmps,len,copy);
3713 TAINT_PROPER("mkdir");
3715 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3719 SETi( dooneliner("mkdir", tmps) );
3720 oldumask = PerlLIO_umask(0);
3721 PerlLIO_umask(oldumask);
3722 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3737 TRIMSLASHES(tmps,len,copy);
3738 TAINT_PROPER("rmdir");
3740 SETi( PerlDir_rmdir(tmps) >= 0 );
3742 SETi( dooneliner("rmdir", tmps) );
3749 /* Directory calls. */
3753 #if defined(Direntry_t) && defined(HAS_READDIR)
3755 const char * const dirname = POPpconstx;
3756 GV * const gv = (GV*)POPs;
3757 register IO * const io = GvIOn(gv);
3763 PerlDir_close(IoDIRP(io));
3764 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3770 SETERRNO(EBADF,RMS_DIR);
3773 DIE(aTHX_ PL_no_dir_func, "opendir");
3779 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3780 DIE(aTHX_ PL_no_dir_func, "readdir");
3782 #if !defined(I_DIRENT) && !defined(VMS)
3783 Direntry_t *readdir (DIR *);
3789 const I32 gimme = GIMME;
3790 GV * const gv = (GV *)POPs;
3791 register const Direntry_t *dp;
3792 register IO * const io = GvIOn(gv);
3794 if (!io || !IoDIRP(io)) {
3795 if(ckWARN(WARN_IO)) {
3796 Perl_warner(aTHX_ packWARN(WARN_IO),
3797 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3803 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3807 sv = newSVpvn(dp->d_name, dp->d_namlen);
3809 sv = newSVpv(dp->d_name, 0);
3811 #ifndef INCOMPLETE_TAINTS
3812 if (!(IoFLAGS(io) & IOf_UNTAINT))
3815 XPUSHs(sv_2mortal(sv));
3816 } while (gimme == G_ARRAY);
3818 if (!dp && gimme != G_ARRAY)
3825 SETERRNO(EBADF,RMS_ISI);
3826 if (GIMME == G_ARRAY)
3835 #if defined(HAS_TELLDIR) || defined(telldir)
3837 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3838 /* XXX netbsd still seemed to.
3839 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3840 --JHI 1999-Feb-02 */
3841 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3842 long telldir (DIR *);
3844 GV * const gv = (GV*)POPs;
3845 register IO * const io = GvIOn(gv);
3847 if (!io || !IoDIRP(io)) {
3848 if(ckWARN(WARN_IO)) {
3849 Perl_warner(aTHX_ packWARN(WARN_IO),
3850 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3855 PUSHi( PerlDir_tell(IoDIRP(io)) );
3859 SETERRNO(EBADF,RMS_ISI);
3862 DIE(aTHX_ PL_no_dir_func, "telldir");
3868 #if defined(HAS_SEEKDIR) || defined(seekdir)
3870 const long along = POPl;
3871 GV * const gv = (GV*)POPs;
3872 register IO * const io = GvIOn(gv);
3874 if (!io || !IoDIRP(io)) {
3875 if(ckWARN(WARN_IO)) {
3876 Perl_warner(aTHX_ packWARN(WARN_IO),
3877 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3881 (void)PerlDir_seek(IoDIRP(io), along);
3886 SETERRNO(EBADF,RMS_ISI);
3889 DIE(aTHX_ PL_no_dir_func, "seekdir");
3895 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3897 GV * const gv = (GV*)POPs;
3898 register IO * const io = GvIOn(gv);
3900 if (!io || !IoDIRP(io)) {
3901 if(ckWARN(WARN_IO)) {
3902 Perl_warner(aTHX_ packWARN(WARN_IO),
3903 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3907 (void)PerlDir_rewind(IoDIRP(io));
3911 SETERRNO(EBADF,RMS_ISI);
3914 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3920 #if defined(Direntry_t) && defined(HAS_READDIR)
3922 GV * const gv = (GV*)POPs;
3923 register IO * const io = GvIOn(gv);
3925 if (!io || !IoDIRP(io)) {
3926 if(ckWARN(WARN_IO)) {
3927 Perl_warner(aTHX_ packWARN(WARN_IO),
3928 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3932 #ifdef VOID_CLOSEDIR
3933 PerlDir_close(IoDIRP(io));
3935 if (PerlDir_close(IoDIRP(io)) < 0) {
3936 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3945 SETERRNO(EBADF,RMS_IFI);
3948 DIE(aTHX_ PL_no_dir_func, "closedir");
3952 /* Process control. */
3961 PERL_FLUSHALL_FOR_CHILD;
3962 childpid = PerlProc_fork();
3966 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3968 SvREADONLY_off(GvSV(tmpgv));
3969 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3970 SvREADONLY_on(GvSV(tmpgv));
3972 #ifdef THREADS_HAVE_PIDS
3973 PL_ppid = (IV)getppid();
3975 #ifdef PERL_USES_PL_PIDSTATUS
3976 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3982 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3987 PERL_FLUSHALL_FOR_CHILD;
3988 childpid = PerlProc_fork();
3994 DIE(aTHX_ PL_no_func, "fork");
4001 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4006 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4007 childpid = wait4pid(-1, &argflags, 0);
4009 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4014 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4015 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4016 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4018 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4023 DIE(aTHX_ PL_no_func, "wait");
4029 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4031 const int optype = POPi;
4032 const Pid_t pid = TOPi;
4036 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4037 result = wait4pid(pid, &argflags, optype);
4039 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4044 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4045 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4046 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4048 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4053 DIE(aTHX_ PL_no_func, "waitpid");
4059 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4065 while (++MARK <= SP) {
4066 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4071 TAINT_PROPER("system");
4073 PERL_FLUSHALL_FOR_CHILD;
4074 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4080 if (PerlProc_pipe(pp) >= 0)
4082 while ((childpid = PerlProc_fork()) == -1) {
4083 if (errno != EAGAIN) {
4088 PerlLIO_close(pp[0]);
4089 PerlLIO_close(pp[1]);
4096 Sigsave_t ihand,qhand; /* place to save signals during system() */
4100 PerlLIO_close(pp[1]);
4102 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4103 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4106 result = wait4pid(childpid, &status, 0);
4107 } while (result == -1 && errno == EINTR);
4109 (void)rsignal_restore(SIGINT, &ihand);
4110 (void)rsignal_restore(SIGQUIT, &qhand);
4112 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4113 do_execfree(); /* free any memory child malloced on fork */
4120 while (n < sizeof(int)) {
4121 n1 = PerlLIO_read(pp[0],
4122 (void*)(((char*)&errkid)+n),
4128 PerlLIO_close(pp[0]);
4129 if (n) { /* Error */
4130 if (n != sizeof(int))
4131 DIE(aTHX_ "panic: kid popen errno read");
4132 errno = errkid; /* Propagate errno from kid */
4133 STATUS_NATIVE_CHILD_SET(-1);
4136 XPUSHi(STATUS_CURRENT);
4140 PerlLIO_close(pp[0]);
4141 #if defined(HAS_FCNTL) && defined(F_SETFD)
4142 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4145 if (PL_op->op_flags & OPf_STACKED) {
4146 SV * const really = *++MARK;
4147 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4149 else if (SP - MARK != 1)
4150 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4152 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4156 #else /* ! FORK or VMS or OS/2 */
4159 if (PL_op->op_flags & OPf_STACKED) {
4160 SV * const really = *++MARK;
4161 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4162 value = (I32)do_aspawn(really, MARK, SP);
4164 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4167 else if (SP - MARK != 1) {
4168 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4169 value = (I32)do_aspawn(NULL, MARK, SP);
4171 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4175 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4177 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4179 STATUS_NATIVE_CHILD_SET(value);
4182 XPUSHi(result ? value : STATUS_CURRENT);
4183 #endif /* !FORK or VMS */
4189 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4194 while (++MARK <= SP) {
4195 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4200 TAINT_PROPER("exec");
4202 PERL_FLUSHALL_FOR_CHILD;
4203 if (PL_op->op_flags & OPf_STACKED) {
4204 SV * const really = *++MARK;
4205 value = (I32)do_aexec(really, MARK, SP);
4207 else if (SP - MARK != 1)
4209 value = (I32)vms_do_aexec(NULL, MARK, SP);
4213 (void ) do_aspawn(NULL, MARK, SP);
4217 value = (I32)do_aexec(NULL, MARK, SP);
4222 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4225 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4228 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4242 # ifdef THREADS_HAVE_PIDS
4243 if (PL_ppid != 1 && getppid() == 1)
4244 /* maybe the parent process has died. Refresh ppid cache */
4248 XPUSHi( getppid() );
4252 DIE(aTHX_ PL_no_func, "getppid");
4261 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4264 pgrp = (I32)BSD_GETPGRP(pid);
4266 if (pid != 0 && pid != PerlProc_getpid())
4267 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4273 DIE(aTHX_ PL_no_func, "getpgrp()");
4292 TAINT_PROPER("setpgrp");
4294 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4296 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4297 || (pid != 0 && pid != PerlProc_getpid()))
4299 DIE(aTHX_ "setpgrp can't take arguments");
4301 SETi( setpgrp() >= 0 );
4302 #endif /* USE_BSDPGRP */
4305 DIE(aTHX_ PL_no_func, "setpgrp()");
4311 #ifdef HAS_GETPRIORITY
4313 const int who = POPi;
4314 const int which = TOPi;
4315 SETi( getpriority(which, who) );
4318 DIE(aTHX_ PL_no_func, "getpriority()");
4324 #ifdef HAS_SETPRIORITY
4326 const int niceval = POPi;
4327 const int who = POPi;
4328 const int which = TOPi;
4329 TAINT_PROPER("setpriority");
4330 SETi( setpriority(which, who, niceval) >= 0 );
4333 DIE(aTHX_ PL_no_func, "setpriority()");
4343 XPUSHn( time(NULL) );
4345 XPUSHi( time(NULL) );
4357 (void)PerlProc_times(&PL_timesbuf);
4359 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4360 /* struct tms, though same data */
4364 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
4365 if (GIMME == G_ARRAY) {
4366 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
4367 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
4368 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
4374 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4376 if (GIMME == G_ARRAY) {
4377 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4378 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4379 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4383 DIE(aTHX_ "times not implemented");
4385 #endif /* HAS_TIMES */
4388 #ifdef LOCALTIME_EDGECASE_BROKEN
4389 static struct tm *S_my_localtime (pTHX_ Time_t *tp)
4394 /* No workarounds in the valid range */
4395 if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4396 return (localtime (tp));
4398 /* This edge case is to workaround the undefined behaviour, where the
4399 * TIMEZONE makes the time go beyond the defined range.
4400 * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4401 * If there is a negative offset in TZ, like MET-1METDST, some broken
4402 * implementations of localtime () (like AIX 5.2) barf with bogus
4404 * 0x7fffffff gmtime 2038-01-19 03:14:07
4405 * 0x7fffffff localtime 1901-12-13 21:45:51
4406 * 0x7fffffff mylocaltime 2038-01-19 04:14:07
4407 * 0x3c19137f gmtime 2001-12-13 20:45:51
4408 * 0x3c19137f localtime 2001-12-13 21:45:51
4409 * 0x3c19137f mylocaltime 2001-12-13 21:45:51
4410 * Given that legal timezones are typically between GMT-12 and GMT+12
4411 * we turn back the clock 23 hours before calling the localtime
4412 * function, and add those to the return value. This will never cause
4413 * day wrapping problems, since the edge case is Tue Jan *19*
4415 T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4418 if (P->tm_hour >= 24) {
4420 P->tm_mday++; /* 18 -> 19 */
4421 P->tm_wday++; /* Mon -> Tue */
4422 P->tm_yday++; /* 18 -> 19 */
4425 } /* S_my_localtime */
4433 const struct tm *tmbuf;
4434 static const char * const dayname[] =
4435 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4436 static const char * const monname[] =
4437 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4438 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4444 when = (Time_t)SvNVx(POPs);
4446 when = (Time_t)SvIVx(POPs);
4449 if (PL_op->op_type == OP_LOCALTIME)
4450 #ifdef LOCALTIME_EDGECASE_BROKEN
4451 tmbuf = S_my_localtime(aTHX_ &when);
4453 tmbuf = localtime(&when);
4456 tmbuf = gmtime(&when);
4458 if (GIMME != G_ARRAY) {
4464 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4465 dayname[tmbuf->tm_wday],
4466 monname[tmbuf->tm_mon],
4471 tmbuf->tm_year + 1900);
4472 PUSHs(sv_2mortal(tsv));
4477 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4478 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4479 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4480 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4481 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4482 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4483 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4484 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4485 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4496 anum = alarm((unsigned int)anum);
4503 DIE(aTHX_ PL_no_func, "alarm");
4514 (void)time(&lasttime);
4519 PerlProc_sleep((unsigned int)duration);
4522 XPUSHi(when - lasttime);
4526 /* Shared memory. */
4527 /* Merged with some message passing. */
4531 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4532 dVAR; dSP; dMARK; dTARGET;
4533 const int op_type = PL_op->op_type;
4538 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4541 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4544 value = (I32)(do_semop(MARK, SP) >= 0);
4547 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4563 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4564 dVAR; dSP; dMARK; dTARGET;
4565 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4572 DIE(aTHX_ "System V IPC is not implemented on this machine");
4578 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4579 dVAR; dSP; dMARK; dTARGET;
4580 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4588 PUSHp(zero_but_true, ZBTLEN);
4596 /* I can't const this further without getting warnings about the types of
4597 various arrays passed in from structures. */
4599 S_space_join_names_mortal(pTHX_ char *const *array)
4603 if (array && *array) {
4604 target = sv_2mortal(newSVpvs(""));
4606 sv_catpv(target, *array);
4609 sv_catpvs(target, " ");
4612 target = sv_mortalcopy(&PL_sv_no);
4617 /* Get system info. */
4621 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4623 I32 which = PL_op->op_type;
4624 register char **elem;
4626 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4627 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4628 struct hostent *gethostbyname(Netdb_name_t);
4629 struct hostent *gethostent(void);
4631 struct hostent *hent;
4635 if (which == OP_GHBYNAME) {
4636 #ifdef HAS_GETHOSTBYNAME
4637 const char* const name = POPpbytex;
4638 hent = PerlSock_gethostbyname(name);
4640 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4643 else if (which == OP_GHBYADDR) {
4644 #ifdef HAS_GETHOSTBYADDR
4645 const int addrtype = POPi;
4646 SV * const addrsv = POPs;
4648 Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4650 hent = PerlSock_gethostbyaddr((const char*)addr, (Netdb_hlen_t) addrlen, addrtype);
4652 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4656 #ifdef HAS_GETHOSTENT
4657 hent = PerlSock_gethostent();
4659 DIE(aTHX_ PL_no_sock_func, "gethostent");
4662 #ifdef HOST_NOT_FOUND
4664 #ifdef USE_REENTRANT_API
4665 # ifdef USE_GETHOSTENT_ERRNO
4666 h_errno = PL_reentrant_buffer->_gethostent_errno;
4669 STATUS_UNIX_SET(h_errno);
4673 if (GIMME != G_ARRAY) {
4674 PUSHs(sv = sv_newmortal());
4676 if (which == OP_GHBYNAME) {
4678 sv_setpvn(sv, hent->h_addr, hent->h_length);
4681 sv_setpv(sv, (char*)hent->h_name);
4687 PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
4688 PUSHs(space_join_names_mortal(hent->h_aliases));
4689 PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
4690 len = hent->h_length;
4691 PUSHs(sv_2mortal(newSViv((IV)len)));
4693 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4694 XPUSHs(sv_2mortal(newSVpvn(*elem, len)));
4698 PUSHs(newSVpvn(hent->h_addr, len));
4700 PUSHs(sv_mortalcopy(&PL_sv_no));
4705 DIE(aTHX_ PL_no_sock_func, "gethostent");
4711 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4713 I32 which = PL_op->op_type;
4715 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4716 struct netent *getnetbyaddr(Netdb_net_t, int);
4717 struct netent *getnetbyname(Netdb_name_t);
4718 struct netent *getnetent(void);
4720 struct netent *nent;
4722 if (which == OP_GNBYNAME){
4723 #ifdef HAS_GETNETBYNAME
4724 const char * const name = POPpbytex;
4725 nent = PerlSock_getnetbyname(name);
4727 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4730 else if (which == OP_GNBYADDR) {
4731 #ifdef HAS_GETNETBYADDR
4732 const int addrtype = POPi;
4733 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4734 nent = PerlSock_getnetbyaddr(addr, addrtype);
4736 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4740 #ifdef HAS_GETNETENT
4741 nent = PerlSock_getnetent();
4743 DIE(aTHX_ PL_no_sock_func, "getnetent");
4746 #ifdef HOST_NOT_FOUND
4748 #ifdef USE_REENTRANT_API
4749 # ifdef USE_GETNETENT_ERRNO
4750 h_errno = PL_reentrant_buffer->_getnetent_errno;
4753 STATUS_UNIX_SET(h_errno);
4758 if (GIMME != G_ARRAY) {
4759 PUSHs(sv = sv_newmortal());
4761 if (which == OP_GNBYNAME)
4762 sv_setiv(sv, (IV)nent->n_net);
4764 sv_setpv(sv, nent->n_name);
4770 PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
4771 PUSHs(space_join_names_mortal(nent->n_aliases));
4772 PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
4773 PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
4778 DIE(aTHX_ PL_no_sock_func, "getnetent");
4784 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4786 I32 which = PL_op->op_type;
4788 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4789 struct protoent *getprotobyname(Netdb_name_t);
4790 struct protoent *getprotobynumber(int);
4791 struct protoent *getprotoent(void);
4793 struct protoent *pent;
4795 if (which == OP_GPBYNAME) {
4796 #ifdef HAS_GETPROTOBYNAME
4797 const char* const name = POPpbytex;
4798 pent = PerlSock_getprotobyname(name);
4800 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4803 else if (which == OP_GPBYNUMBER) {
4804 #ifdef HAS_GETPROTOBYNUMBER
4805 const int number = POPi;
4806 pent = PerlSock_getprotobynumber(number);
4808 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4812 #ifdef HAS_GETPROTOENT
4813 pent = PerlSock_getprotoent();
4815 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4819 if (GIMME != G_ARRAY) {
4820 PUSHs(sv = sv_newmortal());
4822 if (which == OP_GPBYNAME)
4823 sv_setiv(sv, (IV)pent->p_proto);
4825 sv_setpv(sv, pent->p_name);
4831 PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
4832 PUSHs(space_join_names_mortal(pent->p_aliases));
4833 PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
4838 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4844 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4846 I32 which = PL_op->op_type;
4848 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4849 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4850 struct servent *getservbyport(int, Netdb_name_t);
4851 struct servent *getservent(void);
4853 struct servent *sent;
4855 if (which == OP_GSBYNAME) {
4856 #ifdef HAS_GETSERVBYNAME
4857 const char * const proto = POPpbytex;
4858 const char * const name = POPpbytex;
4859 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4861 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4864 else if (which == OP_GSBYPORT) {
4865 #ifdef HAS_GETSERVBYPORT
4866 const char * const proto = POPpbytex;
4867 unsigned short port = (unsigned short)POPu;
4869 port = PerlSock_htons(port);
4871 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4873 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4877 #ifdef HAS_GETSERVENT
4878 sent = PerlSock_getservent();
4880 DIE(aTHX_ PL_no_sock_func, "getservent");
4884 if (GIMME != G_ARRAY) {
4885 PUSHs(sv = sv_newmortal());
4887 if (which == OP_GSBYNAME) {
4889 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4891 sv_setiv(sv, (IV)(sent->s_port));
4895 sv_setpv(sv, sent->s_name);
4901 PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
4902 PUSHs(space_join_names_mortal(sent->s_aliases));
4904 PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
4906 PUSHs(sv_2mortal(newSViv((IV)(sent->s_port))));
4908 PUSHs(sv_2mortal(newSVpv(sent->s_proto, 0)));
4913 DIE(aTHX_ PL_no_sock_func, "getservent");
4919 #ifdef HAS_SETHOSTENT
4921 PerlSock_sethostent(TOPi);
4924 DIE(aTHX_ PL_no_sock_func, "sethostent");
4930 #ifdef HAS_SETNETENT
4932 PerlSock_setnetent(TOPi);
4935 DIE(aTHX_ PL_no_sock_func, "setnetent");
4941 #ifdef HAS_SETPROTOENT
4943 PerlSock_setprotoent(TOPi);
4946 DIE(aTHX_ PL_no_sock_func, "setprotoent");
4952 #ifdef HAS_SETSERVENT
4954 PerlSock_setservent(TOPi);
4957 DIE(aTHX_ PL_no_sock_func, "setservent");
4963 #ifdef HAS_ENDHOSTENT
4965 PerlSock_endhostent();
4969 DIE(aTHX_ PL_no_sock_func, "endhostent");
4975 #ifdef HAS_ENDNETENT
4977 PerlSock_endnetent();
4981 DIE(aTHX_ PL_no_sock_func, "endnetent");
4987 #ifdef HAS_ENDPROTOENT
4989 PerlSock_endprotoent();
4993 DIE(aTHX_ PL_no_sock_func, "endprotoent");
4999 #ifdef HAS_ENDSERVENT
5001 PerlSock_endservent();
5005 DIE(aTHX_ PL_no_sock_func, "endservent");
5013 I32 which = PL_op->op_type;
5015 struct passwd *pwent = NULL;
5017 * We currently support only the SysV getsp* shadow password interface.
5018 * The interface is declared in <shadow.h> and often one needs to link
5019 * with -lsecurity or some such.
5020 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5023 * AIX getpwnam() is clever enough to return the encrypted password
5024 * only if the caller (euid?) is root.
5026 * There are at least three other shadow password APIs. Many platforms
5027 * seem to contain more than one interface for accessing the shadow
5028 * password databases, possibly for compatibility reasons.
5029 * The getsp*() is by far he simplest one, the other two interfaces
5030 * are much more complicated, but also very similar to each other.
5035 * struct pr_passwd *getprpw*();
5036 * The password is in
5037 * char getprpw*(...).ufld.fd_encrypt[]
5038 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5043 * struct es_passwd *getespw*();
5044 * The password is in
5045 * char *(getespw*(...).ufld.fd_encrypt)
5046 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5049 * struct userpw *getuserpw();
5050 * The password is in
5051 * char *(getuserpw(...)).spw_upw_passwd
5052 * (but the de facto standard getpwnam() should work okay)
5054 * Mention I_PROT here so that Configure probes for it.
5056 * In HP-UX for getprpw*() the manual page claims that one should include
5057 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5058 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5059 * and pp_sys.c already includes <shadow.h> if there is such.
5061 * Note that <sys/security.h> is already probed for, but currently
5062 * it is only included in special cases.
5064 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5065 * be preferred interface, even though also the getprpw*() interface
5066 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5067 * One also needs to call set_auth_parameters() in main() before
5068 * doing anything else, whether one is using getespw*() or getprpw*().
5070 * Note that accessing the shadow databases can be magnitudes
5071 * slower than accessing the standard databases.
5076 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5077 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5078 * the pw_comment is left uninitialized. */
5079 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5085 const char* const name = POPpbytex;
5086 pwent = getpwnam(name);
5092 pwent = getpwuid(uid);
5096 # ifdef HAS_GETPWENT
5098 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5099 if (pwent) pwent = getpwnam(pwent->pw_name);
5102 DIE(aTHX_ PL_no_func, "getpwent");
5108 if (GIMME != G_ARRAY) {
5109 PUSHs(sv = sv_newmortal());
5111 if (which == OP_GPWNAM)
5112 # if Uid_t_sign <= 0
5113 sv_setiv(sv, (IV)pwent->pw_uid);
5115 sv_setuv(sv, (UV)pwent->pw_uid);
5118 sv_setpv(sv, pwent->pw_name);
5124 PUSHs(sv_2mortal(newSVpv(pwent->pw_name, 0)));
5126 PUSHs(sv = sv_2mortal(newSViv(0)));
5127 /* If we have getspnam(), we try to dig up the shadow
5128 * password. If we are underprivileged, the shadow
5129 * interface will set the errno to EACCES or similar,
5130 * and return a null pointer. If this happens, we will
5131 * use the dummy password (usually "*" or "x") from the
5132 * standard password database.
5134 * In theory we could skip the shadow call completely
5135 * if euid != 0 but in practice we cannot know which
5136 * security measures are guarding the shadow databases
5137 * on a random platform.
5139 * Resist the urge to use additional shadow interfaces.
5140 * Divert the urge to writing an extension instead.
5143 /* Some AIX setups falsely(?) detect some getspnam(), which
5144 * has a different API than the Solaris/IRIX one. */
5145 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5147 const int saverrno = errno;
5148 const struct spwd * const spwent = getspnam(pwent->pw_name);
5149 /* Save and restore errno so that
5150 * underprivileged attempts seem
5151 * to have never made the unsccessful
5152 * attempt to retrieve the shadow password. */
5154 if (spwent && spwent->sp_pwdp)
5155 sv_setpv(sv, spwent->sp_pwdp);
5159 if (!SvPOK(sv)) /* Use the standard password, then. */
5160 sv_setpv(sv, pwent->pw_passwd);
5163 # ifndef INCOMPLETE_TAINTS
5164 /* passwd is tainted because user himself can diddle with it.
5165 * admittedly not much and in a very limited way, but nevertheless. */
5169 # if Uid_t_sign <= 0
5170 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_uid)));
5172 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_uid)));
5175 # if Uid_t_sign <= 0
5176 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_gid)));
5178 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_gid)));
5180 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5181 * because of the poor interface of the Perl getpw*(),
5182 * not because there's some standard/convention saying so.
5183 * A better interface would have been to return a hash,
5184 * but we are accursed by our history, alas. --jhi. */
5186 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_change)));
5189 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_quota)));
5192 PUSHs(sv_2mortal(newSVpv(pwent->pw_age, 0)));
5194 /* I think that you can never get this compiled, but just in case. */
5195 PUSHs(sv_mortalcopy(&PL_sv_no));
5200 /* pw_class and pw_comment are mutually exclusive--.
5201 * see the above note for pw_change, pw_quota, and pw_age. */
5203 PUSHs(sv_2mortal(newSVpv(pwent->pw_class, 0)));
5206 PUSHs(sv_2mortal(newSVpv(pwent->pw_comment, 0)));
5208 /* I think that you can never get this compiled, but just in case. */
5209 PUSHs(sv_mortalcopy(&PL_sv_no));
5214 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5216 PUSHs(sv_mortalcopy(&PL_sv_no));
5218 # ifndef INCOMPLETE_TAINTS
5219 /* pw_gecos is tainted because user himself can diddle with it. */
5223 PUSHs(sv_2mortal(newSVpv(pwent->pw_dir, 0)));
5225 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5226 # ifndef INCOMPLETE_TAINTS
5227 /* pw_shell is tainted because user himself can diddle with it. */
5232 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_expire)));
5237 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5243 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5248 DIE(aTHX_ PL_no_func, "setpwent");
5254 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5259 DIE(aTHX_ PL_no_func, "endpwent");
5267 const I32 which = PL_op->op_type;
5268 const struct group *grent;
5270 if (which == OP_GGRNAM) {
5271 const char* const name = POPpbytex;
5272 grent = (const struct group *)getgrnam(name);
5274 else if (which == OP_GGRGID) {
5275 const Gid_t gid = POPi;
5276 grent = (const struct group *)getgrgid(gid);
5280 grent = (struct group *)getgrent();
5282 DIE(aTHX_ PL_no_func, "getgrent");
5286 if (GIMME != G_ARRAY) {
5287 SV * const sv = sv_newmortal();
5291 if (which == OP_GGRNAM)
5292 sv_setiv(sv, (IV)grent->gr_gid);
5294 sv_setpv(sv, grent->gr_name);
5300 PUSHs(sv_2mortal(newSVpv(grent->gr_name, 0)));
5303 PUSHs(sv_2mortal(newSVpv(grent->gr_passwd, 0)));
5305 PUSHs(sv_mortalcopy(&PL_sv_no));
5308 PUSHs(sv_2mortal(newSViv((IV)grent->gr_gid)));
5310 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5311 /* In UNICOS/mk (_CRAYMPP) the multithreading
5312 * versions (getgrnam_r, getgrgid_r)
5313 * seem to return an illegal pointer
5314 * as the group members list, gr_mem.
5315 * getgrent() doesn't even have a _r version
5316 * but the gr_mem is poisonous anyway.
5317 * So yes, you cannot get the list of group
5318 * members if building multithreaded in UNICOS/mk. */
5319 PUSHs(space_join_names_mortal(grent->gr_mem));
5325 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5331 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5336 DIE(aTHX_ PL_no_func, "setgrent");
5342 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5347 DIE(aTHX_ PL_no_func, "endgrent");
5357 if (!(tmps = PerlProc_getlogin()))
5359 PUSHp(tmps, strlen(tmps));
5362 DIE(aTHX_ PL_no_func, "getlogin");
5366 /* Miscellaneous. */
5371 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5372 register I32 items = SP - MARK;
5373 unsigned long a[20];
5378 while (++MARK <= SP) {
5379 if (SvTAINTED(*MARK)) {
5385 TAINT_PROPER("syscall");
5388 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5389 * or where sizeof(long) != sizeof(char*). But such machines will
5390 * not likely have syscall implemented either, so who cares?
5392 while (++MARK <= SP) {
5393 if (SvNIOK(*MARK) || !i)
5394 a[i++] = SvIV(*MARK);
5395 else if (*MARK == &PL_sv_undef)
5398 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5404 DIE(aTHX_ "Too many args to syscall");
5406 DIE(aTHX_ "Too few args to syscall");
5408 retval = syscall(a[0]);
5411 retval = syscall(a[0],a[1]);
5414 retval = syscall(a[0],a[1],a[2]);
5417 retval = syscall(a[0],a[1],a[2],a[3]);
5420 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5423 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5426 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5429 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5433 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5436 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5439 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5443 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5447 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5451 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5452 a[10],a[11],a[12],a[13]);
5454 #endif /* atarist */
5460 DIE(aTHX_ PL_no_func, "syscall");
5464 #ifdef FCNTL_EMULATE_FLOCK
5466 /* XXX Emulate flock() with fcntl().
5467 What's really needed is a good file locking module.
5471 fcntl_emulate_flock(int fd, int operation)
5475 switch (operation & ~LOCK_NB) {
5477 flock.l_type = F_RDLCK;
5480 flock.l_type = F_WRLCK;
5483 flock.l_type = F_UNLCK;
5489 flock.l_whence = SEEK_SET;
5490 flock.l_start = flock.l_len = (Off_t)0;
5492 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5495 #endif /* FCNTL_EMULATE_FLOCK */
5497 #ifdef LOCKF_EMULATE_FLOCK
5499 /* XXX Emulate flock() with lockf(). This is just to increase
5500 portability of scripts. The calls are not completely
5501 interchangeable. What's really needed is a good file
5505 /* The lockf() constants might have been defined in <unistd.h>.
5506 Unfortunately, <unistd.h> causes troubles on some mixed
5507 (BSD/POSIX) systems, such as SunOS 4.1.3.
5509 Further, the lockf() constants aren't POSIX, so they might not be
5510 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5511 just stick in the SVID values and be done with it. Sigh.
5515 # define F_ULOCK 0 /* Unlock a previously locked region */
5518 # define F_LOCK 1 /* Lock a region for exclusive use */
5521 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5524 # define F_TEST 3 /* Test a region for other processes locks */
5528 lockf_emulate_flock(int fd, int operation)
5531 const int save_errno = errno;
5534 /* flock locks entire file so for lockf we need to do the same */
5535 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5536 if (pos > 0) /* is seekable and needs to be repositioned */
5537 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5538 pos = -1; /* seek failed, so don't seek back afterwards */
5541 switch (operation) {
5543 /* LOCK_SH - get a shared lock */
5545 /* LOCK_EX - get an exclusive lock */
5547 i = lockf (fd, F_LOCK, 0);
5550 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5551 case LOCK_SH|LOCK_NB:
5552 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5553 case LOCK_EX|LOCK_NB:
5554 i = lockf (fd, F_TLOCK, 0);
5556 if ((errno == EAGAIN) || (errno == EACCES))
5557 errno = EWOULDBLOCK;
5560 /* LOCK_UN - unlock (non-blocking is a no-op) */
5562 case LOCK_UN|LOCK_NB:
5563 i = lockf (fd, F_ULOCK, 0);
5566 /* Default - can't decipher operation */
5573 if (pos > 0) /* need to restore position of the handle */
5574 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5579 #endif /* LOCKF_EMULATE_FLOCK */
5583 * c-indentation-style: bsd
5585 * indent-tabs-mode: t
5588 * ex: set ts=8 sts=4 sw=4 noet: