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 #if defined(__osf__) && defined(__cplusplus) && !defined(_XOPEN_SOURCE_EXTENDED)
201 extern int readlink(const char *, char *, size_t);
202 extern int fchdir(int);
205 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
207 /* AIX 5.2 and below use mktime for localtime, and defines the edge case
208 * for time 0x7fffffff to be valid only in UTC. AIX 5.3 provides localtime64
209 * available in the 32bit environment, which could warrant Configure
210 * checks in the future.
213 #define LOCALTIME_EDGECASE_BROKEN
216 /* F_OK unused: if stat() cannot find it... */
218 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
219 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
220 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
223 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
224 # ifdef I_SYS_SECURITY
225 # include <sys/security.h>
229 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
232 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
236 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
238 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
242 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
243 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
244 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
247 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
249 const Uid_t ruid = getuid();
250 const Uid_t euid = geteuid();
251 const Gid_t rgid = getgid();
252 const Gid_t egid = getegid();
256 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
257 Perl_croak(aTHX_ "switching effective uid is not implemented");
260 if (setreuid(euid, ruid))
263 if (setresuid(euid, ruid, (Uid_t)-1))
266 Perl_croak(aTHX_ "entering effective uid failed");
269 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
270 Perl_croak(aTHX_ "switching effective gid is not implemented");
273 if (setregid(egid, rgid))
276 if (setresgid(egid, rgid, (Gid_t)-1))
279 Perl_croak(aTHX_ "entering effective gid failed");
282 res = access(path, mode);
285 if (setreuid(ruid, euid))
288 if (setresuid(ruid, euid, (Uid_t)-1))
291 Perl_croak(aTHX_ "leaving effective uid failed");
294 if (setregid(rgid, egid))
297 if (setresgid(rgid, egid, (Gid_t)-1))
300 Perl_croak(aTHX_ "leaving effective gid failed");
305 # define PERL_EFF_ACCESS(p,f) (emulate_eaccess((p), (f)))
308 #if !defined(PERL_EFF_ACCESS)
309 /* With it or without it: anyway you get a warning: either that
310 it is unused, or it is declared static and never defined.
313 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
315 PERL_UNUSED_ARG(path);
316 PERL_UNUSED_ARG(mode);
317 Perl_croak(aTHX_ "switching effective uid is not implemented");
327 const char * const tmps = POPpconstx;
328 const I32 gimme = GIMME_V;
329 const char *mode = "r";
332 if (PL_op->op_private & OPpOPEN_IN_RAW)
334 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
336 fp = PerlProc_popen(tmps, mode);
338 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
340 PerlIO_apply_layers(aTHX_ fp,mode,type);
342 if (gimme == G_VOID) {
344 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
347 else if (gimme == G_SCALAR) {
350 PL_rs = &PL_sv_undef;
351 sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */
352 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
360 SV * const sv = newSV(79);
361 if (sv_gets(sv, fp, 0) == NULL) {
365 XPUSHs(sv_2mortal(sv));
366 if (SvLEN(sv) - SvCUR(sv) > 20) {
367 SvPV_shrink_to_cur(sv);
372 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
373 TAINT; /* "I believe that this is not gratuitous!" */
376 STATUS_NATIVE_CHILD_SET(-1);
377 if (gimme == G_SCALAR)
388 tryAMAGICunTARGET(iter, -1);
390 /* Note that we only ever get here if File::Glob fails to load
391 * without at the same time croaking, for some reason, or if
392 * perl was built with PERL_EXTERNAL_GLOB */
399 * The external globbing program may use things we can't control,
400 * so for security reasons we must assume the worst.
403 taint_proper(PL_no_security, "glob");
407 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
408 PL_last_in_gv = (GV*)*PL_stack_sp--;
410 SAVESPTR(PL_rs); /* This is not permanent, either. */
411 PL_rs = sv_2mortal(newSVpvs("\000"));
414 *SvPVX(PL_rs) = '\n';
418 result = do_readline();
426 PL_last_in_gv = cGVOP_gv;
427 return do_readline();
438 do_join(TARG, &PL_sv_no, MARK, SP);
442 else if (SP == MARK) {
449 tmps = SvPV_const(tmpsv, len);
450 if ((!tmps || !len) && PL_errgv) {
451 SV * const error = ERRSV;
452 SvUPGRADE(error, SVt_PV);
453 if (SvPOK(error) && SvCUR(error))
454 sv_catpvs(error, "\t...caught");
456 tmps = SvPV_const(tmpsv, len);
459 tmpsv = sv_2mortal(newSVpvs("Warning: something's wrong"));
461 Perl_warn(aTHX_ "%"SVf, (void*)tmpsv);
473 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
475 if (SP - MARK != 1) {
477 do_join(TARG, &PL_sv_no, MARK, SP);
479 tmps = SvPV_const(tmpsv, len);
485 tmps = SvROK(tmpsv) ? NULL : SvPV_const(tmpsv, len);
488 SV * const error = ERRSV;
489 SvUPGRADE(error, SVt_PV);
490 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
492 SvSetSV(error,tmpsv);
493 else if (sv_isobject(error)) {
494 HV * const stash = SvSTASH(SvRV(error));
495 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
497 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
498 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
505 call_sv((SV*)GvCV(gv),
506 G_SCALAR|G_EVAL|G_KEEPERR);
507 sv_setsv(error,*PL_stack_sp--);
513 if (SvPOK(error) && SvCUR(error))
514 sv_catpvs(error, "\t...propagated");
517 tmps = SvPV_const(tmpsv, len);
523 tmpsv = sv_2mortal(newSVpvs("Died"));
525 DIE(aTHX_ "%"SVf, (void*)tmpsv);
541 GV * const gv = (GV *)*++MARK;
544 DIE(aTHX_ PL_no_usym, "filehandle");
545 if ((io = GvIOp(gv))) {
547 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
549 mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
551 /* Method's args are same as ours ... */
552 /* ... except handle is replaced by the object */
553 *MARK-- = SvTIED_obj((SV*)io, mg);
557 call_method("OPEN", G_SCALAR);
571 tmps = SvPV_const(sv, len);
572 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
575 PUSHi( (I32)PL_forkprocess );
576 else if (PL_forkprocess == 0) /* we are a new child */
586 GV * const gv = (MAXARG == 0) ? PL_defoutgv : (GV*)POPs;
589 IO * const io = GvIO(gv);
591 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
594 XPUSHs(SvTIED_obj((SV*)io, mg));
597 call_method("CLOSE", G_SCALAR);
605 PUSHs(boolSV(do_close(gv, TRUE)));
618 GV * const wgv = (GV*)POPs;
619 GV * const rgv = (GV*)POPs;
624 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
625 DIE(aTHX_ PL_no_usym, "filehandle");
630 do_close(rgv, FALSE);
632 do_close(wgv, FALSE);
634 if (PerlProc_pipe(fd) < 0)
637 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
638 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
639 IoOFP(rstio) = IoIFP(rstio);
640 IoIFP(wstio) = IoOFP(wstio);
641 IoTYPE(rstio) = IoTYPE_RDONLY;
642 IoTYPE(wstio) = IoTYPE_WRONLY;
644 if (!IoIFP(rstio) || !IoOFP(wstio)) {
646 PerlIO_close(IoIFP(rstio));
648 PerlLIO_close(fd[0]);
650 PerlIO_close(IoOFP(wstio));
652 PerlLIO_close(fd[1]);
655 #if defined(HAS_FCNTL) && defined(F_SETFD)
656 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
657 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
664 DIE(aTHX_ PL_no_func, "pipe");
680 if (gv && (io = GvIO(gv))
681 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
684 XPUSHs(SvTIED_obj((SV*)io, mg));
687 call_method("FILENO", G_SCALAR);
693 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
694 /* Can't do this because people seem to do things like
695 defined(fileno($foo)) to check whether $foo is a valid fh.
696 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
697 report_evil_fh(gv, io, PL_op->op_type);
702 PUSHi(PerlIO_fileno(fp));
715 anum = PerlLIO_umask(0);
716 (void)PerlLIO_umask(anum);
719 anum = PerlLIO_umask(POPi);
720 TAINT_PROPER("umask");
723 /* Only DIE if trying to restrict permissions on "user" (self).
724 * Otherwise it's harmless and more useful to just return undef
725 * since 'group' and 'other' concepts probably don't exist here. */
726 if (MAXARG >= 1 && (POPi & 0700))
727 DIE(aTHX_ "umask not implemented");
728 XPUSHs(&PL_sv_undef);
749 if (gv && (io = GvIO(gv))) {
750 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
753 XPUSHs(SvTIED_obj((SV*)io, mg));
758 call_method("BINMODE", G_SCALAR);
766 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
767 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
768 report_evil_fh(gv, io, PL_op->op_type);
769 SETERRNO(EBADF,RMS_IFI);
774 if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
775 (discp) ? SvPV_nolen_const(discp) : NULL)) {
776 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
777 if (!PerlIO_binmode(aTHX_ IoOFP(io),IoTYPE(io),
778 mode_from_discipline(discp),
779 (discp) ? SvPV_nolen_const(discp) : NULL)) {
799 const I32 markoff = MARK - PL_stack_base;
800 const char *methname;
801 int how = PERL_MAGIC_tied;
805 switch(SvTYPE(varsv)) {
807 methname = "TIEHASH";
808 HvEITER_set((HV *)varsv, 0);
811 methname = "TIEARRAY";
814 #ifdef GV_UNIQUE_CHECK
815 if (GvUNIQUE((GV*)varsv)) {
816 Perl_croak(aTHX_ "Attempt to tie unique GV");
819 methname = "TIEHANDLE";
820 how = PERL_MAGIC_tiedscalar;
821 /* For tied filehandles, we apply tiedscalar magic to the IO
822 slot of the GP rather than the GV itself. AMS 20010812 */
824 GvIOp(varsv) = newIO();
825 varsv = (SV *)GvIOp(varsv);
828 methname = "TIESCALAR";
829 how = PERL_MAGIC_tiedscalar;
833 if (sv_isobject(*MARK)) {
835 PUSHSTACKi(PERLSI_MAGIC);
837 EXTEND(SP,(I32)items);
841 call_method(methname, G_SCALAR);
844 /* Not clear why we don't call call_method here too.
845 * perhaps to get different error message ?
847 stash = gv_stashsv(*MARK, FALSE);
848 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
849 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
850 methname, (void*)*MARK);
853 PUSHSTACKi(PERLSI_MAGIC);
855 EXTEND(SP,(I32)items);
859 call_sv((SV*)GvCV(gv), G_SCALAR);
865 if (sv_isobject(sv)) {
866 sv_unmagic(varsv, how);
867 /* Croak if a self-tie on an aggregate is attempted. */
868 if (varsv == SvRV(sv) &&
869 (SvTYPE(varsv) == SVt_PVAV ||
870 SvTYPE(varsv) == SVt_PVHV))
872 "Self-ties of arrays and hashes are not supported");
873 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
876 SP = PL_stack_base + markoff;
886 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
887 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
889 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
892 if ((mg = SvTIED_mg(sv, how))) {
893 SV * const obj = SvRV(SvTIED_obj(sv, mg));
895 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
897 if (gv && isGV(gv) && (cv = GvCV(gv))) {
899 XPUSHs(SvTIED_obj((SV*)gv, mg));
900 XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
903 call_sv((SV *)cv, G_VOID);
907 else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
908 Perl_warner(aTHX_ packWARN(WARN_UNTIE),
909 "untie attempted while %"UVuf" inner references still exist",
910 (UV)SvREFCNT(obj) - 1 ) ;
914 sv_unmagic(sv, how) ;
924 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
925 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
927 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
930 if ((mg = SvTIED_mg(sv, how))) {
931 SV *osv = SvTIED_obj(sv, mg);
932 if (osv == mg->mg_obj)
933 osv = sv_mortalcopy(osv);
947 HV * const hv = (HV*)POPs;
948 SV * const sv = sv_2mortal(newSVpvs("AnyDBM_File"));
949 stash = gv_stashsv(sv, FALSE);
950 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
952 require_pv("AnyDBM_File.pm");
954 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
955 DIE(aTHX_ "No dbm on this machine");
965 PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
967 PUSHs(sv_2mortal(newSVuv(O_RDWR)));
970 call_sv((SV*)GvCV(gv), G_SCALAR);
973 if (!sv_isobject(TOPs)) {
978 PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
981 call_sv((SV*)GvCV(gv), G_SCALAR);
985 if (sv_isobject(TOPs)) {
986 sv_unmagic((SV *) hv, PERL_MAGIC_tied);
987 sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, NULL, 0);
1004 struct timeval timebuf;
1005 struct timeval *tbuf = &timebuf;
1008 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1013 # if BYTEORDER & 0xf0000
1014 # define ORDERBYTE (0x88888888 - BYTEORDER)
1016 # define ORDERBYTE (0x4444 - BYTEORDER)
1022 for (i = 1; i <= 3; i++) {
1023 SV * const sv = SP[i];
1026 if (SvREADONLY(sv)) {
1028 sv_force_normal_flags(sv, 0);
1029 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1030 DIE(aTHX_ PL_no_modify);
1033 if (ckWARN(WARN_MISC))
1034 Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1035 SvPV_force_nolen(sv); /* force string conversion */
1042 /* little endians can use vecs directly */
1043 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1050 masksize = NFDBITS / NBBY;
1052 masksize = sizeof(long); /* documented int, everyone seems to use long */
1054 Zero(&fd_sets[0], 4, char*);
1057 # if SELECT_MIN_BITS == 1
1058 growsize = sizeof(fd_set);
1060 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1061 # undef SELECT_MIN_BITS
1062 # define SELECT_MIN_BITS __FD_SETSIZE
1064 /* If SELECT_MIN_BITS is greater than one we most probably will want
1065 * to align the sizes with SELECT_MIN_BITS/8 because for example
1066 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1067 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1068 * on (sets/tests/clears bits) is 32 bits. */
1069 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1077 timebuf.tv_sec = (long)value;
1078 value -= (NV)timebuf.tv_sec;
1079 timebuf.tv_usec = (long)(value * 1000000.0);
1084 for (i = 1; i <= 3; i++) {
1086 if (!SvOK(sv) || SvCUR(sv) == 0) {
1093 Sv_Grow(sv, growsize);
1097 while (++j <= growsize) {
1101 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1103 Newx(fd_sets[i], growsize, char);
1104 for (offset = 0; offset < growsize; offset += masksize) {
1105 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1106 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1109 fd_sets[i] = SvPVX(sv);
1113 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1114 /* Can't make just the (void*) conditional because that would be
1115 * cpp #if within cpp macro, and not all compilers like that. */
1116 nfound = PerlSock_select(
1118 (Select_fd_set_t) fd_sets[1],
1119 (Select_fd_set_t) fd_sets[2],
1120 (Select_fd_set_t) fd_sets[3],
1121 (void*) tbuf); /* Workaround for compiler bug. */
1123 nfound = PerlSock_select(
1125 (Select_fd_set_t) fd_sets[1],
1126 (Select_fd_set_t) fd_sets[2],
1127 (Select_fd_set_t) fd_sets[3],
1130 for (i = 1; i <= 3; i++) {
1133 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1135 for (offset = 0; offset < growsize; offset += masksize) {
1136 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1137 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1139 Safefree(fd_sets[i]);
1146 if (GIMME == G_ARRAY && tbuf) {
1147 value = (NV)(timebuf.tv_sec) +
1148 (NV)(timebuf.tv_usec) / 1000000.0;
1149 PUSHs(sv_2mortal(newSVnv(value)));
1153 DIE(aTHX_ "select not implemented");
1158 Perl_setdefout(pTHX_ GV *gv)
1161 SvREFCNT_inc_simple_void(gv);
1163 SvREFCNT_dec(PL_defoutgv);
1171 GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : NULL;
1172 GV * egv = GvEGV(PL_defoutgv);
1178 XPUSHs(&PL_sv_undef);
1180 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1181 if (gvp && *gvp == egv) {
1182 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1186 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1191 if (!GvIO(newdefout))
1192 gv_IOadd(newdefout);
1193 setdefout(newdefout);
1203 GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs;
1205 if (gv && (io = GvIO(gv))) {
1206 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1208 const I32 gimme = GIMME_V;
1210 XPUSHs(SvTIED_obj((SV*)io, mg));
1213 call_method("GETC", gimme);
1216 if (gimme == G_SCALAR)
1217 SvSetMagicSV_nosteal(TARG, TOPs);
1221 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1222 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1223 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1224 report_evil_fh(gv, io, PL_op->op_type);
1225 SETERRNO(EBADF,RMS_IFI);
1229 sv_setpvn(TARG, " ", 1);
1230 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1231 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1232 /* Find out how many bytes the char needs */
1233 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1236 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1237 SvCUR_set(TARG,1+len);
1246 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1249 register PERL_CONTEXT *cx;
1250 const I32 gimme = GIMME_V;
1255 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1257 cx->blk_sub.retop = retop;
1259 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1261 setdefout(gv); /* locally select filehandle so $% et al work */
1293 goto not_a_format_reference;
1298 tmpsv = sv_newmortal();
1299 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1300 name = SvPV_nolen_const(tmpsv);
1302 DIE(aTHX_ "Undefined format \"%s\" called", name);
1304 not_a_format_reference:
1305 DIE(aTHX_ "Not a format reference");
1308 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1310 IoFLAGS(io) &= ~IOf_DIDTOP;
1311 return doform(cv,gv,PL_op->op_next);
1317 GV * const gv = cxstack[cxstack_ix].blk_sub.gv;
1318 register IO * const io = GvIOp(gv);
1323 register PERL_CONTEXT *cx;
1325 if (!io || !(ofp = IoOFP(io)))
1328 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1329 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1331 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1332 PL_formtarget != PL_toptarget)
1336 if (!IoTOP_GV(io)) {
1339 if (!IoTOP_NAME(io)) {
1341 if (!IoFMT_NAME(io))
1342 IoFMT_NAME(io) = savepv(GvNAME(gv));
1343 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1344 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1345 if ((topgv && GvFORM(topgv)) ||
1346 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1347 IoTOP_NAME(io) = savesvpv(topname);
1349 IoTOP_NAME(io) = savepvs("top");
1351 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1352 if (!topgv || !GvFORM(topgv)) {
1353 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1356 IoTOP_GV(io) = topgv;
1358 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1359 I32 lines = IoLINES_LEFT(io);
1360 const char *s = SvPVX_const(PL_formtarget);
1361 if (lines <= 0) /* Yow, header didn't even fit!!! */
1363 while (lines-- > 0) {
1364 s = strchr(s, '\n');
1370 const STRLEN save = SvCUR(PL_formtarget);
1371 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1372 do_print(PL_formtarget, ofp);
1373 SvCUR_set(PL_formtarget, save);
1374 sv_chop(PL_formtarget, s);
1375 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1378 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1379 do_print(PL_formfeed, ofp);
1380 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1382 PL_formtarget = PL_toptarget;
1383 IoFLAGS(io) |= IOf_DIDTOP;
1386 DIE(aTHX_ "bad top format reference");
1389 SV * const sv = sv_newmortal();
1391 gv_efullname4(sv, fgv, NULL, FALSE);
1392 name = SvPV_nolen_const(sv);
1394 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1396 DIE(aTHX_ "Undefined top format called");
1398 if (cv && CvCLONE(cv))
1399 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1400 return doform(cv, gv, PL_op);
1404 POPBLOCK(cx,PL_curpm);
1410 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1412 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1413 else if (ckWARN(WARN_CLOSED))
1414 report_evil_fh(gv, io, PL_op->op_type);
1419 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1420 if (ckWARN(WARN_IO))
1421 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1423 if (!do_print(PL_formtarget, fp))
1426 FmLINES(PL_formtarget) = 0;
1427 SvCUR_set(PL_formtarget, 0);
1428 *SvEND(PL_formtarget) = '\0';
1429 if (IoFLAGS(io) & IOf_FLUSH)
1430 (void)PerlIO_flush(fp);
1435 PL_formtarget = PL_bodytarget;
1437 PERL_UNUSED_VAR(newsp);
1438 PERL_UNUSED_VAR(gimme);
1439 return cx->blk_sub.retop;
1444 dVAR; dSP; dMARK; dORIGMARK;
1449 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
1451 if (gv && (io = GvIO(gv))) {
1452 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1454 if (MARK == ORIGMARK) {
1457 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1461 *MARK = SvTIED_obj((SV*)io, mg);
1464 call_method("PRINTF", G_SCALAR);
1467 MARK = ORIGMARK + 1;
1475 if (!(io = GvIO(gv))) {
1476 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1477 report_evil_fh(gv, io, PL_op->op_type);
1478 SETERRNO(EBADF,RMS_IFI);
1481 else if (!(fp = IoOFP(io))) {
1482 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1484 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1485 else if (ckWARN(WARN_CLOSED))
1486 report_evil_fh(gv, io, PL_op->op_type);
1488 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1492 do_sprintf(sv, SP - MARK, MARK + 1);
1493 if (!do_print(sv, fp))
1496 if (IoFLAGS(io) & IOf_FLUSH)
1497 if (PerlIO_flush(fp) == EOF)
1508 PUSHs(&PL_sv_undef);
1516 const int perm = (MAXARG > 3) ? POPi : 0666;
1517 const int mode = POPi;
1518 SV * const sv = POPs;
1519 GV * const gv = (GV *)POPs;
1522 /* Need TIEHANDLE method ? */
1523 const char * const tmps = SvPV_const(sv, len);
1524 /* FIXME? do_open should do const */
1525 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1526 IoLINES(GvIOp(gv)) = 0;
1530 PUSHs(&PL_sv_undef);
1537 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1543 Sock_size_t bufsize;
1551 bool charstart = FALSE;
1552 STRLEN charskip = 0;
1555 GV * const gv = (GV*)*++MARK;
1556 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1557 && gv && (io = GvIO(gv)) )
1559 const MAGIC * mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1563 *MARK = SvTIED_obj((SV*)io, mg);
1565 call_method("READ", G_SCALAR);
1579 sv_setpvn(bufsv, "", 0);
1580 length = SvIVx(*++MARK);
1583 offset = SvIVx(*++MARK);
1587 if (!io || !IoIFP(io)) {
1588 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1589 report_evil_fh(gv, io, PL_op->op_type);
1590 SETERRNO(EBADF,RMS_IFI);
1593 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1594 buffer = SvPVutf8_force(bufsv, blen);
1595 /* UTF-8 may not have been set if they are all low bytes */
1600 buffer = SvPV_force(bufsv, blen);
1601 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1604 DIE(aTHX_ "Negative length");
1612 if (PL_op->op_type == OP_RECV) {
1613 char namebuf[MAXPATHLEN];
1614 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1615 bufsize = sizeof (struct sockaddr_in);
1617 bufsize = sizeof namebuf;
1619 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1623 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1624 /* 'offset' means 'flags' here */
1625 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1626 (struct sockaddr *)namebuf, &bufsize);
1630 /* Bogus return without padding */
1631 bufsize = sizeof (struct sockaddr_in);
1633 SvCUR_set(bufsv, count);
1634 *SvEND(bufsv) = '\0';
1635 (void)SvPOK_only(bufsv);
1639 /* This should not be marked tainted if the fp is marked clean */
1640 if (!(IoFLAGS(io) & IOf_UNTAINT))
1641 SvTAINTED_on(bufsv);
1643 sv_setpvn(TARG, namebuf, bufsize);
1648 if (PL_op->op_type == OP_RECV)
1649 DIE(aTHX_ PL_no_sock_func, "recv");
1651 if (DO_UTF8(bufsv)) {
1652 /* offset adjust in characters not bytes */
1653 blen = sv_len_utf8(bufsv);
1656 if (-offset > (int)blen)
1657 DIE(aTHX_ "Offset outside string");
1660 if (DO_UTF8(bufsv)) {
1661 /* convert offset-as-chars to offset-as-bytes */
1662 if (offset >= (int)blen)
1663 offset += SvCUR(bufsv) - blen;
1665 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1668 bufsize = SvCUR(bufsv);
1669 /* Allocating length + offset + 1 isn't perfect in the case of reading
1670 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1672 (should be 2 * length + offset + 1, or possibly something longer if
1673 PL_encoding is true) */
1674 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1675 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1676 Zero(buffer+bufsize, offset-bufsize, char);
1678 buffer = buffer + offset;
1680 read_target = bufsv;
1682 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1683 concatenate it to the current buffer. */
1685 /* Truncate the existing buffer to the start of where we will be
1687 SvCUR_set(bufsv, offset);
1689 read_target = sv_newmortal();
1690 SvUPGRADE(read_target, SVt_PV);
1691 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1694 if (PL_op->op_type == OP_SYSREAD) {
1695 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1696 if (IoTYPE(io) == IoTYPE_SOCKET) {
1697 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1703 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1708 #ifdef HAS_SOCKET__bad_code_maybe
1709 if (IoTYPE(io) == IoTYPE_SOCKET) {
1710 char namebuf[MAXPATHLEN];
1711 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1712 bufsize = sizeof (struct sockaddr_in);
1714 bufsize = sizeof namebuf;
1716 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1717 (struct sockaddr *)namebuf, &bufsize);
1722 count = PerlIO_read(IoIFP(io), buffer, length);
1723 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1724 if (count == 0 && PerlIO_error(IoIFP(io)))
1728 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1729 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1732 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1733 *SvEND(read_target) = '\0';
1734 (void)SvPOK_only(read_target);
1735 if (fp_utf8 && !IN_BYTES) {
1736 /* Look at utf8 we got back and count the characters */
1737 const char *bend = buffer + count;
1738 while (buffer < bend) {
1740 skip = UTF8SKIP(buffer);
1743 if (buffer - charskip + skip > bend) {
1744 /* partial character - try for rest of it */
1745 length = skip - (bend-buffer);
1746 offset = bend - SvPVX_const(bufsv);
1758 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1759 provided amount read (count) was what was requested (length)
1761 if (got < wanted && count == length) {
1762 length = wanted - got;
1763 offset = bend - SvPVX_const(bufsv);
1766 /* return value is character count */
1770 else if (buffer_utf8) {
1771 /* Let svcatsv upgrade the bytes we read in to utf8.
1772 The buffer is a mortal so will be freed soon. */
1773 sv_catsv_nomg(bufsv, read_target);
1776 /* This should not be marked tainted if the fp is marked clean */
1777 if (!(IoFLAGS(io) & IOf_UNTAINT))
1778 SvTAINTED_on(bufsv);
1790 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1796 STRLEN orig_blen_bytes;
1797 const int op_type = PL_op->op_type;
1801 GV *const gv = (GV*)*++MARK;
1802 if (PL_op->op_type == OP_SYSWRITE
1803 && gv && (io = GvIO(gv))) {
1804 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1808 if (MARK == SP - 1) {
1810 sv = sv_2mortal(newSViv(sv_len(*SP)));
1816 *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg);
1818 call_method("WRITE", G_SCALAR);
1834 if (!io || !IoIFP(io)) {
1836 if (ckWARN(WARN_CLOSED))
1837 report_evil_fh(gv, io, PL_op->op_type);
1838 SETERRNO(EBADF,RMS_IFI);
1842 /* Do this first to trigger any overloading. */
1843 buffer = SvPV_const(bufsv, blen);
1844 orig_blen_bytes = blen;
1845 doing_utf8 = DO_UTF8(bufsv);
1847 if (PerlIO_isutf8(IoIFP(io))) {
1848 if (!SvUTF8(bufsv)) {
1849 /* We don't modify the original scalar. */
1850 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1851 buffer = (char *) tmpbuf;
1855 else if (doing_utf8) {
1856 STRLEN tmplen = blen;
1857 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1860 buffer = (char *) tmpbuf;
1864 assert((char *)result == buffer);
1865 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1869 if (op_type == OP_SYSWRITE) {
1870 Size_t length = 0; /* This length is in characters. */
1876 /* The SV is bytes, and we've had to upgrade it. */
1877 blen_chars = orig_blen_bytes;
1879 /* The SV really is UTF-8. */
1880 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1881 /* Don't call sv_len_utf8 again because it will call magic
1882 or overloading a second time, and we might get back a
1883 different result. */
1884 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1886 /* It's safe, and it may well be cached. */
1887 blen_chars = sv_len_utf8(bufsv);
1895 length = blen_chars;
1897 #if Size_t_size > IVSIZE
1898 length = (Size_t)SvNVx(*++MARK);
1900 length = (Size_t)SvIVx(*++MARK);
1902 if ((SSize_t)length < 0) {
1904 DIE(aTHX_ "Negative length");
1909 offset = SvIVx(*++MARK);
1911 if (-offset > (IV)blen_chars) {
1913 DIE(aTHX_ "Offset outside string");
1915 offset += blen_chars;
1916 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1918 DIE(aTHX_ "Offset outside string");
1922 if (length > blen_chars - offset)
1923 length = blen_chars - offset;
1925 /* Here we convert length from characters to bytes. */
1926 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1927 /* Either we had to convert the SV, or the SV is magical, or
1928 the SV has overloading, in which case we can't or mustn't
1929 or mustn't call it again. */
1931 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1932 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1934 /* It's a real UTF-8 SV, and it's not going to change under
1935 us. Take advantage of any cache. */
1937 I32 len_I32 = length;
1939 /* Convert the start and end character positions to bytes.
1940 Remember that the second argument to sv_pos_u2b is relative
1942 sv_pos_u2b(bufsv, &start, &len_I32);
1949 buffer = buffer+offset;
1951 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1952 if (IoTYPE(io) == IoTYPE_SOCKET) {
1953 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1959 /* See the note at doio.c:do_print about filesize limits. --jhi */
1960 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1966 const int flags = SvIVx(*++MARK);
1969 char * const sockbuf = SvPVx(*++MARK, mlen);
1970 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1971 flags, (struct sockaddr *)sockbuf, mlen);
1975 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1980 DIE(aTHX_ PL_no_sock_func, "send");
1987 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
1990 #if Size_t_size > IVSIZE
2009 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
2011 gv = PL_last_in_gv = GvEGV(PL_argvgv);
2013 if (io && !IoIFP(io)) {
2014 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2016 IoFLAGS(io) &= ~IOf_START;
2017 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2018 sv_setpvn(GvSV(gv), "-", 1);
2019 SvSETMAGIC(GvSV(gv));
2021 else if (!nextargv(gv))
2026 gv = PL_last_in_gv; /* eof */
2029 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
2032 IO * const io = GvIO(gv);
2034 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
2036 XPUSHs(SvTIED_obj((SV*)io, mg));
2039 call_method("EOF", G_SCALAR);
2046 PUSHs(boolSV(!gv || do_eof(gv)));
2057 PL_last_in_gv = (GV*)POPs;
2060 if (gv && (io = GvIO(gv))) {
2061 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2064 XPUSHs(SvTIED_obj((SV*)io, mg));
2067 call_method("TELL", G_SCALAR);
2074 #if LSEEKSIZE > IVSIZE
2075 PUSHn( do_tell(gv) );
2077 PUSHi( do_tell(gv) );
2085 const int whence = POPi;
2086 #if LSEEKSIZE > IVSIZE
2087 const Off_t offset = (Off_t)SvNVx(POPs);
2089 const Off_t offset = (Off_t)SvIVx(POPs);
2092 GV * const gv = PL_last_in_gv = (GV*)POPs;
2095 if (gv && (io = GvIO(gv))) {
2096 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2099 XPUSHs(SvTIED_obj((SV*)io, mg));
2100 #if LSEEKSIZE > IVSIZE
2101 XPUSHs(sv_2mortal(newSVnv((NV) offset)));
2103 XPUSHs(sv_2mortal(newSViv(offset)));
2105 XPUSHs(sv_2mortal(newSViv(whence)));
2108 call_method("SEEK", G_SCALAR);
2115 if (PL_op->op_type == OP_SEEK)
2116 PUSHs(boolSV(do_seek(gv, offset, whence)));
2118 const Off_t sought = do_sysseek(gv, offset, whence);
2120 PUSHs(&PL_sv_undef);
2122 SV* const sv = sought ?
2123 #if LSEEKSIZE > IVSIZE
2128 : newSVpvn(zero_but_true, ZBTLEN);
2129 PUSHs(sv_2mortal(sv));
2139 /* There seems to be no consensus on the length type of truncate()
2140 * and ftruncate(), both off_t and size_t have supporters. In
2141 * general one would think that when using large files, off_t is
2142 * at least as wide as size_t, so using an off_t should be okay. */
2143 /* XXX Configure probe for the length type of *truncate() needed XXX */
2146 #if Off_t_size > IVSIZE
2151 /* Checking for length < 0 is problematic as the type might or
2152 * might not be signed: if it is not, clever compilers will moan. */
2153 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2160 if (PL_op->op_flags & OPf_SPECIAL) {
2161 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2170 TAINT_PROPER("truncate");
2171 if (!(fp = IoIFP(io))) {
2177 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2179 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2186 SV * const sv = POPs;
2189 if (SvTYPE(sv) == SVt_PVGV) {
2190 tmpgv = (GV*)sv; /* *main::FRED for example */
2191 goto do_ftruncate_gv;
2193 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2194 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
2195 goto do_ftruncate_gv;
2197 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2198 io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
2199 goto do_ftruncate_io;
2202 name = SvPV_nolen_const(sv);
2203 TAINT_PROPER("truncate");
2205 if (truncate(name, len) < 0)
2209 const int tmpfd = PerlLIO_open(name, O_RDWR);
2214 if (my_chsize(tmpfd, len) < 0)
2216 PerlLIO_close(tmpfd);
2225 SETERRNO(EBADF,RMS_IFI);
2233 SV * const argsv = POPs;
2234 const unsigned int func = POPu;
2235 const int optype = PL_op->op_type;
2236 GV * const gv = (GV*)POPs;
2237 IO * const io = gv ? GvIOn(gv) : NULL;
2241 if (!io || !argsv || !IoIFP(io)) {
2242 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2243 report_evil_fh(gv, io, PL_op->op_type);
2244 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2248 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2251 s = SvPV_force(argsv, len);
2252 need = IOCPARM_LEN(func);
2254 s = Sv_Grow(argsv, need + 1);
2255 SvCUR_set(argsv, need);
2258 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2261 retval = SvIV(argsv);
2262 s = INT2PTR(char*,retval); /* ouch */
2265 TAINT_PROPER(PL_op_desc[optype]);
2267 if (optype == OP_IOCTL)
2269 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2271 DIE(aTHX_ "ioctl is not implemented");
2275 DIE(aTHX_ "fcntl is not implemented");
2277 #if defined(OS2) && defined(__EMX__)
2278 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2280 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2284 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2286 if (s[SvCUR(argsv)] != 17)
2287 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2289 s[SvCUR(argsv)] = 0; /* put our null back */
2290 SvSETMAGIC(argsv); /* Assume it has changed */
2299 PUSHp(zero_but_true, ZBTLEN);
2312 const int argtype = POPi;
2313 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
2315 if (gv && (io = GvIO(gv)))
2321 /* XXX Looks to me like io is always NULL at this point */
2323 (void)PerlIO_flush(fp);
2324 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2327 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2328 report_evil_fh(gv, io, PL_op->op_type);
2330 SETERRNO(EBADF,RMS_IFI);
2335 DIE(aTHX_ PL_no_func, "flock()");
2345 const int protocol = POPi;
2346 const int type = POPi;
2347 const int domain = POPi;
2348 GV * const gv = (GV*)POPs;
2349 register IO * const io = gv ? GvIOn(gv) : NULL;
2353 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2354 report_evil_fh(gv, io, PL_op->op_type);
2355 if (io && IoIFP(io))
2356 do_close(gv, FALSE);
2357 SETERRNO(EBADF,LIB_INVARG);
2362 do_close(gv, FALSE);
2364 TAINT_PROPER("socket");
2365 fd = PerlSock_socket(domain, type, protocol);
2368 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2369 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2370 IoTYPE(io) = IoTYPE_SOCKET;
2371 if (!IoIFP(io) || !IoOFP(io)) {
2372 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2373 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2374 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2377 #if defined(HAS_FCNTL) && defined(F_SETFD)
2378 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2382 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2387 DIE(aTHX_ PL_no_sock_func, "socket");
2393 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2395 const int protocol = POPi;
2396 const int type = POPi;
2397 const int domain = POPi;
2398 GV * const gv2 = (GV*)POPs;
2399 GV * const gv1 = (GV*)POPs;
2400 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2401 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2404 if (!gv1 || !gv2 || !io1 || !io2) {
2405 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2407 report_evil_fh(gv1, io1, PL_op->op_type);
2409 report_evil_fh(gv1, io2, PL_op->op_type);
2411 if (io1 && IoIFP(io1))
2412 do_close(gv1, FALSE);
2413 if (io2 && IoIFP(io2))
2414 do_close(gv2, FALSE);
2419 do_close(gv1, FALSE);
2421 do_close(gv2, FALSE);
2423 TAINT_PROPER("socketpair");
2424 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2426 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2427 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2428 IoTYPE(io1) = IoTYPE_SOCKET;
2429 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2430 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2431 IoTYPE(io2) = IoTYPE_SOCKET;
2432 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2433 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2434 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2435 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2436 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2437 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2438 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2441 #if defined(HAS_FCNTL) && defined(F_SETFD)
2442 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2443 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2448 DIE(aTHX_ PL_no_sock_func, "socketpair");
2456 SV * const addrsv = POPs;
2457 /* OK, so on what platform does bind modify addr? */
2459 GV * const gv = (GV*)POPs;
2460 register IO * const io = GvIOn(gv);
2463 if (!io || !IoIFP(io))
2466 addr = SvPV_const(addrsv, len);
2467 TAINT_PROPER("bind");
2468 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2474 if (ckWARN(WARN_CLOSED))
2475 report_evil_fh(gv, io, PL_op->op_type);
2476 SETERRNO(EBADF,SS_IVCHAN);
2479 DIE(aTHX_ PL_no_sock_func, "bind");
2487 SV * const addrsv = POPs;
2488 GV * const gv = (GV*)POPs;
2489 register IO * const io = GvIOn(gv);
2493 if (!io || !IoIFP(io))
2496 addr = SvPV_const(addrsv, len);
2497 TAINT_PROPER("connect");
2498 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2504 if (ckWARN(WARN_CLOSED))
2505 report_evil_fh(gv, io, PL_op->op_type);
2506 SETERRNO(EBADF,SS_IVCHAN);
2509 DIE(aTHX_ PL_no_sock_func, "connect");
2517 const int backlog = POPi;
2518 GV * const gv = (GV*)POPs;
2519 register IO * const io = gv ? GvIOn(gv) : NULL;
2521 if (!gv || !io || !IoIFP(io))
2524 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2530 if (ckWARN(WARN_CLOSED))
2531 report_evil_fh(gv, io, PL_op->op_type);
2532 SETERRNO(EBADF,SS_IVCHAN);
2535 DIE(aTHX_ PL_no_sock_func, "listen");
2545 char namebuf[MAXPATHLEN];
2546 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2547 Sock_size_t len = sizeof (struct sockaddr_in);
2549 Sock_size_t len = sizeof namebuf;
2551 GV * const ggv = (GV*)POPs;
2552 GV * const ngv = (GV*)POPs;
2561 if (!gstio || !IoIFP(gstio))
2565 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2568 /* Some platforms indicate zero length when an AF_UNIX client is
2569 * not bound. Simulate a non-zero-length sockaddr structure in
2571 namebuf[0] = 0; /* sun_len */
2572 namebuf[1] = AF_UNIX; /* sun_family */
2580 do_close(ngv, FALSE);
2581 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2582 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2583 IoTYPE(nstio) = IoTYPE_SOCKET;
2584 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2585 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2586 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2587 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2590 #if defined(HAS_FCNTL) && defined(F_SETFD)
2591 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2595 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2596 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2598 #ifdef __SCO_VERSION__
2599 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2602 PUSHp(namebuf, len);
2606 if (ckWARN(WARN_CLOSED))
2607 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2608 SETERRNO(EBADF,SS_IVCHAN);
2614 DIE(aTHX_ PL_no_sock_func, "accept");
2622 const int how = POPi;
2623 GV * const gv = (GV*)POPs;
2624 register IO * const io = GvIOn(gv);
2626 if (!io || !IoIFP(io))
2629 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2633 if (ckWARN(WARN_CLOSED))
2634 report_evil_fh(gv, io, PL_op->op_type);
2635 SETERRNO(EBADF,SS_IVCHAN);
2638 DIE(aTHX_ PL_no_sock_func, "shutdown");
2646 const int optype = PL_op->op_type;
2647 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2648 const unsigned int optname = (unsigned int) POPi;
2649 const unsigned int lvl = (unsigned int) POPi;
2650 GV * const gv = (GV*)POPs;
2651 register IO * const io = GvIOn(gv);
2655 if (!io || !IoIFP(io))
2658 fd = PerlIO_fileno(IoIFP(io));
2662 (void)SvPOK_only(sv);
2666 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2673 #if defined(__SYMBIAN32__)
2674 # define SETSOCKOPT_OPTION_VALUE_T void *
2676 # define SETSOCKOPT_OPTION_VALUE_T const char *
2678 /* XXX TODO: We need to have a proper type (a Configure probe,
2679 * etc.) for what the C headers think of the third argument of
2680 * setsockopt(), the option_value read-only buffer: is it
2681 * a "char *", or a "void *", const or not. Some compilers
2682 * don't take kindly to e.g. assuming that "char *" implicitly
2683 * promotes to a "void *", or to explicitly promoting/demoting
2684 * consts to non/vice versa. The "const void *" is the SUS
2685 * definition, but that does not fly everywhere for the above
2687 SETSOCKOPT_OPTION_VALUE_T buf;
2691 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2695 aint = (int)SvIV(sv);
2696 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2699 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2708 if (ckWARN(WARN_CLOSED))
2709 report_evil_fh(gv, io, optype);
2710 SETERRNO(EBADF,SS_IVCHAN);
2715 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2723 const int optype = PL_op->op_type;
2724 GV * const gv = (GV*)POPs;
2725 register IO * const io = GvIOn(gv);
2730 if (!io || !IoIFP(io))
2733 sv = sv_2mortal(newSV(257));
2734 (void)SvPOK_only(sv);
2738 fd = PerlIO_fileno(IoIFP(io));
2740 case OP_GETSOCKNAME:
2741 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2744 case OP_GETPEERNAME:
2745 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2747 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2749 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";
2750 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2751 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2752 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2753 sizeof(u_short) + sizeof(struct in_addr))) {
2760 #ifdef BOGUS_GETNAME_RETURN
2761 /* Interactive Unix, getpeername() and getsockname()
2762 does not return valid namelen */
2763 if (len == BOGUS_GETNAME_RETURN)
2764 len = sizeof(struct sockaddr);
2772 if (ckWARN(WARN_CLOSED))
2773 report_evil_fh(gv, io, optype);
2774 SETERRNO(EBADF,SS_IVCHAN);
2779 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2794 if (PL_op->op_flags & OPf_REF) {
2796 if (PL_op->op_type == OP_LSTAT) {
2797 if (gv != PL_defgv) {
2798 do_fstat_warning_check:
2799 if (ckWARN(WARN_IO))
2800 Perl_warner(aTHX_ packWARN(WARN_IO),
2801 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2802 } else if (PL_laststype != OP_LSTAT)
2803 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2807 if (gv != PL_defgv) {
2808 PL_laststype = OP_STAT;
2810 sv_setpvn(PL_statname, "", 0);
2817 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2818 } else if (IoDIRP(io)) {
2821 PerlLIO_fstat(dirfd(IoDIRP(io)), &PL_statcache);
2823 DIE(aTHX_ PL_no_func, "dirfd");
2826 PL_laststatval = -1;
2832 if (PL_laststatval < 0) {
2833 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2834 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2839 SV* const sv = POPs;
2840 if (SvTYPE(sv) == SVt_PVGV) {
2843 } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2845 if (PL_op->op_type == OP_LSTAT)
2846 goto do_fstat_warning_check;
2848 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2850 if (PL_op->op_type == OP_LSTAT)
2851 goto do_fstat_warning_check;
2852 goto do_fstat_have_io;
2855 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2857 PL_laststype = PL_op->op_type;
2858 if (PL_op->op_type == OP_LSTAT)
2859 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2861 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2862 if (PL_laststatval < 0) {
2863 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2864 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2870 if (gimme != G_ARRAY) {
2871 if (gimme != G_VOID)
2872 XPUSHs(boolSV(max));
2878 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2879 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2880 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2881 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2882 #if Uid_t_size > IVSIZE
2883 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2885 # if Uid_t_sign <= 0
2886 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2888 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2891 #if Gid_t_size > IVSIZE
2892 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2894 # if Gid_t_sign <= 0
2895 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2897 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2900 #ifdef USE_STAT_RDEV
2901 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2903 PUSHs(sv_2mortal(newSVpvs("")));
2905 #if Off_t_size > IVSIZE
2906 PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
2908 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2911 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2912 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2913 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2915 PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2916 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2917 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
2919 #ifdef USE_STAT_BLOCKS
2920 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2921 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2923 PUSHs(sv_2mortal(newSVpvs("")));
2924 PUSHs(sv_2mortal(newSVpvs("")));
2930 /* This macro is used by the stacked filetest operators :
2931 * if the previous filetest failed, short-circuit and pass its value.
2932 * Else, discard it from the stack and continue. --rgs
2934 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2935 if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
2936 else { (void)POPs; PUTBACK; } \
2943 /* Not const, because things tweak this below. Not bool, because there's
2944 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2945 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2946 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2947 /* Giving some sort of initial value silences compilers. */
2949 int access_mode = R_OK;
2951 int access_mode = 0;
2954 /* access_mode is never used, but leaving use_access in makes the
2955 conditional compiling below much clearer. */
2958 int stat_mode = S_IRUSR;
2960 bool effective = FALSE;
2963 STACKED_FTEST_CHECK;
2965 switch (PL_op->op_type) {
2967 #if !(defined(HAS_ACCESS) && defined(R_OK))
2973 #if defined(HAS_ACCESS) && defined(W_OK)
2978 stat_mode = S_IWUSR;
2982 #if defined(HAS_ACCESS) && defined(X_OK)
2987 stat_mode = S_IXUSR;
2991 #ifdef PERL_EFF_ACCESS
2994 stat_mode = S_IWUSR;
2998 #ifndef PERL_EFF_ACCESS
3006 #ifdef PERL_EFF_ACCESS
3011 stat_mode = S_IXUSR;
3017 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3018 const char *const name = POPpx;
3020 # ifdef PERL_EFF_ACCESS
3021 result = PERL_EFF_ACCESS(name, access_mode);
3023 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3029 result = access(name, access_mode);
3031 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3046 if (cando(stat_mode, effective, &PL_statcache))
3055 const int op_type = PL_op->op_type;
3057 STACKED_FTEST_CHECK;
3062 if (op_type == OP_FTIS)
3065 /* You can't dTARGET inside OP_FTIS, because you'll get
3066 "panic: pad_sv po" - the op is not flagged to have a target. */
3070 #if Off_t_size > IVSIZE
3071 PUSHn(PL_statcache.st_size);
3073 PUSHi(PL_statcache.st_size);
3077 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3080 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3083 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3096 /* I believe that all these three are likely to be defined on most every
3097 system these days. */
3099 if(PL_op->op_type == OP_FTSUID)
3103 if(PL_op->op_type == OP_FTSGID)
3107 if(PL_op->op_type == OP_FTSVTX)
3111 STACKED_FTEST_CHECK;
3116 switch (PL_op->op_type) {
3118 if (PL_statcache.st_uid == PL_uid)
3122 if (PL_statcache.st_uid == PL_euid)
3126 if (PL_statcache.st_size == 0)
3130 if (S_ISSOCK(PL_statcache.st_mode))
3134 if (S_ISCHR(PL_statcache.st_mode))
3138 if (S_ISBLK(PL_statcache.st_mode))
3142 if (S_ISREG(PL_statcache.st_mode))
3146 if (S_ISDIR(PL_statcache.st_mode))
3150 if (S_ISFIFO(PL_statcache.st_mode))
3155 if (PL_statcache.st_mode & S_ISUID)
3161 if (PL_statcache.st_mode & S_ISGID)
3167 if (PL_statcache.st_mode & S_ISVTX)
3178 I32 result = my_lstat();
3182 if (S_ISLNK(PL_statcache.st_mode))
3195 STACKED_FTEST_CHECK;
3197 if (PL_op->op_flags & OPf_REF)
3199 else if (isGV(TOPs))
3201 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3202 gv = (GV*)SvRV(POPs);
3204 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3206 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3207 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3208 else if (tmpsv && SvOK(tmpsv)) {
3209 const char *tmps = SvPV_nolen_const(tmpsv);
3217 if (PerlLIO_isatty(fd))
3222 #if defined(atarist) /* this will work with atariST. Configure will
3223 make guesses for other systems. */
3224 # define FILE_base(f) ((f)->_base)
3225 # define FILE_ptr(f) ((f)->_ptr)
3226 # define FILE_cnt(f) ((f)->_cnt)
3227 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3238 register STDCHAR *s;
3244 STACKED_FTEST_CHECK;
3246 if (PL_op->op_flags & OPf_REF)
3248 else if (isGV(TOPs))
3250 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3251 gv = (GV*)SvRV(POPs);
3257 if (gv == PL_defgv) {
3259 io = GvIO(PL_statgv);
3262 goto really_filename;
3267 PL_laststatval = -1;
3268 sv_setpvn(PL_statname, "", 0);
3269 io = GvIO(PL_statgv);
3271 if (io && IoIFP(io)) {
3272 if (! PerlIO_has_base(IoIFP(io)))
3273 DIE(aTHX_ "-T and -B not implemented on filehandles");
3274 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3275 if (PL_laststatval < 0)
3277 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3278 if (PL_op->op_type == OP_FTTEXT)
3283 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3284 i = PerlIO_getc(IoIFP(io));
3286 (void)PerlIO_ungetc(IoIFP(io),i);
3288 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3290 len = PerlIO_get_bufsiz(IoIFP(io));
3291 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3292 /* sfio can have large buffers - limit to 512 */
3297 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3299 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3301 SETERRNO(EBADF,RMS_IFI);
3309 PL_laststype = OP_STAT;
3310 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3311 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3312 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3314 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3317 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3318 if (PL_laststatval < 0) {
3319 (void)PerlIO_close(fp);
3322 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3323 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3324 (void)PerlIO_close(fp);
3326 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3327 RETPUSHNO; /* special case NFS directories */
3328 RETPUSHYES; /* null file is anything */
3333 /* now scan s to look for textiness */
3334 /* XXX ASCII dependent code */
3336 #if defined(DOSISH) || defined(USEMYBINMODE)
3337 /* ignore trailing ^Z on short files */
3338 if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3342 for (i = 0; i < len; i++, s++) {
3343 if (!*s) { /* null never allowed in text */
3348 else if (!(isPRINT(*s) || isSPACE(*s)))
3351 else if (*s & 128) {
3353 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3356 /* utf8 characters don't count as odd */
3357 if (UTF8_IS_START(*s)) {
3358 int ulen = UTF8SKIP(s);
3359 if (ulen < len - i) {
3361 for (j = 1; j < ulen; j++) {
3362 if (!UTF8_IS_CONTINUATION(s[j]))
3365 --ulen; /* loop does extra increment */
3375 *s != '\n' && *s != '\r' && *s != '\b' &&
3376 *s != '\t' && *s != '\f' && *s != 27)
3381 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3392 const char *tmps = NULL;
3396 SV * const sv = POPs;
3397 if (PL_op->op_flags & OPf_SPECIAL) {
3398 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3400 else if (SvTYPE(sv) == SVt_PVGV) {
3403 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
3407 tmps = SvPVx_nolen_const(sv);
3411 if( !gv && (!tmps || !*tmps) ) {
3412 HV * const table = GvHVn(PL_envgv);
3415 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3416 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3418 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3423 deprecate("chdir('') or chdir(undef) as chdir()");
3424 tmps = SvPV_nolen_const(*svp);
3428 TAINT_PROPER("chdir");
3433 TAINT_PROPER("chdir");
3436 IO* const io = GvIO(gv);
3439 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3441 else if (IoDIRP(io)) {
3443 PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0);
3445 DIE(aTHX_ PL_no_func, "dirfd");
3449 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3450 report_evil_fh(gv, io, PL_op->op_type);
3451 SETERRNO(EBADF, RMS_IFI);
3456 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3457 report_evil_fh(gv, io, PL_op->op_type);
3458 SETERRNO(EBADF,RMS_IFI);
3462 DIE(aTHX_ PL_no_func, "fchdir");
3466 PUSHi( PerlDir_chdir(tmps) >= 0 );
3468 /* Clear the DEFAULT element of ENV so we'll get the new value
3470 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3477 dVAR; dSP; dMARK; dTARGET;
3478 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3489 char * const tmps = POPpx;
3490 TAINT_PROPER("chroot");
3491 PUSHi( chroot(tmps) >= 0 );
3494 DIE(aTHX_ PL_no_func, "chroot");
3502 const char * const tmps2 = POPpconstx;
3503 const char * const tmps = SvPV_nolen_const(TOPs);
3504 TAINT_PROPER("rename");
3506 anum = PerlLIO_rename(tmps, tmps2);
3508 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3509 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3512 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3513 (void)UNLINK(tmps2);
3514 if (!(anum = link(tmps, tmps2)))
3515 anum = UNLINK(tmps);
3523 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3527 const int op_type = PL_op->op_type;
3531 if (op_type == OP_LINK)
3532 DIE(aTHX_ PL_no_func, "link");
3534 # ifndef HAS_SYMLINK
3535 if (op_type == OP_SYMLINK)
3536 DIE(aTHX_ PL_no_func, "symlink");
3540 const char * const tmps2 = POPpconstx;
3541 const char * const tmps = SvPV_nolen_const(TOPs);
3542 TAINT_PROPER(PL_op_desc[op_type]);
3544 # if defined(HAS_LINK)
3545 # if defined(HAS_SYMLINK)
3546 /* Both present - need to choose which. */
3547 (op_type == OP_LINK) ?
3548 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3550 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3551 PerlLIO_link(tmps, tmps2);
3554 # if defined(HAS_SYMLINK)
3555 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3556 symlink(tmps, tmps2);
3561 SETi( result >= 0 );
3568 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3579 char buf[MAXPATHLEN];
3582 #ifndef INCOMPLETE_TAINTS
3586 len = readlink(tmps, buf, sizeof(buf) - 1);
3594 RETSETUNDEF; /* just pretend it's a normal file */
3598 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3600 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3602 char * const save_filename = filename;
3607 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3609 Newx(cmdline, size, char);
3610 my_strlcpy(cmdline, cmd, size);
3611 my_strlcat(cmdline, " ", size);
3612 for (s = cmdline + strlen(cmdline); *filename; ) {
3616 if (s - cmdline < size)
3617 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3618 myfp = PerlProc_popen(cmdline, "r");
3622 SV * const tmpsv = sv_newmortal();
3623 /* Need to save/restore 'PL_rs' ?? */
3624 s = sv_gets(tmpsv, myfp, 0);
3625 (void)PerlProc_pclose(myfp);
3629 #ifdef HAS_SYS_ERRLIST
3634 /* you don't see this */
3635 const char * const errmsg =
3636 #ifdef HAS_SYS_ERRLIST
3644 if (instr(s, errmsg)) {
3651 #define EACCES EPERM
3653 if (instr(s, "cannot make"))
3654 SETERRNO(EEXIST,RMS_FEX);
3655 else if (instr(s, "existing file"))
3656 SETERRNO(EEXIST,RMS_FEX);
3657 else if (instr(s, "ile exists"))
3658 SETERRNO(EEXIST,RMS_FEX);
3659 else if (instr(s, "non-exist"))
3660 SETERRNO(ENOENT,RMS_FNF);
3661 else if (instr(s, "does not exist"))
3662 SETERRNO(ENOENT,RMS_FNF);
3663 else if (instr(s, "not empty"))
3664 SETERRNO(EBUSY,SS_DEVOFFLINE);
3665 else if (instr(s, "cannot access"))
3666 SETERRNO(EACCES,RMS_PRV);
3668 SETERRNO(EPERM,RMS_PRV);
3671 else { /* some mkdirs return no failure indication */
3672 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3673 if (PL_op->op_type == OP_RMDIR)
3678 SETERRNO(EACCES,RMS_PRV); /* a guess */
3687 /* This macro removes trailing slashes from a directory name.
3688 * Different operating and file systems take differently to
3689 * trailing slashes. According to POSIX 1003.1 1996 Edition
3690 * any number of trailing slashes should be allowed.
3691 * Thusly we snip them away so that even non-conforming
3692 * systems are happy.
3693 * We should probably do this "filtering" for all
3694 * the functions that expect (potentially) directory names:
3695 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3696 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3698 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3699 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3702 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3703 (tmps) = savepvn((tmps), (len)); \
3713 const int mode = (MAXARG > 1) ? POPi : 0777;
3715 TRIMSLASHES(tmps,len,copy);
3717 TAINT_PROPER("mkdir");
3719 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3723 SETi( dooneliner("mkdir", tmps) );
3724 oldumask = PerlLIO_umask(0);
3725 PerlLIO_umask(oldumask);
3726 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3741 TRIMSLASHES(tmps,len,copy);
3742 TAINT_PROPER("rmdir");
3744 SETi( PerlDir_rmdir(tmps) >= 0 );
3746 SETi( dooneliner("rmdir", tmps) );
3753 /* Directory calls. */
3757 #if defined(Direntry_t) && defined(HAS_READDIR)
3759 const char * const dirname = POPpconstx;
3760 GV * const gv = (GV*)POPs;
3761 register IO * const io = GvIOn(gv);
3767 PerlDir_close(IoDIRP(io));
3768 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3774 SETERRNO(EBADF,RMS_DIR);
3777 DIE(aTHX_ PL_no_dir_func, "opendir");
3783 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3784 DIE(aTHX_ PL_no_dir_func, "readdir");
3786 #if !defined(I_DIRENT) && !defined(VMS)
3787 Direntry_t *readdir (DIR *);
3793 const I32 gimme = GIMME;
3794 GV * const gv = (GV *)POPs;
3795 register const Direntry_t *dp;
3796 register IO * const io = GvIOn(gv);
3798 if (!io || !IoDIRP(io)) {
3799 if(ckWARN(WARN_IO)) {
3800 Perl_warner(aTHX_ packWARN(WARN_IO),
3801 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3807 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3811 sv = newSVpvn(dp->d_name, dp->d_namlen);
3813 sv = newSVpv(dp->d_name, 0);
3815 #ifndef INCOMPLETE_TAINTS
3816 if (!(IoFLAGS(io) & IOf_UNTAINT))
3819 XPUSHs(sv_2mortal(sv));
3820 } while (gimme == G_ARRAY);
3822 if (!dp && gimme != G_ARRAY)
3829 SETERRNO(EBADF,RMS_ISI);
3830 if (GIMME == G_ARRAY)
3839 #if defined(HAS_TELLDIR) || defined(telldir)
3841 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3842 /* XXX netbsd still seemed to.
3843 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3844 --JHI 1999-Feb-02 */
3845 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3846 long telldir (DIR *);
3848 GV * const gv = (GV*)POPs;
3849 register IO * const io = GvIOn(gv);
3851 if (!io || !IoDIRP(io)) {
3852 if(ckWARN(WARN_IO)) {
3853 Perl_warner(aTHX_ packWARN(WARN_IO),
3854 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3859 PUSHi( PerlDir_tell(IoDIRP(io)) );
3863 SETERRNO(EBADF,RMS_ISI);
3866 DIE(aTHX_ PL_no_dir_func, "telldir");
3872 #if defined(HAS_SEEKDIR) || defined(seekdir)
3874 const long along = POPl;
3875 GV * const gv = (GV*)POPs;
3876 register IO * const io = GvIOn(gv);
3878 if (!io || !IoDIRP(io)) {
3879 if(ckWARN(WARN_IO)) {
3880 Perl_warner(aTHX_ packWARN(WARN_IO),
3881 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3885 (void)PerlDir_seek(IoDIRP(io), along);
3890 SETERRNO(EBADF,RMS_ISI);
3893 DIE(aTHX_ PL_no_dir_func, "seekdir");
3899 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3901 GV * const gv = (GV*)POPs;
3902 register IO * const io = GvIOn(gv);
3904 if (!io || !IoDIRP(io)) {
3905 if(ckWARN(WARN_IO)) {
3906 Perl_warner(aTHX_ packWARN(WARN_IO),
3907 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3911 (void)PerlDir_rewind(IoDIRP(io));
3915 SETERRNO(EBADF,RMS_ISI);
3918 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3924 #if defined(Direntry_t) && defined(HAS_READDIR)
3926 GV * const gv = (GV*)POPs;
3927 register IO * const io = GvIOn(gv);
3929 if (!io || !IoDIRP(io)) {
3930 if(ckWARN(WARN_IO)) {
3931 Perl_warner(aTHX_ packWARN(WARN_IO),
3932 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3936 #ifdef VOID_CLOSEDIR
3937 PerlDir_close(IoDIRP(io));
3939 if (PerlDir_close(IoDIRP(io)) < 0) {
3940 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3949 SETERRNO(EBADF,RMS_IFI);
3952 DIE(aTHX_ PL_no_dir_func, "closedir");
3956 /* Process control. */
3965 PERL_FLUSHALL_FOR_CHILD;
3966 childpid = PerlProc_fork();
3970 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3972 SvREADONLY_off(GvSV(tmpgv));
3973 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3974 SvREADONLY_on(GvSV(tmpgv));
3976 #ifdef THREADS_HAVE_PIDS
3977 PL_ppid = (IV)getppid();
3979 #ifdef PERL_USES_PL_PIDSTATUS
3980 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3986 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3991 PERL_FLUSHALL_FOR_CHILD;
3992 childpid = PerlProc_fork();
3998 DIE(aTHX_ PL_no_func, "fork");
4005 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4010 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4011 childpid = wait4pid(-1, &argflags, 0);
4013 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4018 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4019 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4020 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4022 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4027 DIE(aTHX_ PL_no_func, "wait");
4033 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4035 const int optype = POPi;
4036 const Pid_t pid = TOPi;
4040 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4041 result = wait4pid(pid, &argflags, optype);
4043 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4048 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4049 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4050 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4052 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4057 DIE(aTHX_ PL_no_func, "waitpid");
4063 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4069 while (++MARK <= SP) {
4070 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4075 TAINT_PROPER("system");
4077 PERL_FLUSHALL_FOR_CHILD;
4078 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4084 if (PerlProc_pipe(pp) >= 0)
4086 while ((childpid = PerlProc_fork()) == -1) {
4087 if (errno != EAGAIN) {
4092 PerlLIO_close(pp[0]);
4093 PerlLIO_close(pp[1]);
4100 Sigsave_t ihand,qhand; /* place to save signals during system() */
4104 PerlLIO_close(pp[1]);
4106 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4107 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4110 result = wait4pid(childpid, &status, 0);
4111 } while (result == -1 && errno == EINTR);
4113 (void)rsignal_restore(SIGINT, &ihand);
4114 (void)rsignal_restore(SIGQUIT, &qhand);
4116 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4117 do_execfree(); /* free any memory child malloced on fork */
4124 while (n < sizeof(int)) {
4125 n1 = PerlLIO_read(pp[0],
4126 (void*)(((char*)&errkid)+n),
4132 PerlLIO_close(pp[0]);
4133 if (n) { /* Error */
4134 if (n != sizeof(int))
4135 DIE(aTHX_ "panic: kid popen errno read");
4136 errno = errkid; /* Propagate errno from kid */
4137 STATUS_NATIVE_CHILD_SET(-1);
4140 XPUSHi(STATUS_CURRENT);
4144 PerlLIO_close(pp[0]);
4145 #if defined(HAS_FCNTL) && defined(F_SETFD)
4146 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4149 if (PL_op->op_flags & OPf_STACKED) {
4150 SV * const really = *++MARK;
4151 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4153 else if (SP - MARK != 1)
4154 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4156 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4160 #else /* ! FORK or VMS or OS/2 */
4163 if (PL_op->op_flags & OPf_STACKED) {
4164 SV * const really = *++MARK;
4165 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4166 value = (I32)do_aspawn(really, MARK, SP);
4168 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4171 else if (SP - MARK != 1) {
4172 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4173 value = (I32)do_aspawn(NULL, MARK, SP);
4175 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4179 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4181 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4183 STATUS_NATIVE_CHILD_SET(value);
4186 XPUSHi(result ? value : STATUS_CURRENT);
4187 #endif /* !FORK or VMS */
4193 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4198 while (++MARK <= SP) {
4199 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4204 TAINT_PROPER("exec");
4206 PERL_FLUSHALL_FOR_CHILD;
4207 if (PL_op->op_flags & OPf_STACKED) {
4208 SV * const really = *++MARK;
4209 value = (I32)do_aexec(really, MARK, SP);
4211 else if (SP - MARK != 1)
4213 value = (I32)vms_do_aexec(NULL, MARK, SP);
4217 (void ) do_aspawn(NULL, MARK, SP);
4221 value = (I32)do_aexec(NULL, MARK, SP);
4226 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4229 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4232 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4246 # ifdef THREADS_HAVE_PIDS
4247 if (PL_ppid != 1 && getppid() == 1)
4248 /* maybe the parent process has died. Refresh ppid cache */
4252 XPUSHi( getppid() );
4256 DIE(aTHX_ PL_no_func, "getppid");
4265 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4268 pgrp = (I32)BSD_GETPGRP(pid);
4270 if (pid != 0 && pid != PerlProc_getpid())
4271 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4277 DIE(aTHX_ PL_no_func, "getpgrp()");
4296 TAINT_PROPER("setpgrp");
4298 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4300 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4301 || (pid != 0 && pid != PerlProc_getpid()))
4303 DIE(aTHX_ "setpgrp can't take arguments");
4305 SETi( setpgrp() >= 0 );
4306 #endif /* USE_BSDPGRP */
4309 DIE(aTHX_ PL_no_func, "setpgrp()");
4315 #ifdef HAS_GETPRIORITY
4317 const int who = POPi;
4318 const int which = TOPi;
4319 SETi( getpriority(which, who) );
4322 DIE(aTHX_ PL_no_func, "getpriority()");
4328 #ifdef HAS_SETPRIORITY
4330 const int niceval = POPi;
4331 const int who = POPi;
4332 const int which = TOPi;
4333 TAINT_PROPER("setpriority");
4334 SETi( setpriority(which, who, niceval) >= 0 );
4337 DIE(aTHX_ PL_no_func, "setpriority()");
4347 XPUSHn( time(NULL) );
4349 XPUSHi( time(NULL) );
4361 (void)PerlProc_times(&PL_timesbuf);
4363 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4364 /* struct tms, though same data */
4368 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
4369 if (GIMME == G_ARRAY) {
4370 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
4371 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
4372 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
4378 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4380 if (GIMME == G_ARRAY) {
4381 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4382 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4383 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4387 DIE(aTHX_ "times not implemented");
4389 #endif /* HAS_TIMES */
4392 #ifdef LOCALTIME_EDGECASE_BROKEN
4393 static struct tm *S_my_localtime (pTHX_ Time_t *tp)
4398 /* No workarounds in the valid range */
4399 if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4400 return (localtime (tp));
4402 /* This edge case is to workaround the undefined behaviour, where the
4403 * TIMEZONE makes the time go beyond the defined range.
4404 * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4405 * If there is a negative offset in TZ, like MET-1METDST, some broken
4406 * implementations of localtime () (like AIX 5.2) barf with bogus
4408 * 0x7fffffff gmtime 2038-01-19 03:14:07
4409 * 0x7fffffff localtime 1901-12-13 21:45:51
4410 * 0x7fffffff mylocaltime 2038-01-19 04:14:07
4411 * 0x3c19137f gmtime 2001-12-13 20:45:51
4412 * 0x3c19137f localtime 2001-12-13 21:45:51
4413 * 0x3c19137f mylocaltime 2001-12-13 21:45:51
4414 * Given that legal timezones are typically between GMT-12 and GMT+12
4415 * we turn back the clock 23 hours before calling the localtime
4416 * function, and add those to the return value. This will never cause
4417 * day wrapping problems, since the edge case is Tue Jan *19*
4419 T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4422 if (P->tm_hour >= 24) {
4424 P->tm_mday++; /* 18 -> 19 */
4425 P->tm_wday++; /* Mon -> Tue */
4426 P->tm_yday++; /* 18 -> 19 */
4429 } /* S_my_localtime */
4437 const struct tm *tmbuf;
4438 static const char * const dayname[] =
4439 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4440 static const char * const monname[] =
4441 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4442 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4448 when = (Time_t)SvNVx(POPs);
4450 when = (Time_t)SvIVx(POPs);
4453 if (PL_op->op_type == OP_LOCALTIME)
4454 #ifdef LOCALTIME_EDGECASE_BROKEN
4455 tmbuf = S_my_localtime(aTHX_ &when);
4457 tmbuf = localtime(&when);
4460 tmbuf = gmtime(&when);
4462 if (GIMME != G_ARRAY) {
4468 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4469 dayname[tmbuf->tm_wday],
4470 monname[tmbuf->tm_mon],
4475 tmbuf->tm_year + 1900);
4476 PUSHs(sv_2mortal(tsv));
4481 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4482 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4483 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4484 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4485 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4486 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4487 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4488 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4489 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4500 anum = alarm((unsigned int)anum);
4507 DIE(aTHX_ PL_no_func, "alarm");
4518 (void)time(&lasttime);
4523 PerlProc_sleep((unsigned int)duration);
4526 XPUSHi(when - lasttime);
4530 /* Shared memory. */
4531 /* Merged with some message passing. */
4535 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4536 dVAR; dSP; dMARK; dTARGET;
4537 const int op_type = PL_op->op_type;
4542 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4545 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4548 value = (I32)(do_semop(MARK, SP) >= 0);
4551 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4567 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4568 dVAR; dSP; dMARK; dTARGET;
4569 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4576 DIE(aTHX_ "System V IPC is not implemented on this machine");
4582 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4583 dVAR; dSP; dMARK; dTARGET;
4584 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4592 PUSHp(zero_but_true, ZBTLEN);
4600 /* I can't const this further without getting warnings about the types of
4601 various arrays passed in from structures. */
4603 S_space_join_names_mortal(pTHX_ char *const *array)
4607 if (array && *array) {
4608 target = sv_2mortal(newSVpvs(""));
4610 sv_catpv(target, *array);
4613 sv_catpvs(target, " ");
4616 target = sv_mortalcopy(&PL_sv_no);
4621 /* Get system info. */
4625 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4627 I32 which = PL_op->op_type;
4628 register char **elem;
4630 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4631 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4632 struct hostent *gethostbyname(Netdb_name_t);
4633 struct hostent *gethostent(void);
4635 struct hostent *hent;
4639 if (which == OP_GHBYNAME) {
4640 #ifdef HAS_GETHOSTBYNAME
4641 const char* const name = POPpbytex;
4642 hent = PerlSock_gethostbyname(name);
4644 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4647 else if (which == OP_GHBYADDR) {
4648 #ifdef HAS_GETHOSTBYADDR
4649 const int addrtype = POPi;
4650 SV * const addrsv = POPs;
4652 Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4654 hent = PerlSock_gethostbyaddr((const char*)addr, (Netdb_hlen_t) addrlen, addrtype);
4656 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4660 #ifdef HAS_GETHOSTENT
4661 hent = PerlSock_gethostent();
4663 DIE(aTHX_ PL_no_sock_func, "gethostent");
4666 #ifdef HOST_NOT_FOUND
4668 #ifdef USE_REENTRANT_API
4669 # ifdef USE_GETHOSTENT_ERRNO
4670 h_errno = PL_reentrant_buffer->_gethostent_errno;
4673 STATUS_UNIX_SET(h_errno);
4677 if (GIMME != G_ARRAY) {
4678 PUSHs(sv = sv_newmortal());
4680 if (which == OP_GHBYNAME) {
4682 sv_setpvn(sv, hent->h_addr, hent->h_length);
4685 sv_setpv(sv, (char*)hent->h_name);
4691 PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
4692 PUSHs(space_join_names_mortal(hent->h_aliases));
4693 PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
4694 len = hent->h_length;
4695 PUSHs(sv_2mortal(newSViv((IV)len)));
4697 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4698 XPUSHs(sv_2mortal(newSVpvn(*elem, len)));
4702 PUSHs(newSVpvn(hent->h_addr, len));
4704 PUSHs(sv_mortalcopy(&PL_sv_no));
4709 DIE(aTHX_ PL_no_sock_func, "gethostent");
4715 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4717 I32 which = PL_op->op_type;
4719 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4720 struct netent *getnetbyaddr(Netdb_net_t, int);
4721 struct netent *getnetbyname(Netdb_name_t);
4722 struct netent *getnetent(void);
4724 struct netent *nent;
4726 if (which == OP_GNBYNAME){
4727 #ifdef HAS_GETNETBYNAME
4728 const char * const name = POPpbytex;
4729 nent = PerlSock_getnetbyname(name);
4731 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4734 else if (which == OP_GNBYADDR) {
4735 #ifdef HAS_GETNETBYADDR
4736 const int addrtype = POPi;
4737 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4738 nent = PerlSock_getnetbyaddr(addr, addrtype);
4740 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4744 #ifdef HAS_GETNETENT
4745 nent = PerlSock_getnetent();
4747 DIE(aTHX_ PL_no_sock_func, "getnetent");
4750 #ifdef HOST_NOT_FOUND
4752 #ifdef USE_REENTRANT_API
4753 # ifdef USE_GETNETENT_ERRNO
4754 h_errno = PL_reentrant_buffer->_getnetent_errno;
4757 STATUS_UNIX_SET(h_errno);
4762 if (GIMME != G_ARRAY) {
4763 PUSHs(sv = sv_newmortal());
4765 if (which == OP_GNBYNAME)
4766 sv_setiv(sv, (IV)nent->n_net);
4768 sv_setpv(sv, nent->n_name);
4774 PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
4775 PUSHs(space_join_names_mortal(nent->n_aliases));
4776 PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
4777 PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
4782 DIE(aTHX_ PL_no_sock_func, "getnetent");
4788 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4790 I32 which = PL_op->op_type;
4792 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4793 struct protoent *getprotobyname(Netdb_name_t);
4794 struct protoent *getprotobynumber(int);
4795 struct protoent *getprotoent(void);
4797 struct protoent *pent;
4799 if (which == OP_GPBYNAME) {
4800 #ifdef HAS_GETPROTOBYNAME
4801 const char* const name = POPpbytex;
4802 pent = PerlSock_getprotobyname(name);
4804 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4807 else if (which == OP_GPBYNUMBER) {
4808 #ifdef HAS_GETPROTOBYNUMBER
4809 const int number = POPi;
4810 pent = PerlSock_getprotobynumber(number);
4812 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4816 #ifdef HAS_GETPROTOENT
4817 pent = PerlSock_getprotoent();
4819 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4823 if (GIMME != G_ARRAY) {
4824 PUSHs(sv = sv_newmortal());
4826 if (which == OP_GPBYNAME)
4827 sv_setiv(sv, (IV)pent->p_proto);
4829 sv_setpv(sv, pent->p_name);
4835 PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
4836 PUSHs(space_join_names_mortal(pent->p_aliases));
4837 PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
4842 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4848 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4850 I32 which = PL_op->op_type;
4852 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4853 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4854 struct servent *getservbyport(int, Netdb_name_t);
4855 struct servent *getservent(void);
4857 struct servent *sent;
4859 if (which == OP_GSBYNAME) {
4860 #ifdef HAS_GETSERVBYNAME
4861 const char * const proto = POPpbytex;
4862 const char * const name = POPpbytex;
4863 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4865 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4868 else if (which == OP_GSBYPORT) {
4869 #ifdef HAS_GETSERVBYPORT
4870 const char * const proto = POPpbytex;
4871 unsigned short port = (unsigned short)POPu;
4873 port = PerlSock_htons(port);
4875 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4877 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4881 #ifdef HAS_GETSERVENT
4882 sent = PerlSock_getservent();
4884 DIE(aTHX_ PL_no_sock_func, "getservent");
4888 if (GIMME != G_ARRAY) {
4889 PUSHs(sv = sv_newmortal());
4891 if (which == OP_GSBYNAME) {
4893 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4895 sv_setiv(sv, (IV)(sent->s_port));
4899 sv_setpv(sv, sent->s_name);
4905 PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
4906 PUSHs(space_join_names_mortal(sent->s_aliases));
4908 PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
4910 PUSHs(sv_2mortal(newSViv((IV)(sent->s_port))));
4912 PUSHs(sv_2mortal(newSVpv(sent->s_proto, 0)));
4917 DIE(aTHX_ PL_no_sock_func, "getservent");
4923 #ifdef HAS_SETHOSTENT
4925 PerlSock_sethostent(TOPi);
4928 DIE(aTHX_ PL_no_sock_func, "sethostent");
4934 #ifdef HAS_SETNETENT
4936 PerlSock_setnetent(TOPi);
4939 DIE(aTHX_ PL_no_sock_func, "setnetent");
4945 #ifdef HAS_SETPROTOENT
4947 PerlSock_setprotoent(TOPi);
4950 DIE(aTHX_ PL_no_sock_func, "setprotoent");
4956 #ifdef HAS_SETSERVENT
4958 PerlSock_setservent(TOPi);
4961 DIE(aTHX_ PL_no_sock_func, "setservent");
4967 #ifdef HAS_ENDHOSTENT
4969 PerlSock_endhostent();
4973 DIE(aTHX_ PL_no_sock_func, "endhostent");
4979 #ifdef HAS_ENDNETENT
4981 PerlSock_endnetent();
4985 DIE(aTHX_ PL_no_sock_func, "endnetent");
4991 #ifdef HAS_ENDPROTOENT
4993 PerlSock_endprotoent();
4997 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5003 #ifdef HAS_ENDSERVENT
5005 PerlSock_endservent();
5009 DIE(aTHX_ PL_no_sock_func, "endservent");
5017 I32 which = PL_op->op_type;
5019 struct passwd *pwent = NULL;
5021 * We currently support only the SysV getsp* shadow password interface.
5022 * The interface is declared in <shadow.h> and often one needs to link
5023 * with -lsecurity or some such.
5024 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5027 * AIX getpwnam() is clever enough to return the encrypted password
5028 * only if the caller (euid?) is root.
5030 * There are at least three other shadow password APIs. Many platforms
5031 * seem to contain more than one interface for accessing the shadow
5032 * password databases, possibly for compatibility reasons.
5033 * The getsp*() is by far he simplest one, the other two interfaces
5034 * are much more complicated, but also very similar to each other.
5039 * struct pr_passwd *getprpw*();
5040 * The password is in
5041 * char getprpw*(...).ufld.fd_encrypt[]
5042 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5047 * struct es_passwd *getespw*();
5048 * The password is in
5049 * char *(getespw*(...).ufld.fd_encrypt)
5050 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5053 * struct userpw *getuserpw();
5054 * The password is in
5055 * char *(getuserpw(...)).spw_upw_passwd
5056 * (but the de facto standard getpwnam() should work okay)
5058 * Mention I_PROT here so that Configure probes for it.
5060 * In HP-UX for getprpw*() the manual page claims that one should include
5061 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5062 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5063 * and pp_sys.c already includes <shadow.h> if there is such.
5065 * Note that <sys/security.h> is already probed for, but currently
5066 * it is only included in special cases.
5068 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5069 * be preferred interface, even though also the getprpw*() interface
5070 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5071 * One also needs to call set_auth_parameters() in main() before
5072 * doing anything else, whether one is using getespw*() or getprpw*().
5074 * Note that accessing the shadow databases can be magnitudes
5075 * slower than accessing the standard databases.
5080 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5081 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5082 * the pw_comment is left uninitialized. */
5083 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5089 const char* const name = POPpbytex;
5090 pwent = getpwnam(name);
5096 pwent = getpwuid(uid);
5100 # ifdef HAS_GETPWENT
5102 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5103 if (pwent) pwent = getpwnam(pwent->pw_name);
5106 DIE(aTHX_ PL_no_func, "getpwent");
5112 if (GIMME != G_ARRAY) {
5113 PUSHs(sv = sv_newmortal());
5115 if (which == OP_GPWNAM)
5116 # if Uid_t_sign <= 0
5117 sv_setiv(sv, (IV)pwent->pw_uid);
5119 sv_setuv(sv, (UV)pwent->pw_uid);
5122 sv_setpv(sv, pwent->pw_name);
5128 PUSHs(sv_2mortal(newSVpv(pwent->pw_name, 0)));
5130 PUSHs(sv = sv_2mortal(newSViv(0)));
5131 /* If we have getspnam(), we try to dig up the shadow
5132 * password. If we are underprivileged, the shadow
5133 * interface will set the errno to EACCES or similar,
5134 * and return a null pointer. If this happens, we will
5135 * use the dummy password (usually "*" or "x") from the
5136 * standard password database.
5138 * In theory we could skip the shadow call completely
5139 * if euid != 0 but in practice we cannot know which
5140 * security measures are guarding the shadow databases
5141 * on a random platform.
5143 * Resist the urge to use additional shadow interfaces.
5144 * Divert the urge to writing an extension instead.
5147 /* Some AIX setups falsely(?) detect some getspnam(), which
5148 * has a different API than the Solaris/IRIX one. */
5149 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5151 const int saverrno = errno;
5152 const struct spwd * const spwent = getspnam(pwent->pw_name);
5153 /* Save and restore errno so that
5154 * underprivileged attempts seem
5155 * to have never made the unsccessful
5156 * attempt to retrieve the shadow password. */
5158 if (spwent && spwent->sp_pwdp)
5159 sv_setpv(sv, spwent->sp_pwdp);
5163 if (!SvPOK(sv)) /* Use the standard password, then. */
5164 sv_setpv(sv, pwent->pw_passwd);
5167 # ifndef INCOMPLETE_TAINTS
5168 /* passwd is tainted because user himself can diddle with it.
5169 * admittedly not much and in a very limited way, but nevertheless. */
5173 # if Uid_t_sign <= 0
5174 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_uid)));
5176 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_uid)));
5179 # if Uid_t_sign <= 0
5180 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_gid)));
5182 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_gid)));
5184 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5185 * because of the poor interface of the Perl getpw*(),
5186 * not because there's some standard/convention saying so.
5187 * A better interface would have been to return a hash,
5188 * but we are accursed by our history, alas. --jhi. */
5190 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_change)));
5193 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_quota)));
5196 PUSHs(sv_2mortal(newSVpv(pwent->pw_age, 0)));
5198 /* I think that you can never get this compiled, but just in case. */
5199 PUSHs(sv_mortalcopy(&PL_sv_no));
5204 /* pw_class and pw_comment are mutually exclusive--.
5205 * see the above note for pw_change, pw_quota, and pw_age. */
5207 PUSHs(sv_2mortal(newSVpv(pwent->pw_class, 0)));
5210 PUSHs(sv_2mortal(newSVpv(pwent->pw_comment, 0)));
5212 /* I think that you can never get this compiled, but just in case. */
5213 PUSHs(sv_mortalcopy(&PL_sv_no));
5218 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5220 PUSHs(sv_mortalcopy(&PL_sv_no));
5222 # ifndef INCOMPLETE_TAINTS
5223 /* pw_gecos is tainted because user himself can diddle with it. */
5227 PUSHs(sv_2mortal(newSVpv(pwent->pw_dir, 0)));
5229 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5230 # ifndef INCOMPLETE_TAINTS
5231 /* pw_shell is tainted because user himself can diddle with it. */
5236 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_expire)));
5241 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5247 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5252 DIE(aTHX_ PL_no_func, "setpwent");
5258 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5263 DIE(aTHX_ PL_no_func, "endpwent");
5271 const I32 which = PL_op->op_type;
5272 const struct group *grent;
5274 if (which == OP_GGRNAM) {
5275 const char* const name = POPpbytex;
5276 grent = (const struct group *)getgrnam(name);
5278 else if (which == OP_GGRGID) {
5279 const Gid_t gid = POPi;
5280 grent = (const struct group *)getgrgid(gid);
5284 grent = (struct group *)getgrent();
5286 DIE(aTHX_ PL_no_func, "getgrent");
5290 if (GIMME != G_ARRAY) {
5291 SV * const sv = sv_newmortal();
5295 if (which == OP_GGRNAM)
5296 sv_setiv(sv, (IV)grent->gr_gid);
5298 sv_setpv(sv, grent->gr_name);
5304 PUSHs(sv_2mortal(newSVpv(grent->gr_name, 0)));
5307 PUSHs(sv_2mortal(newSVpv(grent->gr_passwd, 0)));
5309 PUSHs(sv_mortalcopy(&PL_sv_no));
5312 PUSHs(sv_2mortal(newSViv((IV)grent->gr_gid)));
5314 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5315 /* In UNICOS/mk (_CRAYMPP) the multithreading
5316 * versions (getgrnam_r, getgrgid_r)
5317 * seem to return an illegal pointer
5318 * as the group members list, gr_mem.
5319 * getgrent() doesn't even have a _r version
5320 * but the gr_mem is poisonous anyway.
5321 * So yes, you cannot get the list of group
5322 * members if building multithreaded in UNICOS/mk. */
5323 PUSHs(space_join_names_mortal(grent->gr_mem));
5329 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5335 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5340 DIE(aTHX_ PL_no_func, "setgrent");
5346 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5351 DIE(aTHX_ PL_no_func, "endgrent");
5361 if (!(tmps = PerlProc_getlogin()))
5363 PUSHp(tmps, strlen(tmps));
5366 DIE(aTHX_ PL_no_func, "getlogin");
5370 /* Miscellaneous. */
5375 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5376 register I32 items = SP - MARK;
5377 unsigned long a[20];
5382 while (++MARK <= SP) {
5383 if (SvTAINTED(*MARK)) {
5389 TAINT_PROPER("syscall");
5392 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5393 * or where sizeof(long) != sizeof(char*). But such machines will
5394 * not likely have syscall implemented either, so who cares?
5396 while (++MARK <= SP) {
5397 if (SvNIOK(*MARK) || !i)
5398 a[i++] = SvIV(*MARK);
5399 else if (*MARK == &PL_sv_undef)
5402 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5408 DIE(aTHX_ "Too many args to syscall");
5410 DIE(aTHX_ "Too few args to syscall");
5412 retval = syscall(a[0]);
5415 retval = syscall(a[0],a[1]);
5418 retval = syscall(a[0],a[1],a[2]);
5421 retval = syscall(a[0],a[1],a[2],a[3]);
5424 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5427 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5430 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5433 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5437 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5440 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5443 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5447 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5451 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5455 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5456 a[10],a[11],a[12],a[13]);
5458 #endif /* atarist */
5464 DIE(aTHX_ PL_no_func, "syscall");
5468 #ifdef FCNTL_EMULATE_FLOCK
5470 /* XXX Emulate flock() with fcntl().
5471 What's really needed is a good file locking module.
5475 fcntl_emulate_flock(int fd, int operation)
5479 switch (operation & ~LOCK_NB) {
5481 flock.l_type = F_RDLCK;
5484 flock.l_type = F_WRLCK;
5487 flock.l_type = F_UNLCK;
5493 flock.l_whence = SEEK_SET;
5494 flock.l_start = flock.l_len = (Off_t)0;
5496 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5499 #endif /* FCNTL_EMULATE_FLOCK */
5501 #ifdef LOCKF_EMULATE_FLOCK
5503 /* XXX Emulate flock() with lockf(). This is just to increase
5504 portability of scripts. The calls are not completely
5505 interchangeable. What's really needed is a good file
5509 /* The lockf() constants might have been defined in <unistd.h>.
5510 Unfortunately, <unistd.h> causes troubles on some mixed
5511 (BSD/POSIX) systems, such as SunOS 4.1.3.
5513 Further, the lockf() constants aren't POSIX, so they might not be
5514 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5515 just stick in the SVID values and be done with it. Sigh.
5519 # define F_ULOCK 0 /* Unlock a previously locked region */
5522 # define F_LOCK 1 /* Lock a region for exclusive use */
5525 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5528 # define F_TEST 3 /* Test a region for other processes locks */
5532 lockf_emulate_flock(int fd, int operation)
5535 const int save_errno = errno;
5538 /* flock locks entire file so for lockf we need to do the same */
5539 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5540 if (pos > 0) /* is seekable and needs to be repositioned */
5541 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5542 pos = -1; /* seek failed, so don't seek back afterwards */
5545 switch (operation) {
5547 /* LOCK_SH - get a shared lock */
5549 /* LOCK_EX - get an exclusive lock */
5551 i = lockf (fd, F_LOCK, 0);
5554 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5555 case LOCK_SH|LOCK_NB:
5556 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5557 case LOCK_EX|LOCK_NB:
5558 i = lockf (fd, F_TLOCK, 0);
5560 if ((errno == EAGAIN) || (errno == EACCES))
5561 errno = EWOULDBLOCK;
5564 /* LOCK_UN - unlock (non-blocking is a no-op) */
5566 case LOCK_UN|LOCK_NB:
5567 i = lockf (fd, F_ULOCK, 0);
5570 /* Default - can't decipher operation */
5577 if (pos > 0) /* need to restore position of the handle */
5578 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5583 #endif /* LOCKF_EMULATE_FLOCK */
5587 * c-indentation-style: bsd
5589 * indent-tabs-mode: t
5592 * ex: set ts=8 sts=4 sw=4 noet: