3 * Copyright (C) 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * But only a short way ahead its floor and the walls on either side were
13 * cloven by a great fissure, out of which the red glare came, now leaping
14 * up, now dying down into darkness; and all the while far below there was
15 * a rumour and a trouble as of great engines throbbing and labouring.
18 /* This file contains system pp ("push/pop") functions that
19 * execute the opcodes that make up a perl program. A typical pp function
20 * expects to find its arguments on the stack, and usually pushes its
21 * results onto the stack, hence the 'pp' terminology. Each OP structure
22 * contains a pointer to the relevant pp_foo() function.
24 * By 'system', we mean ops which interact with the OS, such as pp_open().
28 #define PERL_IN_PP_SYS_C
32 /* Shadow password support for solaris - pdo@cs.umd.edu
33 * Not just Solaris: at least HP-UX, IRIX, Linux.
34 * The API is from SysV.
36 * There are at least two more shadow interfaces,
37 * see the comments in pp_gpwent().
41 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
42 * and another MAXINT from "perl.h" <- <sys/param.h>. */
49 # include <sys/wait.h>
53 # include <sys/resource.h>
62 # include <sys/select.h>
66 /* XXX Configure test needed.
67 h_errno might not be a simple 'int', especially for multi-threaded
68 applications, see "extern int errno in perl.h". Creating such
69 a test requires taking into account the differences between
70 compiling multithreaded and singlethreaded ($ccflags et al).
71 HOST_NOT_FOUND is typically defined in <netdb.h>.
73 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
82 struct passwd *getpwnam (char *);
83 struct passwd *getpwuid (Uid_t);
88 struct passwd *getpwent (void);
89 #elif defined (VMS) && defined (my_getpwent)
90 struct passwd *Perl_my_getpwent (pTHX);
99 struct group *getgrnam (char *);
100 struct group *getgrgid (Gid_t);
104 struct group *getgrent (void);
110 # if defined(_MSC_VER) || defined(__MINGW32__)
111 # include <sys/utime.h>
118 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
121 # define my_chsize PerlLIO_chsize
124 # define my_chsize PerlLIO_chsize
126 I32 my_chsize(int fd, Off_t length);
132 #else /* no flock() */
134 /* fcntl.h might not have been included, even if it exists, because
135 the current Configure only sets I_FCNTL if it's needed to pick up
136 the *_OK constants. Make sure it has been included before testing
137 the fcntl() locking constants. */
138 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
142 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
143 # define FLOCK fcntl_emulate_flock
144 # define FCNTL_EMULATE_FLOCK
145 # else /* no flock() or fcntl(F_SETLK,...) */
147 # define FLOCK lockf_emulate_flock
148 # define LOCKF_EMULATE_FLOCK
150 # endif /* no flock() or fcntl(F_SETLK,...) */
153 static int FLOCK (int, int);
156 * These are the flock() constants. Since this sytems doesn't have
157 * flock(), the values of the constants are probably not available.
171 # endif /* emulating flock() */
173 #endif /* no flock() */
176 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
178 #if defined(I_SYS_ACCESS) && !defined(R_OK)
179 # include <sys/access.h>
182 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
183 # define FD_CLOEXEC 1 /* NeXT needs this */
189 /* Missing protos on LynxOS */
190 void sethostent(int);
191 void endhostent(void);
193 void endnetent(void);
194 void setprotoent(int);
195 void endprotoent(void);
196 void setservent(int);
197 void endservent(void);
200 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
202 /* AIX 5.2 and below use mktime for localtime, and defines the edge case
203 * for time 0x7fffffff to be valid only in UTC. AIX 5.3 provides localtime64
204 * available in the 32bit environment, which could warrant Configure
205 * checks in the future.
208 #define LOCALTIME_EDGECASE_BROKEN
211 /* F_OK unused: if stat() cannot find it... */
213 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
214 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
215 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
218 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
219 # ifdef I_SYS_SECURITY
220 # include <sys/security.h>
224 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
227 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
231 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
233 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
237 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
238 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
239 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
242 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
244 const Uid_t ruid = getuid();
245 const Uid_t euid = geteuid();
246 const Gid_t rgid = getgid();
247 const Gid_t egid = getegid();
251 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
252 Perl_croak(aTHX_ "switching effective uid is not implemented");
255 if (setreuid(euid, ruid))
258 if (setresuid(euid, ruid, (Uid_t)-1))
261 Perl_croak(aTHX_ "entering effective uid failed");
264 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
265 Perl_croak(aTHX_ "switching effective gid is not implemented");
268 if (setregid(egid, rgid))
271 if (setresgid(egid, rgid, (Gid_t)-1))
274 Perl_croak(aTHX_ "entering effective gid failed");
277 res = access(path, mode);
280 if (setreuid(ruid, euid))
283 if (setresuid(ruid, euid, (Uid_t)-1))
286 Perl_croak(aTHX_ "leaving effective uid failed");
289 if (setregid(rgid, egid))
292 if (setresgid(rgid, egid, (Gid_t)-1))
295 Perl_croak(aTHX_ "leaving effective gid failed");
300 # define PERL_EFF_ACCESS(p,f) (emulate_eaccess((p), (f)))
303 #if !defined(PERL_EFF_ACCESS)
304 /* With it or without it: anyway you get a warning: either that
305 it is unused, or it is declared static and never defined.
308 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
310 PERL_UNUSED_ARG(path);
311 PERL_UNUSED_ARG(mode);
312 Perl_croak(aTHX_ "switching effective uid is not implemented");
322 const char * const tmps = POPpconstx;
323 const I32 gimme = GIMME_V;
324 const char *mode = "r";
327 if (PL_op->op_private & OPpOPEN_IN_RAW)
329 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
331 fp = PerlProc_popen(tmps, mode);
333 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
335 PerlIO_apply_layers(aTHX_ fp,mode,type);
337 if (gimme == G_VOID) {
339 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
342 else if (gimme == G_SCALAR) {
345 PL_rs = &PL_sv_undef;
346 sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */
347 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
355 SV * const sv = newSV(79);
356 if (sv_gets(sv, fp, 0) == NULL) {
360 XPUSHs(sv_2mortal(sv));
361 if (SvLEN(sv) - SvCUR(sv) > 20) {
362 SvPV_shrink_to_cur(sv);
367 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
368 TAINT; /* "I believe that this is not gratuitous!" */
371 STATUS_NATIVE_CHILD_SET(-1);
372 if (gimme == G_SCALAR)
383 tryAMAGICunTARGET(iter, -1);
385 /* Note that we only ever get here if File::Glob fails to load
386 * without at the same time croaking, for some reason, or if
387 * perl was built with PERL_EXTERNAL_GLOB */
394 * The external globbing program may use things we can't control,
395 * so for security reasons we must assume the worst.
398 taint_proper(PL_no_security, "glob");
402 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
403 PL_last_in_gv = (GV*)*PL_stack_sp--;
405 SAVESPTR(PL_rs); /* This is not permanent, either. */
406 PL_rs = sv_2mortal(newSVpvs("\000"));
409 *SvPVX(PL_rs) = '\n';
413 result = do_readline();
421 PL_last_in_gv = cGVOP_gv;
422 return do_readline();
433 do_join(TARG, &PL_sv_no, MARK, SP);
437 else if (SP == MARK) {
444 tmps = SvPV_const(tmpsv, len);
445 if ((!tmps || !len) && PL_errgv) {
446 SV * const error = ERRSV;
447 SvUPGRADE(error, SVt_PV);
448 if (SvPOK(error) && SvCUR(error))
449 sv_catpvs(error, "\t...caught");
451 tmps = SvPV_const(tmpsv, len);
454 tmpsv = sv_2mortal(newSVpvs("Warning: something's wrong"));
456 Perl_warn(aTHX_ "%"SVf, (void*)tmpsv);
468 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
470 if (SP - MARK != 1) {
472 do_join(TARG, &PL_sv_no, MARK, SP);
474 tmps = SvPV_const(tmpsv, len);
480 tmps = SvROK(tmpsv) ? NULL : SvPV_const(tmpsv, len);
483 SV * const error = ERRSV;
484 SvUPGRADE(error, SVt_PV);
485 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
487 SvSetSV(error,tmpsv);
488 else if (sv_isobject(error)) {
489 HV * const stash = SvSTASH(SvRV(error));
490 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
492 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
493 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
500 call_sv((SV*)GvCV(gv),
501 G_SCALAR|G_EVAL|G_KEEPERR);
502 sv_setsv(error,*PL_stack_sp--);
508 if (SvPOK(error) && SvCUR(error))
509 sv_catpvs(error, "\t...propagated");
512 tmps = SvPV_const(tmpsv, len);
518 tmpsv = sv_2mortal(newSVpvs("Died"));
520 DIE(aTHX_ "%"SVf, (void*)tmpsv);
536 GV * const gv = (GV *)*++MARK;
539 DIE(aTHX_ PL_no_usym, "filehandle");
540 if ((io = GvIOp(gv))) {
542 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
544 mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
546 /* Method's args are same as ours ... */
547 /* ... except handle is replaced by the object */
548 *MARK-- = SvTIED_obj((SV*)io, mg);
552 call_method("OPEN", G_SCALAR);
566 tmps = SvPV_const(sv, len);
567 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
570 PUSHi( (I32)PL_forkprocess );
571 else if (PL_forkprocess == 0) /* we are a new child */
581 GV * const gv = (MAXARG == 0) ? PL_defoutgv : (GV*)POPs;
584 IO * const io = GvIO(gv);
586 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
589 XPUSHs(SvTIED_obj((SV*)io, mg));
592 call_method("CLOSE", G_SCALAR);
600 PUSHs(boolSV(do_close(gv, TRUE)));
613 GV * const wgv = (GV*)POPs;
614 GV * const rgv = (GV*)POPs;
619 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
620 DIE(aTHX_ PL_no_usym, "filehandle");
625 do_close(rgv, FALSE);
627 do_close(wgv, FALSE);
629 if (PerlProc_pipe(fd) < 0)
632 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
633 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
634 IoOFP(rstio) = IoIFP(rstio);
635 IoIFP(wstio) = IoOFP(wstio);
636 IoTYPE(rstio) = IoTYPE_RDONLY;
637 IoTYPE(wstio) = IoTYPE_WRONLY;
639 if (!IoIFP(rstio) || !IoOFP(wstio)) {
641 PerlIO_close(IoIFP(rstio));
643 PerlLIO_close(fd[0]);
645 PerlIO_close(IoOFP(wstio));
647 PerlLIO_close(fd[1]);
650 #if defined(HAS_FCNTL) && defined(F_SETFD)
651 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
652 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
659 DIE(aTHX_ PL_no_func, "pipe");
675 if (gv && (io = GvIO(gv))
676 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
679 XPUSHs(SvTIED_obj((SV*)io, mg));
682 call_method("FILENO", G_SCALAR);
688 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
689 /* Can't do this because people seem to do things like
690 defined(fileno($foo)) to check whether $foo is a valid fh.
691 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
692 report_evil_fh(gv, io, PL_op->op_type);
697 PUSHi(PerlIO_fileno(fp));
710 anum = PerlLIO_umask(0);
711 (void)PerlLIO_umask(anum);
714 anum = PerlLIO_umask(POPi);
715 TAINT_PROPER("umask");
718 /* Only DIE if trying to restrict permissions on "user" (self).
719 * Otherwise it's harmless and more useful to just return undef
720 * since 'group' and 'other' concepts probably don't exist here. */
721 if (MAXARG >= 1 && (POPi & 0700))
722 DIE(aTHX_ "umask not implemented");
723 XPUSHs(&PL_sv_undef);
744 if (gv && (io = GvIO(gv))) {
745 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
748 XPUSHs(SvTIED_obj((SV*)io, mg));
753 call_method("BINMODE", G_SCALAR);
761 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
762 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
763 report_evil_fh(gv, io, PL_op->op_type);
764 SETERRNO(EBADF,RMS_IFI);
770 const int mode = mode_from_discipline(discp);
771 const char *const d = (discp ? SvPV_nolen_const(discp) : NULL);
772 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
773 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
774 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
795 const I32 markoff = MARK - PL_stack_base;
796 const char *methname;
797 int how = PERL_MAGIC_tied;
801 switch(SvTYPE(varsv)) {
803 methname = "TIEHASH";
804 HvEITER_set((HV *)varsv, 0);
807 methname = "TIEARRAY";
810 #ifdef GV_UNIQUE_CHECK
811 if (GvUNIQUE((GV*)varsv)) {
812 Perl_croak(aTHX_ "Attempt to tie unique GV");
815 methname = "TIEHANDLE";
816 how = PERL_MAGIC_tiedscalar;
817 /* For tied filehandles, we apply tiedscalar magic to the IO
818 slot of the GP rather than the GV itself. AMS 20010812 */
820 GvIOp(varsv) = newIO();
821 varsv = (SV *)GvIOp(varsv);
824 methname = "TIESCALAR";
825 how = PERL_MAGIC_tiedscalar;
829 if (sv_isobject(*MARK)) {
831 PUSHSTACKi(PERLSI_MAGIC);
833 EXTEND(SP,(I32)items);
837 call_method(methname, G_SCALAR);
840 /* Not clear why we don't call call_method here too.
841 * perhaps to get different error message ?
843 stash = gv_stashsv(*MARK, FALSE);
844 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
845 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
846 methname, (void*)*MARK);
849 PUSHSTACKi(PERLSI_MAGIC);
851 EXTEND(SP,(I32)items);
855 call_sv((SV*)GvCV(gv), G_SCALAR);
861 if (sv_isobject(sv)) {
862 sv_unmagic(varsv, how);
863 /* Croak if a self-tie on an aggregate is attempted. */
864 if (varsv == SvRV(sv) &&
865 (SvTYPE(varsv) == SVt_PVAV ||
866 SvTYPE(varsv) == SVt_PVHV))
868 "Self-ties of arrays and hashes are not supported");
869 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
872 SP = PL_stack_base + markoff;
882 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
883 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
885 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
888 if ((mg = SvTIED_mg(sv, how))) {
889 SV * const obj = SvRV(SvTIED_obj(sv, mg));
891 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
893 if (gv && isGV(gv) && (cv = GvCV(gv))) {
895 XPUSHs(SvTIED_obj((SV*)gv, mg));
896 XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
899 call_sv((SV *)cv, G_VOID);
903 else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
904 Perl_warner(aTHX_ packWARN(WARN_UNTIE),
905 "untie attempted while %"UVuf" inner references still exist",
906 (UV)SvREFCNT(obj) - 1 ) ;
910 sv_unmagic(sv, how) ;
920 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
921 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
923 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
926 if ((mg = SvTIED_mg(sv, how))) {
927 SV *osv = SvTIED_obj(sv, mg);
928 if (osv == mg->mg_obj)
929 osv = sv_mortalcopy(osv);
943 HV * const hv = (HV*)POPs;
944 SV * const sv = sv_2mortal(newSVpvs("AnyDBM_File"));
945 stash = gv_stashsv(sv, FALSE);
946 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
948 require_pv("AnyDBM_File.pm");
950 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
951 DIE(aTHX_ "No dbm on this machine");
961 PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
963 PUSHs(sv_2mortal(newSVuv(O_RDWR)));
966 call_sv((SV*)GvCV(gv), G_SCALAR);
969 if (!sv_isobject(TOPs)) {
974 PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
977 call_sv((SV*)GvCV(gv), G_SCALAR);
981 if (sv_isobject(TOPs)) {
982 sv_unmagic((SV *) hv, PERL_MAGIC_tied);
983 sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, NULL, 0);
1000 struct timeval timebuf;
1001 struct timeval *tbuf = &timebuf;
1004 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1009 # if BYTEORDER & 0xf0000
1010 # define ORDERBYTE (0x88888888 - BYTEORDER)
1012 # define ORDERBYTE (0x4444 - BYTEORDER)
1018 for (i = 1; i <= 3; i++) {
1019 SV * const sv = SP[i];
1022 if (SvREADONLY(sv)) {
1024 sv_force_normal_flags(sv, 0);
1025 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1026 DIE(aTHX_ PL_no_modify);
1029 if (ckWARN(WARN_MISC))
1030 Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1031 SvPV_force_nolen(sv); /* force string conversion */
1038 /* little endians can use vecs directly */
1039 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1046 masksize = NFDBITS / NBBY;
1048 masksize = sizeof(long); /* documented int, everyone seems to use long */
1050 Zero(&fd_sets[0], 4, char*);
1053 # if SELECT_MIN_BITS == 1
1054 growsize = sizeof(fd_set);
1056 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1057 # undef SELECT_MIN_BITS
1058 # define SELECT_MIN_BITS __FD_SETSIZE
1060 /* If SELECT_MIN_BITS is greater than one we most probably will want
1061 * to align the sizes with SELECT_MIN_BITS/8 because for example
1062 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1063 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1064 * on (sets/tests/clears bits) is 32 bits. */
1065 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1073 timebuf.tv_sec = (long)value;
1074 value -= (NV)timebuf.tv_sec;
1075 timebuf.tv_usec = (long)(value * 1000000.0);
1080 for (i = 1; i <= 3; i++) {
1082 if (!SvOK(sv) || SvCUR(sv) == 0) {
1089 Sv_Grow(sv, growsize);
1093 while (++j <= growsize) {
1097 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1099 Newx(fd_sets[i], growsize, char);
1100 for (offset = 0; offset < growsize; offset += masksize) {
1101 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1102 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1105 fd_sets[i] = SvPVX(sv);
1109 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1110 /* Can't make just the (void*) conditional because that would be
1111 * cpp #if within cpp macro, and not all compilers like that. */
1112 nfound = PerlSock_select(
1114 (Select_fd_set_t) fd_sets[1],
1115 (Select_fd_set_t) fd_sets[2],
1116 (Select_fd_set_t) fd_sets[3],
1117 (void*) tbuf); /* Workaround for compiler bug. */
1119 nfound = PerlSock_select(
1121 (Select_fd_set_t) fd_sets[1],
1122 (Select_fd_set_t) fd_sets[2],
1123 (Select_fd_set_t) fd_sets[3],
1126 for (i = 1; i <= 3; i++) {
1129 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1131 for (offset = 0; offset < growsize; offset += masksize) {
1132 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1133 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1135 Safefree(fd_sets[i]);
1142 if (GIMME == G_ARRAY && tbuf) {
1143 value = (NV)(timebuf.tv_sec) +
1144 (NV)(timebuf.tv_usec) / 1000000.0;
1145 PUSHs(sv_2mortal(newSVnv(value)));
1149 DIE(aTHX_ "select not implemented");
1154 Perl_setdefout(pTHX_ GV *gv)
1157 SvREFCNT_inc_simple_void(gv);
1159 SvREFCNT_dec(PL_defoutgv);
1167 GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : NULL;
1168 GV * egv = GvEGV(PL_defoutgv);
1174 XPUSHs(&PL_sv_undef);
1176 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1177 if (gvp && *gvp == egv) {
1178 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1182 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1187 if (!GvIO(newdefout))
1188 gv_IOadd(newdefout);
1189 setdefout(newdefout);
1199 GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs;
1201 if (gv && (io = GvIO(gv))) {
1202 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1204 const I32 gimme = GIMME_V;
1206 XPUSHs(SvTIED_obj((SV*)io, mg));
1209 call_method("GETC", gimme);
1212 if (gimme == G_SCALAR)
1213 SvSetMagicSV_nosteal(TARG, TOPs);
1217 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1218 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1219 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1220 report_evil_fh(gv, io, PL_op->op_type);
1221 SETERRNO(EBADF,RMS_IFI);
1225 sv_setpvn(TARG, " ", 1);
1226 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1227 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1228 /* Find out how many bytes the char needs */
1229 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1232 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1233 SvCUR_set(TARG,1+len);
1242 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1245 register PERL_CONTEXT *cx;
1246 const I32 gimme = GIMME_V;
1251 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1253 cx->blk_sub.retop = retop;
1255 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1257 setdefout(gv); /* locally select filehandle so $% et al work */
1289 goto not_a_format_reference;
1294 tmpsv = sv_newmortal();
1295 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1296 name = SvPV_nolen_const(tmpsv);
1298 DIE(aTHX_ "Undefined format \"%s\" called", name);
1300 not_a_format_reference:
1301 DIE(aTHX_ "Not a format reference");
1304 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1306 IoFLAGS(io) &= ~IOf_DIDTOP;
1307 return doform(cv,gv,PL_op->op_next);
1313 GV * const gv = cxstack[cxstack_ix].blk_sub.gv;
1314 register IO * const io = GvIOp(gv);
1319 register PERL_CONTEXT *cx;
1321 if (!io || !(ofp = IoOFP(io)))
1324 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1325 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1327 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1328 PL_formtarget != PL_toptarget)
1332 if (!IoTOP_GV(io)) {
1335 if (!IoTOP_NAME(io)) {
1337 if (!IoFMT_NAME(io))
1338 IoFMT_NAME(io) = savepv(GvNAME(gv));
1339 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1340 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1341 if ((topgv && GvFORM(topgv)) ||
1342 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1343 IoTOP_NAME(io) = savesvpv(topname);
1345 IoTOP_NAME(io) = savepvs("top");
1347 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1348 if (!topgv || !GvFORM(topgv)) {
1349 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1352 IoTOP_GV(io) = topgv;
1354 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1355 I32 lines = IoLINES_LEFT(io);
1356 const char *s = SvPVX_const(PL_formtarget);
1357 if (lines <= 0) /* Yow, header didn't even fit!!! */
1359 while (lines-- > 0) {
1360 s = strchr(s, '\n');
1366 const STRLEN save = SvCUR(PL_formtarget);
1367 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1368 do_print(PL_formtarget, ofp);
1369 SvCUR_set(PL_formtarget, save);
1370 sv_chop(PL_formtarget, s);
1371 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1374 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1375 do_print(PL_formfeed, ofp);
1376 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1378 PL_formtarget = PL_toptarget;
1379 IoFLAGS(io) |= IOf_DIDTOP;
1382 DIE(aTHX_ "bad top format reference");
1385 SV * const sv = sv_newmortal();
1387 gv_efullname4(sv, fgv, NULL, FALSE);
1388 name = SvPV_nolen_const(sv);
1390 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1392 DIE(aTHX_ "Undefined top format called");
1394 if (cv && CvCLONE(cv))
1395 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1396 return doform(cv, gv, PL_op);
1400 POPBLOCK(cx,PL_curpm);
1406 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1408 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1409 else if (ckWARN(WARN_CLOSED))
1410 report_evil_fh(gv, io, PL_op->op_type);
1415 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1416 if (ckWARN(WARN_IO))
1417 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1419 if (!do_print(PL_formtarget, fp))
1422 FmLINES(PL_formtarget) = 0;
1423 SvCUR_set(PL_formtarget, 0);
1424 *SvEND(PL_formtarget) = '\0';
1425 if (IoFLAGS(io) & IOf_FLUSH)
1426 (void)PerlIO_flush(fp);
1431 PL_formtarget = PL_bodytarget;
1433 PERL_UNUSED_VAR(newsp);
1434 PERL_UNUSED_VAR(gimme);
1435 return cx->blk_sub.retop;
1440 dVAR; dSP; dMARK; dORIGMARK;
1445 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
1447 if (gv && (io = GvIO(gv))) {
1448 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1450 if (MARK == ORIGMARK) {
1453 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1457 *MARK = SvTIED_obj((SV*)io, mg);
1460 call_method("PRINTF", G_SCALAR);
1463 MARK = ORIGMARK + 1;
1471 if (!(io = GvIO(gv))) {
1472 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1473 report_evil_fh(gv, io, PL_op->op_type);
1474 SETERRNO(EBADF,RMS_IFI);
1477 else if (!(fp = IoOFP(io))) {
1478 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1480 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1481 else if (ckWARN(WARN_CLOSED))
1482 report_evil_fh(gv, io, PL_op->op_type);
1484 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1488 if (SvTAINTED(MARK[1]))
1489 TAINT_PROPER("printf");
1490 do_sprintf(sv, SP - MARK, MARK + 1);
1491 if (!do_print(sv, fp))
1494 if (IoFLAGS(io) & IOf_FLUSH)
1495 if (PerlIO_flush(fp) == EOF)
1506 PUSHs(&PL_sv_undef);
1514 const int perm = (MAXARG > 3) ? POPi : 0666;
1515 const int mode = POPi;
1516 SV * const sv = POPs;
1517 GV * const gv = (GV *)POPs;
1520 /* Need TIEHANDLE method ? */
1521 const char * const tmps = SvPV_const(sv, len);
1522 /* FIXME? do_open should do const */
1523 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1524 IoLINES(GvIOp(gv)) = 0;
1528 PUSHs(&PL_sv_undef);
1535 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1541 Sock_size_t bufsize;
1549 bool charstart = FALSE;
1550 STRLEN charskip = 0;
1553 GV * const gv = (GV*)*++MARK;
1554 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1555 && gv && (io = GvIO(gv)) )
1557 const MAGIC * mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1561 *MARK = SvTIED_obj((SV*)io, mg);
1563 call_method("READ", G_SCALAR);
1577 sv_setpvn(bufsv, "", 0);
1578 length = SvIVx(*++MARK);
1581 offset = SvIVx(*++MARK);
1585 if (!io || !IoIFP(io)) {
1586 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1587 report_evil_fh(gv, io, PL_op->op_type);
1588 SETERRNO(EBADF,RMS_IFI);
1591 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1592 buffer = SvPVutf8_force(bufsv, blen);
1593 /* UTF-8 may not have been set if they are all low bytes */
1598 buffer = SvPV_force(bufsv, blen);
1599 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1602 DIE(aTHX_ "Negative length");
1610 if (PL_op->op_type == OP_RECV) {
1611 char namebuf[MAXPATHLEN];
1612 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1613 bufsize = sizeof (struct sockaddr_in);
1615 bufsize = sizeof namebuf;
1617 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1621 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1622 /* 'offset' means 'flags' here */
1623 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1624 (struct sockaddr *)namebuf, &bufsize);
1628 /* Bogus return without padding */
1629 bufsize = sizeof (struct sockaddr_in);
1631 SvCUR_set(bufsv, count);
1632 *SvEND(bufsv) = '\0';
1633 (void)SvPOK_only(bufsv);
1637 /* This should not be marked tainted if the fp is marked clean */
1638 if (!(IoFLAGS(io) & IOf_UNTAINT))
1639 SvTAINTED_on(bufsv);
1641 sv_setpvn(TARG, namebuf, bufsize);
1646 if (PL_op->op_type == OP_RECV)
1647 DIE(aTHX_ PL_no_sock_func, "recv");
1649 if (DO_UTF8(bufsv)) {
1650 /* offset adjust in characters not bytes */
1651 blen = sv_len_utf8(bufsv);
1654 if (-offset > (int)blen)
1655 DIE(aTHX_ "Offset outside string");
1658 if (DO_UTF8(bufsv)) {
1659 /* convert offset-as-chars to offset-as-bytes */
1660 if (offset >= (int)blen)
1661 offset += SvCUR(bufsv) - blen;
1663 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1666 bufsize = SvCUR(bufsv);
1667 /* Allocating length + offset + 1 isn't perfect in the case of reading
1668 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1670 (should be 2 * length + offset + 1, or possibly something longer if
1671 PL_encoding is true) */
1672 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1673 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1674 Zero(buffer+bufsize, offset-bufsize, char);
1676 buffer = buffer + offset;
1678 read_target = bufsv;
1680 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1681 concatenate it to the current buffer. */
1683 /* Truncate the existing buffer to the start of where we will be
1685 SvCUR_set(bufsv, offset);
1687 read_target = sv_newmortal();
1688 SvUPGRADE(read_target, SVt_PV);
1689 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1692 if (PL_op->op_type == OP_SYSREAD) {
1693 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1694 if (IoTYPE(io) == IoTYPE_SOCKET) {
1695 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1701 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1706 #ifdef HAS_SOCKET__bad_code_maybe
1707 if (IoTYPE(io) == IoTYPE_SOCKET) {
1708 char namebuf[MAXPATHLEN];
1709 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1710 bufsize = sizeof (struct sockaddr_in);
1712 bufsize = sizeof namebuf;
1714 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1715 (struct sockaddr *)namebuf, &bufsize);
1720 count = PerlIO_read(IoIFP(io), buffer, length);
1721 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1722 if (count == 0 && PerlIO_error(IoIFP(io)))
1726 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1727 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1730 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1731 *SvEND(read_target) = '\0';
1732 (void)SvPOK_only(read_target);
1733 if (fp_utf8 && !IN_BYTES) {
1734 /* Look at utf8 we got back and count the characters */
1735 const char *bend = buffer + count;
1736 while (buffer < bend) {
1738 skip = UTF8SKIP(buffer);
1741 if (buffer - charskip + skip > bend) {
1742 /* partial character - try for rest of it */
1743 length = skip - (bend-buffer);
1744 offset = bend - SvPVX_const(bufsv);
1756 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1757 provided amount read (count) was what was requested (length)
1759 if (got < wanted && count == length) {
1760 length = wanted - got;
1761 offset = bend - SvPVX_const(bufsv);
1764 /* return value is character count */
1768 else if (buffer_utf8) {
1769 /* Let svcatsv upgrade the bytes we read in to utf8.
1770 The buffer is a mortal so will be freed soon. */
1771 sv_catsv_nomg(bufsv, read_target);
1774 /* This should not be marked tainted if the fp is marked clean */
1775 if (!(IoFLAGS(io) & IOf_UNTAINT))
1776 SvTAINTED_on(bufsv);
1788 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1794 STRLEN orig_blen_bytes;
1795 const int op_type = PL_op->op_type;
1799 GV *const gv = (GV*)*++MARK;
1800 if (PL_op->op_type == OP_SYSWRITE
1801 && gv && (io = GvIO(gv))) {
1802 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1806 if (MARK == SP - 1) {
1808 sv = sv_2mortal(newSViv(sv_len(*SP)));
1814 *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg);
1816 call_method("WRITE", G_SCALAR);
1832 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1834 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1835 if (io && IoIFP(io))
1836 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1838 report_evil_fh(gv, io, PL_op->op_type);
1840 SETERRNO(EBADF,RMS_IFI);
1844 /* Do this first to trigger any overloading. */
1845 buffer = SvPV_const(bufsv, blen);
1846 orig_blen_bytes = blen;
1847 doing_utf8 = DO_UTF8(bufsv);
1849 if (PerlIO_isutf8(IoIFP(io))) {
1850 if (!SvUTF8(bufsv)) {
1851 /* We don't modify the original scalar. */
1852 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1853 buffer = (char *) tmpbuf;
1857 else if (doing_utf8) {
1858 STRLEN tmplen = blen;
1859 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1862 buffer = (char *) tmpbuf;
1866 assert((char *)result == buffer);
1867 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1871 if (op_type == OP_SYSWRITE) {
1872 Size_t length = 0; /* This length is in characters. */
1878 /* The SV is bytes, and we've had to upgrade it. */
1879 blen_chars = orig_blen_bytes;
1881 /* The SV really is UTF-8. */
1882 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1883 /* Don't call sv_len_utf8 again because it will call magic
1884 or overloading a second time, and we might get back a
1885 different result. */
1886 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1888 /* It's safe, and it may well be cached. */
1889 blen_chars = sv_len_utf8(bufsv);
1897 length = blen_chars;
1899 #if Size_t_size > IVSIZE
1900 length = (Size_t)SvNVx(*++MARK);
1902 length = (Size_t)SvIVx(*++MARK);
1904 if ((SSize_t)length < 0) {
1906 DIE(aTHX_ "Negative length");
1911 offset = SvIVx(*++MARK);
1913 if (-offset > (IV)blen_chars) {
1915 DIE(aTHX_ "Offset outside string");
1917 offset += blen_chars;
1918 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1920 DIE(aTHX_ "Offset outside string");
1924 if (length > blen_chars - offset)
1925 length = blen_chars - offset;
1927 /* Here we convert length from characters to bytes. */
1928 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1929 /* Either we had to convert the SV, or the SV is magical, or
1930 the SV has overloading, in which case we can't or mustn't
1931 or mustn't call it again. */
1933 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1934 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1936 /* It's a real UTF-8 SV, and it's not going to change under
1937 us. Take advantage of any cache. */
1939 I32 len_I32 = length;
1941 /* Convert the start and end character positions to bytes.
1942 Remember that the second argument to sv_pos_u2b is relative
1944 sv_pos_u2b(bufsv, &start, &len_I32);
1951 buffer = buffer+offset;
1953 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1954 if (IoTYPE(io) == IoTYPE_SOCKET) {
1955 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1961 /* See the note at doio.c:do_print about filesize limits. --jhi */
1962 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1968 const int flags = SvIVx(*++MARK);
1971 char * const sockbuf = SvPVx(*++MARK, mlen);
1972 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1973 flags, (struct sockaddr *)sockbuf, mlen);
1977 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1982 DIE(aTHX_ PL_no_sock_func, "send");
1989 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
1992 #if Size_t_size > IVSIZE
2011 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
2013 gv = PL_last_in_gv = GvEGV(PL_argvgv);
2015 if (io && !IoIFP(io)) {
2016 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2018 IoFLAGS(io) &= ~IOf_START;
2019 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2020 sv_setpvn(GvSV(gv), "-", 1);
2021 SvSETMAGIC(GvSV(gv));
2023 else if (!nextargv(gv))
2028 gv = PL_last_in_gv; /* eof */
2031 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
2034 IO * const io = GvIO(gv);
2036 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
2038 XPUSHs(SvTIED_obj((SV*)io, mg));
2041 call_method("EOF", G_SCALAR);
2048 PUSHs(boolSV(!gv || do_eof(gv)));
2059 PL_last_in_gv = (GV*)POPs;
2062 if (gv && (io = GvIO(gv))) {
2063 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2066 XPUSHs(SvTIED_obj((SV*)io, mg));
2069 call_method("TELL", G_SCALAR);
2076 #if LSEEKSIZE > IVSIZE
2077 PUSHn( do_tell(gv) );
2079 PUSHi( do_tell(gv) );
2087 const int whence = POPi;
2088 #if LSEEKSIZE > IVSIZE
2089 const Off_t offset = (Off_t)SvNVx(POPs);
2091 const Off_t offset = (Off_t)SvIVx(POPs);
2094 GV * const gv = PL_last_in_gv = (GV*)POPs;
2097 if (gv && (io = GvIO(gv))) {
2098 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2101 XPUSHs(SvTIED_obj((SV*)io, mg));
2102 #if LSEEKSIZE > IVSIZE
2103 XPUSHs(sv_2mortal(newSVnv((NV) offset)));
2105 XPUSHs(sv_2mortal(newSViv(offset)));
2107 XPUSHs(sv_2mortal(newSViv(whence)));
2110 call_method("SEEK", G_SCALAR);
2117 if (PL_op->op_type == OP_SEEK)
2118 PUSHs(boolSV(do_seek(gv, offset, whence)));
2120 const Off_t sought = do_sysseek(gv, offset, whence);
2122 PUSHs(&PL_sv_undef);
2124 SV* const sv = sought ?
2125 #if LSEEKSIZE > IVSIZE
2130 : newSVpvn(zero_but_true, ZBTLEN);
2131 PUSHs(sv_2mortal(sv));
2141 /* There seems to be no consensus on the length type of truncate()
2142 * and ftruncate(), both off_t and size_t have supporters. In
2143 * general one would think that when using large files, off_t is
2144 * at least as wide as size_t, so using an off_t should be okay. */
2145 /* XXX Configure probe for the length type of *truncate() needed XXX */
2148 #if Off_t_size > IVSIZE
2153 /* Checking for length < 0 is problematic as the type might or
2154 * might not be signed: if it is not, clever compilers will moan. */
2155 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2162 if (PL_op->op_flags & OPf_SPECIAL) {
2163 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2172 TAINT_PROPER("truncate");
2173 if (!(fp = IoIFP(io))) {
2179 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2181 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2188 SV * const sv = POPs;
2191 if (SvTYPE(sv) == SVt_PVGV) {
2192 tmpgv = (GV*)sv; /* *main::FRED for example */
2193 goto do_ftruncate_gv;
2195 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2196 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
2197 goto do_ftruncate_gv;
2199 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2200 io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
2201 goto do_ftruncate_io;
2204 name = SvPV_nolen_const(sv);
2205 TAINT_PROPER("truncate");
2207 if (truncate(name, len) < 0)
2211 const int tmpfd = PerlLIO_open(name, O_RDWR);
2216 if (my_chsize(tmpfd, len) < 0)
2218 PerlLIO_close(tmpfd);
2227 SETERRNO(EBADF,RMS_IFI);
2235 SV * const argsv = POPs;
2236 const unsigned int func = POPu;
2237 const int optype = PL_op->op_type;
2238 GV * const gv = (GV*)POPs;
2239 IO * const io = gv ? GvIOn(gv) : NULL;
2243 if (!io || !argsv || !IoIFP(io)) {
2244 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2245 report_evil_fh(gv, io, PL_op->op_type);
2246 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2250 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2253 s = SvPV_force(argsv, len);
2254 need = IOCPARM_LEN(func);
2256 s = Sv_Grow(argsv, need + 1);
2257 SvCUR_set(argsv, need);
2260 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2263 retval = SvIV(argsv);
2264 s = INT2PTR(char*,retval); /* ouch */
2267 TAINT_PROPER(PL_op_desc[optype]);
2269 if (optype == OP_IOCTL)
2271 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2273 DIE(aTHX_ "ioctl is not implemented");
2277 DIE(aTHX_ "fcntl is not implemented");
2279 #if defined(OS2) && defined(__EMX__)
2280 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2282 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2286 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2288 if (s[SvCUR(argsv)] != 17)
2289 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2291 s[SvCUR(argsv)] = 0; /* put our null back */
2292 SvSETMAGIC(argsv); /* Assume it has changed */
2301 PUSHp(zero_but_true, ZBTLEN);
2314 const int argtype = POPi;
2315 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
2317 if (gv && (io = GvIO(gv)))
2323 /* XXX Looks to me like io is always NULL at this point */
2325 (void)PerlIO_flush(fp);
2326 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2329 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2330 report_evil_fh(gv, io, PL_op->op_type);
2332 SETERRNO(EBADF,RMS_IFI);
2337 DIE(aTHX_ PL_no_func, "flock()");
2347 const int protocol = POPi;
2348 const int type = POPi;
2349 const int domain = POPi;
2350 GV * const gv = (GV*)POPs;
2351 register IO * const io = gv ? GvIOn(gv) : NULL;
2355 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2356 report_evil_fh(gv, io, PL_op->op_type);
2357 if (io && IoIFP(io))
2358 do_close(gv, FALSE);
2359 SETERRNO(EBADF,LIB_INVARG);
2364 do_close(gv, FALSE);
2366 TAINT_PROPER("socket");
2367 fd = PerlSock_socket(domain, type, protocol);
2370 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2371 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2372 IoTYPE(io) = IoTYPE_SOCKET;
2373 if (!IoIFP(io) || !IoOFP(io)) {
2374 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2375 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2376 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2379 #if defined(HAS_FCNTL) && defined(F_SETFD)
2380 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2384 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2389 DIE(aTHX_ PL_no_sock_func, "socket");
2395 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2397 const int protocol = POPi;
2398 const int type = POPi;
2399 const int domain = POPi;
2400 GV * const gv2 = (GV*)POPs;
2401 GV * const gv1 = (GV*)POPs;
2402 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2403 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2406 if (!gv1 || !gv2 || !io1 || !io2) {
2407 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2409 report_evil_fh(gv1, io1, PL_op->op_type);
2411 report_evil_fh(gv1, io2, PL_op->op_type);
2413 if (io1 && IoIFP(io1))
2414 do_close(gv1, FALSE);
2415 if (io2 && IoIFP(io2))
2416 do_close(gv2, FALSE);
2421 do_close(gv1, FALSE);
2423 do_close(gv2, FALSE);
2425 TAINT_PROPER("socketpair");
2426 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2428 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2429 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2430 IoTYPE(io1) = IoTYPE_SOCKET;
2431 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2432 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2433 IoTYPE(io2) = IoTYPE_SOCKET;
2434 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2435 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2436 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2437 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2438 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2439 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2440 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2443 #if defined(HAS_FCNTL) && defined(F_SETFD)
2444 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2445 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2450 DIE(aTHX_ PL_no_sock_func, "socketpair");
2458 SV * const addrsv = POPs;
2459 /* OK, so on what platform does bind modify addr? */
2461 GV * const gv = (GV*)POPs;
2462 register IO * const io = GvIOn(gv);
2465 if (!io || !IoIFP(io))
2468 addr = SvPV_const(addrsv, len);
2469 TAINT_PROPER("bind");
2470 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2476 if (ckWARN(WARN_CLOSED))
2477 report_evil_fh(gv, io, PL_op->op_type);
2478 SETERRNO(EBADF,SS_IVCHAN);
2481 DIE(aTHX_ PL_no_sock_func, "bind");
2489 SV * const addrsv = POPs;
2490 GV * const gv = (GV*)POPs;
2491 register IO * const io = GvIOn(gv);
2495 if (!io || !IoIFP(io))
2498 addr = SvPV_const(addrsv, len);
2499 TAINT_PROPER("connect");
2500 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2506 if (ckWARN(WARN_CLOSED))
2507 report_evil_fh(gv, io, PL_op->op_type);
2508 SETERRNO(EBADF,SS_IVCHAN);
2511 DIE(aTHX_ PL_no_sock_func, "connect");
2519 const int backlog = POPi;
2520 GV * const gv = (GV*)POPs;
2521 register IO * const io = gv ? GvIOn(gv) : NULL;
2523 if (!gv || !io || !IoIFP(io))
2526 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2532 if (ckWARN(WARN_CLOSED))
2533 report_evil_fh(gv, io, PL_op->op_type);
2534 SETERRNO(EBADF,SS_IVCHAN);
2537 DIE(aTHX_ PL_no_sock_func, "listen");
2547 char namebuf[MAXPATHLEN];
2548 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2549 Sock_size_t len = sizeof (struct sockaddr_in);
2551 Sock_size_t len = sizeof namebuf;
2553 GV * const ggv = (GV*)POPs;
2554 GV * const ngv = (GV*)POPs;
2563 if (!gstio || !IoIFP(gstio))
2567 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2570 /* Some platforms indicate zero length when an AF_UNIX client is
2571 * not bound. Simulate a non-zero-length sockaddr structure in
2573 namebuf[0] = 0; /* sun_len */
2574 namebuf[1] = AF_UNIX; /* sun_family */
2582 do_close(ngv, FALSE);
2583 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2584 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2585 IoTYPE(nstio) = IoTYPE_SOCKET;
2586 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2587 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2588 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2589 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2592 #if defined(HAS_FCNTL) && defined(F_SETFD)
2593 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2597 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2598 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2600 #ifdef __SCO_VERSION__
2601 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2604 PUSHp(namebuf, len);
2608 if (ckWARN(WARN_CLOSED))
2609 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2610 SETERRNO(EBADF,SS_IVCHAN);
2616 DIE(aTHX_ PL_no_sock_func, "accept");
2624 const int how = POPi;
2625 GV * const gv = (GV*)POPs;
2626 register IO * const io = GvIOn(gv);
2628 if (!io || !IoIFP(io))
2631 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2635 if (ckWARN(WARN_CLOSED))
2636 report_evil_fh(gv, io, PL_op->op_type);
2637 SETERRNO(EBADF,SS_IVCHAN);
2640 DIE(aTHX_ PL_no_sock_func, "shutdown");
2648 const int optype = PL_op->op_type;
2649 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2650 const unsigned int optname = (unsigned int) POPi;
2651 const unsigned int lvl = (unsigned int) POPi;
2652 GV * const gv = (GV*)POPs;
2653 register IO * const io = GvIOn(gv);
2657 if (!io || !IoIFP(io))
2660 fd = PerlIO_fileno(IoIFP(io));
2664 (void)SvPOK_only(sv);
2668 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2675 #if defined(__SYMBIAN32__)
2676 # define SETSOCKOPT_OPTION_VALUE_T void *
2678 # define SETSOCKOPT_OPTION_VALUE_T const char *
2680 /* XXX TODO: We need to have a proper type (a Configure probe,
2681 * etc.) for what the C headers think of the third argument of
2682 * setsockopt(), the option_value read-only buffer: is it
2683 * a "char *", or a "void *", const or not. Some compilers
2684 * don't take kindly to e.g. assuming that "char *" implicitly
2685 * promotes to a "void *", or to explicitly promoting/demoting
2686 * consts to non/vice versa. The "const void *" is the SUS
2687 * definition, but that does not fly everywhere for the above
2689 SETSOCKOPT_OPTION_VALUE_T buf;
2693 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2697 aint = (int)SvIV(sv);
2698 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2701 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2710 if (ckWARN(WARN_CLOSED))
2711 report_evil_fh(gv, io, optype);
2712 SETERRNO(EBADF,SS_IVCHAN);
2717 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2725 const int optype = PL_op->op_type;
2726 GV * const gv = (GV*)POPs;
2727 register IO * const io = GvIOn(gv);
2732 if (!io || !IoIFP(io))
2735 sv = sv_2mortal(newSV(257));
2736 (void)SvPOK_only(sv);
2740 fd = PerlIO_fileno(IoIFP(io));
2742 case OP_GETSOCKNAME:
2743 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2746 case OP_GETPEERNAME:
2747 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2749 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2751 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";
2752 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2753 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2754 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2755 sizeof(u_short) + sizeof(struct in_addr))) {
2762 #ifdef BOGUS_GETNAME_RETURN
2763 /* Interactive Unix, getpeername() and getsockname()
2764 does not return valid namelen */
2765 if (len == BOGUS_GETNAME_RETURN)
2766 len = sizeof(struct sockaddr);
2774 if (ckWARN(WARN_CLOSED))
2775 report_evil_fh(gv, io, optype);
2776 SETERRNO(EBADF,SS_IVCHAN);
2781 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2796 if (PL_op->op_flags & OPf_REF) {
2798 if (PL_op->op_type == OP_LSTAT) {
2799 if (gv != PL_defgv) {
2800 do_fstat_warning_check:
2801 if (ckWARN(WARN_IO))
2802 Perl_warner(aTHX_ packWARN(WARN_IO),
2803 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2804 } else if (PL_laststype != OP_LSTAT)
2805 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2809 if (gv != PL_defgv) {
2810 PL_laststype = OP_STAT;
2812 sv_setpvn(PL_statname, "", 0);
2819 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2820 } else if (IoDIRP(io)) {
2823 PerlLIO_fstat(dirfd(IoDIRP(io)), &PL_statcache);
2825 DIE(aTHX_ PL_no_func, "dirfd");
2828 PL_laststatval = -1;
2834 if (PL_laststatval < 0) {
2835 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2836 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2841 SV* const sv = POPs;
2842 if (SvTYPE(sv) == SVt_PVGV) {
2845 } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2847 if (PL_op->op_type == OP_LSTAT)
2848 goto do_fstat_warning_check;
2850 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2852 if (PL_op->op_type == OP_LSTAT)
2853 goto do_fstat_warning_check;
2854 goto do_fstat_have_io;
2857 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2859 PL_laststype = PL_op->op_type;
2860 if (PL_op->op_type == OP_LSTAT)
2861 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2863 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2864 if (PL_laststatval < 0) {
2865 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2866 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2872 if (gimme != G_ARRAY) {
2873 if (gimme != G_VOID)
2874 XPUSHs(boolSV(max));
2880 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2881 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2882 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2883 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2884 #if Uid_t_size > IVSIZE
2885 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2887 # if Uid_t_sign <= 0
2888 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2890 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2893 #if Gid_t_size > IVSIZE
2894 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2896 # if Gid_t_sign <= 0
2897 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2899 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2902 #ifdef USE_STAT_RDEV
2903 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2905 PUSHs(sv_2mortal(newSVpvs("")));
2907 #if Off_t_size > IVSIZE
2908 PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
2910 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2913 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2914 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2915 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2917 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_atime)));
2918 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_mtime)));
2919 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_ctime)));
2921 #ifdef USE_STAT_BLOCKS
2922 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2923 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2925 PUSHs(sv_2mortal(newSVpvs("")));
2926 PUSHs(sv_2mortal(newSVpvs("")));
2932 /* This macro is used by the stacked filetest operators :
2933 * if the previous filetest failed, short-circuit and pass its value.
2934 * Else, discard it from the stack and continue. --rgs
2936 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2937 if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
2938 else { (void)POPs; PUTBACK; } \
2945 /* Not const, because things tweak this below. Not bool, because there's
2946 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2947 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2948 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2949 /* Giving some sort of initial value silences compilers. */
2951 int access_mode = R_OK;
2953 int access_mode = 0;
2956 /* access_mode is never used, but leaving use_access in makes the
2957 conditional compiling below much clearer. */
2960 int stat_mode = S_IRUSR;
2962 bool effective = FALSE;
2965 STACKED_FTEST_CHECK;
2967 switch (PL_op->op_type) {
2969 #if !(defined(HAS_ACCESS) && defined(R_OK))
2975 #if defined(HAS_ACCESS) && defined(W_OK)
2980 stat_mode = S_IWUSR;
2984 #if defined(HAS_ACCESS) && defined(X_OK)
2989 stat_mode = S_IXUSR;
2993 #ifdef PERL_EFF_ACCESS
2996 stat_mode = S_IWUSR;
3000 #ifndef PERL_EFF_ACCESS
3008 #ifdef PERL_EFF_ACCESS
3013 stat_mode = S_IXUSR;
3019 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3020 const char *name = POPpx;
3022 # ifdef PERL_EFF_ACCESS
3023 result = PERL_EFF_ACCESS(name, access_mode);
3025 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3031 result = access(name, access_mode);
3033 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3048 if (cando(stat_mode, effective, &PL_statcache))
3057 const int op_type = PL_op->op_type;
3059 STACKED_FTEST_CHECK;
3064 if (op_type == OP_FTIS)
3067 /* You can't dTARGET inside OP_FTIS, because you'll get
3068 "panic: pad_sv po" - the op is not flagged to have a target. */
3072 #if Off_t_size > IVSIZE
3073 PUSHn(PL_statcache.st_size);
3075 PUSHi(PL_statcache.st_size);
3079 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3082 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3085 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3098 /* I believe that all these three are likely to be defined on most every
3099 system these days. */
3101 if(PL_op->op_type == OP_FTSUID)
3105 if(PL_op->op_type == OP_FTSGID)
3109 if(PL_op->op_type == OP_FTSVTX)
3113 STACKED_FTEST_CHECK;
3118 switch (PL_op->op_type) {
3120 if (PL_statcache.st_uid == PL_uid)
3124 if (PL_statcache.st_uid == PL_euid)
3128 if (PL_statcache.st_size == 0)
3132 if (S_ISSOCK(PL_statcache.st_mode))
3136 if (S_ISCHR(PL_statcache.st_mode))
3140 if (S_ISBLK(PL_statcache.st_mode))
3144 if (S_ISREG(PL_statcache.st_mode))
3148 if (S_ISDIR(PL_statcache.st_mode))
3152 if (S_ISFIFO(PL_statcache.st_mode))
3157 if (PL_statcache.st_mode & S_ISUID)
3163 if (PL_statcache.st_mode & S_ISGID)
3169 if (PL_statcache.st_mode & S_ISVTX)
3180 I32 result = my_lstat();
3184 if (S_ISLNK(PL_statcache.st_mode))
3197 STACKED_FTEST_CHECK;
3199 if (PL_op->op_flags & OPf_REF)
3201 else if (isGV(TOPs))
3203 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3204 gv = (GV*)SvRV(POPs);
3206 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3208 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3209 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3210 else if (tmpsv && SvOK(tmpsv)) {
3211 const char *tmps = SvPV_nolen_const(tmpsv);
3219 if (PerlLIO_isatty(fd))
3224 #if defined(atarist) /* this will work with atariST. Configure will
3225 make guesses for other systems. */
3226 # define FILE_base(f) ((f)->_base)
3227 # define FILE_ptr(f) ((f)->_ptr)
3228 # define FILE_cnt(f) ((f)->_cnt)
3229 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3240 register STDCHAR *s;
3246 STACKED_FTEST_CHECK;
3248 if (PL_op->op_flags & OPf_REF)
3250 else if (isGV(TOPs))
3252 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3253 gv = (GV*)SvRV(POPs);
3259 if (gv == PL_defgv) {
3261 io = GvIO(PL_statgv);
3264 goto really_filename;
3269 PL_laststatval = -1;
3270 sv_setpvn(PL_statname, "", 0);
3271 io = GvIO(PL_statgv);
3273 if (io && IoIFP(io)) {
3274 if (! PerlIO_has_base(IoIFP(io)))
3275 DIE(aTHX_ "-T and -B not implemented on filehandles");
3276 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3277 if (PL_laststatval < 0)
3279 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3280 if (PL_op->op_type == OP_FTTEXT)
3285 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3286 i = PerlIO_getc(IoIFP(io));
3288 (void)PerlIO_ungetc(IoIFP(io),i);
3290 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3292 len = PerlIO_get_bufsiz(IoIFP(io));
3293 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3294 /* sfio can have large buffers - limit to 512 */
3299 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3301 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3303 SETERRNO(EBADF,RMS_IFI);
3311 PL_laststype = OP_STAT;
3312 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3313 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3314 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3316 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3319 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3320 if (PL_laststatval < 0) {
3321 (void)PerlIO_close(fp);
3324 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3325 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3326 (void)PerlIO_close(fp);
3328 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3329 RETPUSHNO; /* special case NFS directories */
3330 RETPUSHYES; /* null file is anything */
3335 /* now scan s to look for textiness */
3336 /* XXX ASCII dependent code */
3338 #if defined(DOSISH) || defined(USEMYBINMODE)
3339 /* ignore trailing ^Z on short files */
3340 if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3344 for (i = 0; i < len; i++, s++) {
3345 if (!*s) { /* null never allowed in text */
3350 else if (!(isPRINT(*s) || isSPACE(*s)))
3353 else if (*s & 128) {
3355 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3358 /* utf8 characters don't count as odd */
3359 if (UTF8_IS_START(*s)) {
3360 int ulen = UTF8SKIP(s);
3361 if (ulen < len - i) {
3363 for (j = 1; j < ulen; j++) {
3364 if (!UTF8_IS_CONTINUATION(s[j]))
3367 --ulen; /* loop does extra increment */
3377 *s != '\n' && *s != '\r' && *s != '\b' &&
3378 *s != '\t' && *s != '\f' && *s != 27)
3383 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3394 const char *tmps = NULL;
3398 SV * const sv = POPs;
3399 if (PL_op->op_flags & OPf_SPECIAL) {
3400 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3402 else if (SvTYPE(sv) == SVt_PVGV) {
3405 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
3409 tmps = SvPVx_nolen_const(sv);
3413 if( !gv && (!tmps || !*tmps) ) {
3414 HV * const table = GvHVn(PL_envgv);
3417 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3418 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3420 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3425 deprecate("chdir('') or chdir(undef) as chdir()");
3426 tmps = SvPV_nolen_const(*svp);
3430 TAINT_PROPER("chdir");
3435 TAINT_PROPER("chdir");
3438 IO* const io = GvIO(gv);
3441 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3443 else if (IoDIRP(io)) {
3445 PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0);
3447 DIE(aTHX_ PL_no_func, "dirfd");
3451 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3452 report_evil_fh(gv, io, PL_op->op_type);
3453 SETERRNO(EBADF, RMS_IFI);
3458 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3459 report_evil_fh(gv, io, PL_op->op_type);
3460 SETERRNO(EBADF,RMS_IFI);
3464 DIE(aTHX_ PL_no_func, "fchdir");
3468 PUSHi( PerlDir_chdir(tmps) >= 0 );
3470 /* Clear the DEFAULT element of ENV so we'll get the new value
3472 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3479 dVAR; dSP; dMARK; dTARGET;
3480 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3491 char * const tmps = POPpx;
3492 TAINT_PROPER("chroot");
3493 PUSHi( chroot(tmps) >= 0 );
3496 DIE(aTHX_ PL_no_func, "chroot");
3504 const char * const tmps2 = POPpconstx;
3505 const char * const tmps = SvPV_nolen_const(TOPs);
3506 TAINT_PROPER("rename");
3508 anum = PerlLIO_rename(tmps, tmps2);
3510 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3511 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3514 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3515 (void)UNLINK(tmps2);
3516 if (!(anum = link(tmps, tmps2)))
3517 anum = UNLINK(tmps);
3525 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3529 const int op_type = PL_op->op_type;
3533 if (op_type == OP_LINK)
3534 DIE(aTHX_ PL_no_func, "link");
3536 # ifndef HAS_SYMLINK
3537 if (op_type == OP_SYMLINK)
3538 DIE(aTHX_ PL_no_func, "symlink");
3542 const char * const tmps2 = POPpconstx;
3543 const char * const tmps = SvPV_nolen_const(TOPs);
3544 TAINT_PROPER(PL_op_desc[op_type]);
3546 # if defined(HAS_LINK)
3547 # if defined(HAS_SYMLINK)
3548 /* Both present - need to choose which. */
3549 (op_type == OP_LINK) ?
3550 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3552 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3553 PerlLIO_link(tmps, tmps2);
3556 # if defined(HAS_SYMLINK)
3557 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3558 symlink(tmps, tmps2);
3563 SETi( result >= 0 );
3570 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3581 char buf[MAXPATHLEN];
3584 #ifndef INCOMPLETE_TAINTS
3588 len = readlink(tmps, buf, sizeof(buf) - 1);
3596 RETSETUNDEF; /* just pretend it's a normal file */
3600 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3602 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3604 char * const save_filename = filename;
3609 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3611 Newx(cmdline, size, char);
3612 my_strlcpy(cmdline, cmd, size);
3613 my_strlcat(cmdline, " ", size);
3614 for (s = cmdline + strlen(cmdline); *filename; ) {
3618 if (s - cmdline < size)
3619 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3620 myfp = PerlProc_popen(cmdline, "r");
3624 SV * const tmpsv = sv_newmortal();
3625 /* Need to save/restore 'PL_rs' ?? */
3626 s = sv_gets(tmpsv, myfp, 0);
3627 (void)PerlProc_pclose(myfp);
3631 #ifdef HAS_SYS_ERRLIST
3636 /* you don't see this */
3637 const char * const errmsg =
3638 #ifdef HAS_SYS_ERRLIST
3646 if (instr(s, errmsg)) {
3653 #define EACCES EPERM
3655 if (instr(s, "cannot make"))
3656 SETERRNO(EEXIST,RMS_FEX);
3657 else if (instr(s, "existing file"))
3658 SETERRNO(EEXIST,RMS_FEX);
3659 else if (instr(s, "ile exists"))
3660 SETERRNO(EEXIST,RMS_FEX);
3661 else if (instr(s, "non-exist"))
3662 SETERRNO(ENOENT,RMS_FNF);
3663 else if (instr(s, "does not exist"))
3664 SETERRNO(ENOENT,RMS_FNF);
3665 else if (instr(s, "not empty"))
3666 SETERRNO(EBUSY,SS_DEVOFFLINE);
3667 else if (instr(s, "cannot access"))
3668 SETERRNO(EACCES,RMS_PRV);
3670 SETERRNO(EPERM,RMS_PRV);
3673 else { /* some mkdirs return no failure indication */
3674 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3675 if (PL_op->op_type == OP_RMDIR)
3680 SETERRNO(EACCES,RMS_PRV); /* a guess */
3689 /* This macro removes trailing slashes from a directory name.
3690 * Different operating and file systems take differently to
3691 * trailing slashes. According to POSIX 1003.1 1996 Edition
3692 * any number of trailing slashes should be allowed.
3693 * Thusly we snip them away so that even non-conforming
3694 * systems are happy.
3695 * We should probably do this "filtering" for all
3696 * the functions that expect (potentially) directory names:
3697 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3698 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3700 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3701 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3704 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3705 (tmps) = savepvn((tmps), (len)); \
3715 const int mode = (MAXARG > 1) ? POPi : 0777;
3717 TRIMSLASHES(tmps,len,copy);
3719 TAINT_PROPER("mkdir");
3721 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3725 SETi( dooneliner("mkdir", tmps) );
3726 oldumask = PerlLIO_umask(0);
3727 PerlLIO_umask(oldumask);
3728 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3743 TRIMSLASHES(tmps,len,copy);
3744 TAINT_PROPER("rmdir");
3746 SETi( PerlDir_rmdir(tmps) >= 0 );
3748 SETi( dooneliner("rmdir", tmps) );
3755 /* Directory calls. */
3759 #if defined(Direntry_t) && defined(HAS_READDIR)
3761 const char * const dirname = POPpconstx;
3762 GV * const gv = (GV*)POPs;
3763 register IO * const io = GvIOn(gv);
3769 PerlDir_close(IoDIRP(io));
3770 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3776 SETERRNO(EBADF,RMS_DIR);
3779 DIE(aTHX_ PL_no_dir_func, "opendir");
3785 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3786 DIE(aTHX_ PL_no_dir_func, "readdir");
3788 #if !defined(I_DIRENT) && !defined(VMS)
3789 Direntry_t *readdir (DIR *);
3795 const I32 gimme = GIMME;
3796 GV * const gv = (GV *)POPs;
3797 register const Direntry_t *dp;
3798 register IO * const io = GvIOn(gv);
3800 if (!io || !IoDIRP(io)) {
3801 if(ckWARN(WARN_IO)) {
3802 Perl_warner(aTHX_ packWARN(WARN_IO),
3803 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3809 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3813 sv = newSVpvn(dp->d_name, dp->d_namlen);
3815 sv = newSVpv(dp->d_name, 0);
3817 #ifndef INCOMPLETE_TAINTS
3818 if (!(IoFLAGS(io) & IOf_UNTAINT))
3821 XPUSHs(sv_2mortal(sv));
3822 } while (gimme == G_ARRAY);
3824 if (!dp && gimme != G_ARRAY)
3831 SETERRNO(EBADF,RMS_ISI);
3832 if (GIMME == G_ARRAY)
3841 #if defined(HAS_TELLDIR) || defined(telldir)
3843 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3844 /* XXX netbsd still seemed to.
3845 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3846 --JHI 1999-Feb-02 */
3847 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3848 long telldir (DIR *);
3850 GV * const gv = (GV*)POPs;
3851 register IO * const io = GvIOn(gv);
3853 if (!io || !IoDIRP(io)) {
3854 if(ckWARN(WARN_IO)) {
3855 Perl_warner(aTHX_ packWARN(WARN_IO),
3856 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3861 PUSHi( PerlDir_tell(IoDIRP(io)) );
3865 SETERRNO(EBADF,RMS_ISI);
3868 DIE(aTHX_ PL_no_dir_func, "telldir");
3874 #if defined(HAS_SEEKDIR) || defined(seekdir)
3876 const long along = POPl;
3877 GV * const gv = (GV*)POPs;
3878 register IO * const io = GvIOn(gv);
3880 if (!io || !IoDIRP(io)) {
3881 if(ckWARN(WARN_IO)) {
3882 Perl_warner(aTHX_ packWARN(WARN_IO),
3883 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3887 (void)PerlDir_seek(IoDIRP(io), along);
3892 SETERRNO(EBADF,RMS_ISI);
3895 DIE(aTHX_ PL_no_dir_func, "seekdir");
3901 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3903 GV * const gv = (GV*)POPs;
3904 register IO * const io = GvIOn(gv);
3906 if (!io || !IoDIRP(io)) {
3907 if(ckWARN(WARN_IO)) {
3908 Perl_warner(aTHX_ packWARN(WARN_IO),
3909 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3913 (void)PerlDir_rewind(IoDIRP(io));
3917 SETERRNO(EBADF,RMS_ISI);
3920 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3926 #if defined(Direntry_t) && defined(HAS_READDIR)
3928 GV * const gv = (GV*)POPs;
3929 register IO * const io = GvIOn(gv);
3931 if (!io || !IoDIRP(io)) {
3932 if(ckWARN(WARN_IO)) {
3933 Perl_warner(aTHX_ packWARN(WARN_IO),
3934 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3938 #ifdef VOID_CLOSEDIR
3939 PerlDir_close(IoDIRP(io));
3941 if (PerlDir_close(IoDIRP(io)) < 0) {
3942 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3951 SETERRNO(EBADF,RMS_IFI);
3954 DIE(aTHX_ PL_no_dir_func, "closedir");
3958 /* Process control. */
3967 PERL_FLUSHALL_FOR_CHILD;
3968 childpid = PerlProc_fork();
3972 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3974 SvREADONLY_off(GvSV(tmpgv));
3975 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3976 SvREADONLY_on(GvSV(tmpgv));
3978 #ifdef THREADS_HAVE_PIDS
3979 PL_ppid = (IV)getppid();
3981 #ifdef PERL_USES_PL_PIDSTATUS
3982 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3988 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3993 PERL_FLUSHALL_FOR_CHILD;
3994 childpid = PerlProc_fork();
4000 DIE(aTHX_ PL_no_func, "fork");
4007 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4012 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4013 childpid = wait4pid(-1, &argflags, 0);
4015 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4020 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4021 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4022 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4024 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4029 DIE(aTHX_ PL_no_func, "wait");
4035 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4037 const int optype = POPi;
4038 const Pid_t pid = TOPi;
4042 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4043 result = wait4pid(pid, &argflags, optype);
4045 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4050 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4051 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4052 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4054 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4059 DIE(aTHX_ PL_no_func, "waitpid");
4065 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4071 while (++MARK <= SP) {
4072 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4077 TAINT_PROPER("system");
4079 PERL_FLUSHALL_FOR_CHILD;
4080 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4086 if (PerlProc_pipe(pp) >= 0)
4088 while ((childpid = PerlProc_fork()) == -1) {
4089 if (errno != EAGAIN) {
4094 PerlLIO_close(pp[0]);
4095 PerlLIO_close(pp[1]);
4102 Sigsave_t ihand,qhand; /* place to save signals during system() */
4106 PerlLIO_close(pp[1]);
4108 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4109 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4112 result = wait4pid(childpid, &status, 0);
4113 } while (result == -1 && errno == EINTR);
4115 (void)rsignal_restore(SIGINT, &ihand);
4116 (void)rsignal_restore(SIGQUIT, &qhand);
4118 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4119 do_execfree(); /* free any memory child malloced on fork */
4126 while (n < sizeof(int)) {
4127 n1 = PerlLIO_read(pp[0],
4128 (void*)(((char*)&errkid)+n),
4134 PerlLIO_close(pp[0]);
4135 if (n) { /* Error */
4136 if (n != sizeof(int))
4137 DIE(aTHX_ "panic: kid popen errno read");
4138 errno = errkid; /* Propagate errno from kid */
4139 STATUS_NATIVE_CHILD_SET(-1);
4142 XPUSHi(STATUS_CURRENT);
4146 PerlLIO_close(pp[0]);
4147 #if defined(HAS_FCNTL) && defined(F_SETFD)
4148 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4151 if (PL_op->op_flags & OPf_STACKED) {
4152 SV * const really = *++MARK;
4153 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4155 else if (SP - MARK != 1)
4156 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4158 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4162 #else /* ! FORK or VMS or OS/2 */
4165 if (PL_op->op_flags & OPf_STACKED) {
4166 SV * const really = *++MARK;
4167 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4168 value = (I32)do_aspawn(really, MARK, SP);
4170 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4173 else if (SP - MARK != 1) {
4174 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4175 value = (I32)do_aspawn(NULL, MARK, SP);
4177 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4181 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4183 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4185 STATUS_NATIVE_CHILD_SET(value);
4188 XPUSHi(result ? value : STATUS_CURRENT);
4189 #endif /* !FORK or VMS */
4195 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4200 while (++MARK <= SP) {
4201 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4206 TAINT_PROPER("exec");
4208 PERL_FLUSHALL_FOR_CHILD;
4209 if (PL_op->op_flags & OPf_STACKED) {
4210 SV * const really = *++MARK;
4211 value = (I32)do_aexec(really, MARK, SP);
4213 else if (SP - MARK != 1)
4215 value = (I32)vms_do_aexec(NULL, MARK, SP);
4219 (void ) do_aspawn(NULL, MARK, SP);
4223 value = (I32)do_aexec(NULL, MARK, SP);
4228 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4231 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4234 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4248 # ifdef THREADS_HAVE_PIDS
4249 if (PL_ppid != 1 && getppid() == 1)
4250 /* maybe the parent process has died. Refresh ppid cache */
4254 XPUSHi( getppid() );
4258 DIE(aTHX_ PL_no_func, "getppid");
4267 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4270 pgrp = (I32)BSD_GETPGRP(pid);
4272 if (pid != 0 && pid != PerlProc_getpid())
4273 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4279 DIE(aTHX_ PL_no_func, "getpgrp()");
4298 TAINT_PROPER("setpgrp");
4300 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4302 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4303 || (pid != 0 && pid != PerlProc_getpid()))
4305 DIE(aTHX_ "setpgrp can't take arguments");
4307 SETi( setpgrp() >= 0 );
4308 #endif /* USE_BSDPGRP */
4311 DIE(aTHX_ PL_no_func, "setpgrp()");
4317 #ifdef HAS_GETPRIORITY
4319 const int who = POPi;
4320 const int which = TOPi;
4321 SETi( getpriority(which, who) );
4324 DIE(aTHX_ PL_no_func, "getpriority()");
4330 #ifdef HAS_SETPRIORITY
4332 const int niceval = POPi;
4333 const int who = POPi;
4334 const int which = TOPi;
4335 TAINT_PROPER("setpriority");
4336 SETi( setpriority(which, who, niceval) >= 0 );
4339 DIE(aTHX_ PL_no_func, "setpriority()");
4349 XPUSHn( time(NULL) );
4351 XPUSHi( time(NULL) );
4363 (void)PerlProc_times(&PL_timesbuf);
4365 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4366 /* struct tms, though same data */
4370 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
4371 if (GIMME == G_ARRAY) {
4372 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
4373 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
4374 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
4380 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4382 if (GIMME == G_ARRAY) {
4383 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4384 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4385 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4389 DIE(aTHX_ "times not implemented");
4391 #endif /* HAS_TIMES */
4394 #ifdef LOCALTIME_EDGECASE_BROKEN
4395 static struct tm *S_my_localtime (pTHX_ Time_t *tp)
4400 /* No workarounds in the valid range */
4401 if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4402 return (localtime (tp));
4404 /* This edge case is to workaround the undefined behaviour, where the
4405 * TIMEZONE makes the time go beyond the defined range.
4406 * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4407 * If there is a negative offset in TZ, like MET-1METDST, some broken
4408 * implementations of localtime () (like AIX 5.2) barf with bogus
4410 * 0x7fffffff gmtime 2038-01-19 03:14:07
4411 * 0x7fffffff localtime 1901-12-13 21:45:51
4412 * 0x7fffffff mylocaltime 2038-01-19 04:14:07
4413 * 0x3c19137f gmtime 2001-12-13 20:45:51
4414 * 0x3c19137f localtime 2001-12-13 21:45:51
4415 * 0x3c19137f mylocaltime 2001-12-13 21:45:51
4416 * Given that legal timezones are typically between GMT-12 and GMT+12
4417 * we turn back the clock 23 hours before calling the localtime
4418 * function, and add those to the return value. This will never cause
4419 * day wrapping problems, since the edge case is Tue Jan *19*
4421 T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4424 if (P->tm_hour >= 24) {
4426 P->tm_mday++; /* 18 -> 19 */
4427 P->tm_wday++; /* Mon -> Tue */
4428 P->tm_yday++; /* 18 -> 19 */
4431 } /* S_my_localtime */
4439 const struct tm *tmbuf;
4440 static const char * const dayname[] =
4441 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4442 static const char * const monname[] =
4443 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4444 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4450 when = (Time_t)SvNVx(POPs);
4452 when = (Time_t)SvIVx(POPs);
4455 if (PL_op->op_type == OP_LOCALTIME)
4456 #ifdef LOCALTIME_EDGECASE_BROKEN
4457 tmbuf = S_my_localtime(aTHX_ &when);
4459 tmbuf = localtime(&when);
4462 tmbuf = gmtime(&when);
4464 if (GIMME != G_ARRAY) {
4470 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4471 dayname[tmbuf->tm_wday],
4472 monname[tmbuf->tm_mon],
4477 tmbuf->tm_year + 1900);
4478 PUSHs(sv_2mortal(tsv));
4483 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4484 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4485 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4486 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4487 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4488 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4489 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4490 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4491 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4502 anum = alarm((unsigned int)anum);
4509 DIE(aTHX_ PL_no_func, "alarm");
4520 (void)time(&lasttime);
4525 PerlProc_sleep((unsigned int)duration);
4528 XPUSHi(when - lasttime);
4532 /* Shared memory. */
4533 /* Merged with some message passing. */
4537 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4538 dVAR; dSP; dMARK; dTARGET;
4539 const int op_type = PL_op->op_type;
4544 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4547 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4550 value = (I32)(do_semop(MARK, SP) >= 0);
4553 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4569 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4570 dVAR; dSP; dMARK; dTARGET;
4571 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4578 DIE(aTHX_ "System V IPC is not implemented on this machine");
4584 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4585 dVAR; dSP; dMARK; dTARGET;
4586 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4594 PUSHp(zero_but_true, ZBTLEN);
4602 /* I can't const this further without getting warnings about the types of
4603 various arrays passed in from structures. */
4605 S_space_join_names_mortal(pTHX_ char *const *array)
4609 if (array && *array) {
4610 target = sv_2mortal(newSVpvs(""));
4612 sv_catpv(target, *array);
4615 sv_catpvs(target, " ");
4618 target = sv_mortalcopy(&PL_sv_no);
4623 /* Get system info. */
4627 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4629 I32 which = PL_op->op_type;
4630 register char **elem;
4632 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4633 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4634 struct hostent *gethostbyname(Netdb_name_t);
4635 struct hostent *gethostent(void);
4637 struct hostent *hent;
4641 if (which == OP_GHBYNAME) {
4642 #ifdef HAS_GETHOSTBYNAME
4643 const char* const name = POPpbytex;
4644 hent = PerlSock_gethostbyname(name);
4646 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4649 else if (which == OP_GHBYADDR) {
4650 #ifdef HAS_GETHOSTBYADDR
4651 const int addrtype = POPi;
4652 SV * const addrsv = POPs;
4654 Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4656 hent = PerlSock_gethostbyaddr((const char*)addr, (Netdb_hlen_t) addrlen, addrtype);
4658 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4662 #ifdef HAS_GETHOSTENT
4663 hent = PerlSock_gethostent();
4665 DIE(aTHX_ PL_no_sock_func, "gethostent");
4668 #ifdef HOST_NOT_FOUND
4670 #ifdef USE_REENTRANT_API
4671 # ifdef USE_GETHOSTENT_ERRNO
4672 h_errno = PL_reentrant_buffer->_gethostent_errno;
4675 STATUS_UNIX_SET(h_errno);
4679 if (GIMME != G_ARRAY) {
4680 PUSHs(sv = sv_newmortal());
4682 if (which == OP_GHBYNAME) {
4684 sv_setpvn(sv, hent->h_addr, hent->h_length);
4687 sv_setpv(sv, (char*)hent->h_name);
4693 PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
4694 PUSHs(space_join_names_mortal(hent->h_aliases));
4695 PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
4696 len = hent->h_length;
4697 PUSHs(sv_2mortal(newSViv((IV)len)));
4699 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4700 XPUSHs(sv_2mortal(newSVpvn(*elem, len)));
4704 PUSHs(newSVpvn(hent->h_addr, len));
4706 PUSHs(sv_mortalcopy(&PL_sv_no));
4711 DIE(aTHX_ PL_no_sock_func, "gethostent");
4717 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4719 I32 which = PL_op->op_type;
4721 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4722 struct netent *getnetbyaddr(Netdb_net_t, int);
4723 struct netent *getnetbyname(Netdb_name_t);
4724 struct netent *getnetent(void);
4726 struct netent *nent;
4728 if (which == OP_GNBYNAME){
4729 #ifdef HAS_GETNETBYNAME
4730 const char * const name = POPpbytex;
4731 nent = PerlSock_getnetbyname(name);
4733 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4736 else if (which == OP_GNBYADDR) {
4737 #ifdef HAS_GETNETBYADDR
4738 const int addrtype = POPi;
4739 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4740 nent = PerlSock_getnetbyaddr(addr, addrtype);
4742 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4746 #ifdef HAS_GETNETENT
4747 nent = PerlSock_getnetent();
4749 DIE(aTHX_ PL_no_sock_func, "getnetent");
4752 #ifdef HOST_NOT_FOUND
4754 #ifdef USE_REENTRANT_API
4755 # ifdef USE_GETNETENT_ERRNO
4756 h_errno = PL_reentrant_buffer->_getnetent_errno;
4759 STATUS_UNIX_SET(h_errno);
4764 if (GIMME != G_ARRAY) {
4765 PUSHs(sv = sv_newmortal());
4767 if (which == OP_GNBYNAME)
4768 sv_setiv(sv, (IV)nent->n_net);
4770 sv_setpv(sv, nent->n_name);
4776 PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
4777 PUSHs(space_join_names_mortal(nent->n_aliases));
4778 PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
4779 PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
4784 DIE(aTHX_ PL_no_sock_func, "getnetent");
4790 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4792 I32 which = PL_op->op_type;
4794 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4795 struct protoent *getprotobyname(Netdb_name_t);
4796 struct protoent *getprotobynumber(int);
4797 struct protoent *getprotoent(void);
4799 struct protoent *pent;
4801 if (which == OP_GPBYNAME) {
4802 #ifdef HAS_GETPROTOBYNAME
4803 const char* const name = POPpbytex;
4804 pent = PerlSock_getprotobyname(name);
4806 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4809 else if (which == OP_GPBYNUMBER) {
4810 #ifdef HAS_GETPROTOBYNUMBER
4811 const int number = POPi;
4812 pent = PerlSock_getprotobynumber(number);
4814 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4818 #ifdef HAS_GETPROTOENT
4819 pent = PerlSock_getprotoent();
4821 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4825 if (GIMME != G_ARRAY) {
4826 PUSHs(sv = sv_newmortal());
4828 if (which == OP_GPBYNAME)
4829 sv_setiv(sv, (IV)pent->p_proto);
4831 sv_setpv(sv, pent->p_name);
4837 PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
4838 PUSHs(space_join_names_mortal(pent->p_aliases));
4839 PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
4844 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4850 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4852 I32 which = PL_op->op_type;
4854 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4855 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4856 struct servent *getservbyport(int, Netdb_name_t);
4857 struct servent *getservent(void);
4859 struct servent *sent;
4861 if (which == OP_GSBYNAME) {
4862 #ifdef HAS_GETSERVBYNAME
4863 const char * const proto = POPpbytex;
4864 const char * const name = POPpbytex;
4865 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4867 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4870 else if (which == OP_GSBYPORT) {
4871 #ifdef HAS_GETSERVBYPORT
4872 const char * const proto = POPpbytex;
4873 unsigned short port = (unsigned short)POPu;
4875 port = PerlSock_htons(port);
4877 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4879 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4883 #ifdef HAS_GETSERVENT
4884 sent = PerlSock_getservent();
4886 DIE(aTHX_ PL_no_sock_func, "getservent");
4890 if (GIMME != G_ARRAY) {
4891 PUSHs(sv = sv_newmortal());
4893 if (which == OP_GSBYNAME) {
4895 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4897 sv_setiv(sv, (IV)(sent->s_port));
4901 sv_setpv(sv, sent->s_name);
4907 PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
4908 PUSHs(space_join_names_mortal(sent->s_aliases));
4910 PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
4912 PUSHs(sv_2mortal(newSViv((IV)(sent->s_port))));
4914 PUSHs(sv_2mortal(newSVpv(sent->s_proto, 0)));
4919 DIE(aTHX_ PL_no_sock_func, "getservent");
4925 #ifdef HAS_SETHOSTENT
4927 PerlSock_sethostent(TOPi);
4930 DIE(aTHX_ PL_no_sock_func, "sethostent");
4936 #ifdef HAS_SETNETENT
4938 PerlSock_setnetent(TOPi);
4941 DIE(aTHX_ PL_no_sock_func, "setnetent");
4947 #ifdef HAS_SETPROTOENT
4949 PerlSock_setprotoent(TOPi);
4952 DIE(aTHX_ PL_no_sock_func, "setprotoent");
4958 #ifdef HAS_SETSERVENT
4960 PerlSock_setservent(TOPi);
4963 DIE(aTHX_ PL_no_sock_func, "setservent");
4969 #ifdef HAS_ENDHOSTENT
4971 PerlSock_endhostent();
4975 DIE(aTHX_ PL_no_sock_func, "endhostent");
4981 #ifdef HAS_ENDNETENT
4983 PerlSock_endnetent();
4987 DIE(aTHX_ PL_no_sock_func, "endnetent");
4993 #ifdef HAS_ENDPROTOENT
4995 PerlSock_endprotoent();
4999 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5005 #ifdef HAS_ENDSERVENT
5007 PerlSock_endservent();
5011 DIE(aTHX_ PL_no_sock_func, "endservent");
5019 I32 which = PL_op->op_type;
5021 struct passwd *pwent = NULL;
5023 * We currently support only the SysV getsp* shadow password interface.
5024 * The interface is declared in <shadow.h> and often one needs to link
5025 * with -lsecurity or some such.
5026 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5029 * AIX getpwnam() is clever enough to return the encrypted password
5030 * only if the caller (euid?) is root.
5032 * There are at least three other shadow password APIs. Many platforms
5033 * seem to contain more than one interface for accessing the shadow
5034 * password databases, possibly for compatibility reasons.
5035 * The getsp*() is by far he simplest one, the other two interfaces
5036 * are much more complicated, but also very similar to each other.
5041 * struct pr_passwd *getprpw*();
5042 * The password is in
5043 * char getprpw*(...).ufld.fd_encrypt[]
5044 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5049 * struct es_passwd *getespw*();
5050 * The password is in
5051 * char *(getespw*(...).ufld.fd_encrypt)
5052 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5055 * struct userpw *getuserpw();
5056 * The password is in
5057 * char *(getuserpw(...)).spw_upw_passwd
5058 * (but the de facto standard getpwnam() should work okay)
5060 * Mention I_PROT here so that Configure probes for it.
5062 * In HP-UX for getprpw*() the manual page claims that one should include
5063 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5064 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5065 * and pp_sys.c already includes <shadow.h> if there is such.
5067 * Note that <sys/security.h> is already probed for, but currently
5068 * it is only included in special cases.
5070 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5071 * be preferred interface, even though also the getprpw*() interface
5072 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5073 * One also needs to call set_auth_parameters() in main() before
5074 * doing anything else, whether one is using getespw*() or getprpw*().
5076 * Note that accessing the shadow databases can be magnitudes
5077 * slower than accessing the standard databases.
5082 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5083 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5084 * the pw_comment is left uninitialized. */
5085 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5091 const char* const name = POPpbytex;
5092 pwent = getpwnam(name);
5098 pwent = getpwuid(uid);
5102 # ifdef HAS_GETPWENT
5104 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5105 if (pwent) pwent = getpwnam(pwent->pw_name);
5108 DIE(aTHX_ PL_no_func, "getpwent");
5114 if (GIMME != G_ARRAY) {
5115 PUSHs(sv = sv_newmortal());
5117 if (which == OP_GPWNAM)
5118 # if Uid_t_sign <= 0
5119 sv_setiv(sv, (IV)pwent->pw_uid);
5121 sv_setuv(sv, (UV)pwent->pw_uid);
5124 sv_setpv(sv, pwent->pw_name);
5130 PUSHs(sv_2mortal(newSVpv(pwent->pw_name, 0)));
5132 PUSHs(sv = sv_2mortal(newSViv(0)));
5133 /* If we have getspnam(), we try to dig up the shadow
5134 * password. If we are underprivileged, the shadow
5135 * interface will set the errno to EACCES or similar,
5136 * and return a null pointer. If this happens, we will
5137 * use the dummy password (usually "*" or "x") from the
5138 * standard password database.
5140 * In theory we could skip the shadow call completely
5141 * if euid != 0 but in practice we cannot know which
5142 * security measures are guarding the shadow databases
5143 * on a random platform.
5145 * Resist the urge to use additional shadow interfaces.
5146 * Divert the urge to writing an extension instead.
5149 /* Some AIX setups falsely(?) detect some getspnam(), which
5150 * has a different API than the Solaris/IRIX one. */
5151 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5153 const int saverrno = errno;
5154 const struct spwd * const spwent = getspnam(pwent->pw_name);
5155 /* Save and restore errno so that
5156 * underprivileged attempts seem
5157 * to have never made the unsccessful
5158 * attempt to retrieve the shadow password. */
5160 if (spwent && spwent->sp_pwdp)
5161 sv_setpv(sv, spwent->sp_pwdp);
5165 if (!SvPOK(sv)) /* Use the standard password, then. */
5166 sv_setpv(sv, pwent->pw_passwd);
5169 # ifndef INCOMPLETE_TAINTS
5170 /* passwd is tainted because user himself can diddle with it.
5171 * admittedly not much and in a very limited way, but nevertheless. */
5175 # if Uid_t_sign <= 0
5176 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_uid)));
5178 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_uid)));
5181 # if Uid_t_sign <= 0
5182 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_gid)));
5184 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_gid)));
5186 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5187 * because of the poor interface of the Perl getpw*(),
5188 * not because there's some standard/convention saying so.
5189 * A better interface would have been to return a hash,
5190 * but we are accursed by our history, alas. --jhi. */
5192 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_change)));
5195 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_quota)));
5198 PUSHs(sv_2mortal(newSVpv(pwent->pw_age, 0)));
5200 /* I think that you can never get this compiled, but just in case. */
5201 PUSHs(sv_mortalcopy(&PL_sv_no));
5206 /* pw_class and pw_comment are mutually exclusive--.
5207 * see the above note for pw_change, pw_quota, and pw_age. */
5209 PUSHs(sv_2mortal(newSVpv(pwent->pw_class, 0)));
5212 PUSHs(sv_2mortal(newSVpv(pwent->pw_comment, 0)));
5214 /* I think that you can never get this compiled, but just in case. */
5215 PUSHs(sv_mortalcopy(&PL_sv_no));
5220 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5222 PUSHs(sv_mortalcopy(&PL_sv_no));
5224 # ifndef INCOMPLETE_TAINTS
5225 /* pw_gecos is tainted because user himself can diddle with it. */
5229 PUSHs(sv_2mortal(newSVpv(pwent->pw_dir, 0)));
5231 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5232 # ifndef INCOMPLETE_TAINTS
5233 /* pw_shell is tainted because user himself can diddle with it. */
5238 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_expire)));
5243 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5249 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5254 DIE(aTHX_ PL_no_func, "setpwent");
5260 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5265 DIE(aTHX_ PL_no_func, "endpwent");
5273 const I32 which = PL_op->op_type;
5274 const struct group *grent;
5276 if (which == OP_GGRNAM) {
5277 const char* const name = POPpbytex;
5278 grent = (const struct group *)getgrnam(name);
5280 else if (which == OP_GGRGID) {
5281 const Gid_t gid = POPi;
5282 grent = (const struct group *)getgrgid(gid);
5286 grent = (struct group *)getgrent();
5288 DIE(aTHX_ PL_no_func, "getgrent");
5292 if (GIMME != G_ARRAY) {
5293 SV * const sv = sv_newmortal();
5297 if (which == OP_GGRNAM)
5298 sv_setiv(sv, (IV)grent->gr_gid);
5300 sv_setpv(sv, grent->gr_name);
5306 PUSHs(sv_2mortal(newSVpv(grent->gr_name, 0)));
5309 PUSHs(sv_2mortal(newSVpv(grent->gr_passwd, 0)));
5311 PUSHs(sv_mortalcopy(&PL_sv_no));
5314 PUSHs(sv_2mortal(newSViv((IV)grent->gr_gid)));
5316 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5317 /* In UNICOS/mk (_CRAYMPP) the multithreading
5318 * versions (getgrnam_r, getgrgid_r)
5319 * seem to return an illegal pointer
5320 * as the group members list, gr_mem.
5321 * getgrent() doesn't even have a _r version
5322 * but the gr_mem is poisonous anyway.
5323 * So yes, you cannot get the list of group
5324 * members if building multithreaded in UNICOS/mk. */
5325 PUSHs(space_join_names_mortal(grent->gr_mem));
5331 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5337 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5342 DIE(aTHX_ PL_no_func, "setgrent");
5348 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5353 DIE(aTHX_ PL_no_func, "endgrent");
5363 if (!(tmps = PerlProc_getlogin()))
5365 PUSHp(tmps, strlen(tmps));
5368 DIE(aTHX_ PL_no_func, "getlogin");
5372 /* Miscellaneous. */
5377 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5378 register I32 items = SP - MARK;
5379 unsigned long a[20];
5384 while (++MARK <= SP) {
5385 if (SvTAINTED(*MARK)) {
5391 TAINT_PROPER("syscall");
5394 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5395 * or where sizeof(long) != sizeof(char*). But such machines will
5396 * not likely have syscall implemented either, so who cares?
5398 while (++MARK <= SP) {
5399 if (SvNIOK(*MARK) || !i)
5400 a[i++] = SvIV(*MARK);
5401 else if (*MARK == &PL_sv_undef)
5404 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5410 DIE(aTHX_ "Too many args to syscall");
5412 DIE(aTHX_ "Too few args to syscall");
5414 retval = syscall(a[0]);
5417 retval = syscall(a[0],a[1]);
5420 retval = syscall(a[0],a[1],a[2]);
5423 retval = syscall(a[0],a[1],a[2],a[3]);
5426 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5429 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5432 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5435 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5439 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5442 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5445 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5449 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5453 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5457 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5458 a[10],a[11],a[12],a[13]);
5460 #endif /* atarist */
5466 DIE(aTHX_ PL_no_func, "syscall");
5470 #ifdef FCNTL_EMULATE_FLOCK
5472 /* XXX Emulate flock() with fcntl().
5473 What's really needed is a good file locking module.
5477 fcntl_emulate_flock(int fd, int operation)
5481 switch (operation & ~LOCK_NB) {
5483 flock.l_type = F_RDLCK;
5486 flock.l_type = F_WRLCK;
5489 flock.l_type = F_UNLCK;
5495 flock.l_whence = SEEK_SET;
5496 flock.l_start = flock.l_len = (Off_t)0;
5498 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5501 #endif /* FCNTL_EMULATE_FLOCK */
5503 #ifdef LOCKF_EMULATE_FLOCK
5505 /* XXX Emulate flock() with lockf(). This is just to increase
5506 portability of scripts. The calls are not completely
5507 interchangeable. What's really needed is a good file
5511 /* The lockf() constants might have been defined in <unistd.h>.
5512 Unfortunately, <unistd.h> causes troubles on some mixed
5513 (BSD/POSIX) systems, such as SunOS 4.1.3.
5515 Further, the lockf() constants aren't POSIX, so they might not be
5516 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5517 just stick in the SVID values and be done with it. Sigh.
5521 # define F_ULOCK 0 /* Unlock a previously locked region */
5524 # define F_LOCK 1 /* Lock a region for exclusive use */
5527 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5530 # define F_TEST 3 /* Test a region for other processes locks */
5534 lockf_emulate_flock(int fd, int operation)
5537 const int save_errno = errno;
5540 /* flock locks entire file so for lockf we need to do the same */
5541 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5542 if (pos > 0) /* is seekable and needs to be repositioned */
5543 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5544 pos = -1; /* seek failed, so don't seek back afterwards */
5547 switch (operation) {
5549 /* LOCK_SH - get a shared lock */
5551 /* LOCK_EX - get an exclusive lock */
5553 i = lockf (fd, F_LOCK, 0);
5556 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5557 case LOCK_SH|LOCK_NB:
5558 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5559 case LOCK_EX|LOCK_NB:
5560 i = lockf (fd, F_TLOCK, 0);
5562 if ((errno == EAGAIN) || (errno == EACCES))
5563 errno = EWOULDBLOCK;
5566 /* LOCK_UN - unlock (non-blocking is a no-op) */
5568 case LOCK_UN|LOCK_NB:
5569 i = lockf (fd, F_ULOCK, 0);
5572 /* Default - can't decipher operation */
5579 if (pos > 0) /* need to restore position of the handle */
5580 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5585 #endif /* LOCKF_EMULATE_FLOCK */
5589 * c-indentation-style: bsd
5591 * indent-tabs-mode: t
5594 * ex: set ts=8 sts=4 sw=4 noet: