3 * Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 * 2004, 2005, 2006, 2007 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * But only a short way ahead its floor and the walls on either side were
13 * cloven by a great fissure, out of which the red glare came, now leaping
14 * up, now dying down into darkness; and all the while far below there was
15 * a rumour and a trouble as of great engines throbbing and labouring.
18 /* This file contains system pp ("push/pop") functions that
19 * execute the opcodes that make up a perl program. A typical pp function
20 * expects to find its arguments on the stack, and usually pushes its
21 * results onto the stack, hence the 'pp' terminology. Each OP structure
22 * contains a pointer to the relevant pp_foo() function.
24 * By 'system', we mean ops which interact with the OS, such as pp_open().
28 #define PERL_IN_PP_SYS_C
32 /* Shadow password support for solaris - pdo@cs.umd.edu
33 * Not just Solaris: at least HP-UX, IRIX, Linux.
34 * The API is from SysV.
36 * There are at least two more shadow interfaces,
37 * see the comments in pp_gpwent().
41 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
42 * and another MAXINT from "perl.h" <- <sys/param.h>. */
49 # include <sys/wait.h>
53 # include <sys/resource.h>
62 # include <sys/select.h>
66 /* XXX Configure test needed.
67 h_errno might not be a simple 'int', especially for multi-threaded
68 applications, see "extern int errno in perl.h". Creating such
69 a test requires taking into account the differences between
70 compiling multithreaded and singlethreaded ($ccflags et al).
71 HOST_NOT_FOUND is typically defined in <netdb.h>.
73 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
82 struct passwd *getpwnam (char *);
83 struct passwd *getpwuid (Uid_t);
88 struct passwd *getpwent (void);
89 #elif defined (VMS) && defined (my_getpwent)
90 struct passwd *Perl_my_getpwent (pTHX);
99 struct group *getgrnam (char *);
100 struct group *getgrgid (Gid_t);
104 struct group *getgrent (void);
110 # if defined(_MSC_VER) || defined(__MINGW32__)
111 # include <sys/utime.h>
118 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
121 # define my_chsize PerlLIO_chsize
124 # define my_chsize PerlLIO_chsize
126 I32 my_chsize(int fd, Off_t length);
132 #else /* no flock() */
134 /* fcntl.h might not have been included, even if it exists, because
135 the current Configure only sets I_FCNTL if it's needed to pick up
136 the *_OK constants. Make sure it has been included before testing
137 the fcntl() locking constants. */
138 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
142 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
143 # define FLOCK fcntl_emulate_flock
144 # define FCNTL_EMULATE_FLOCK
145 # else /* no flock() or fcntl(F_SETLK,...) */
147 # define FLOCK lockf_emulate_flock
148 # define LOCKF_EMULATE_FLOCK
150 # endif /* no flock() or fcntl(F_SETLK,...) */
153 static int FLOCK (int, int);
156 * These are the flock() constants. Since this sytems doesn't have
157 * flock(), the values of the constants are probably not available.
171 # endif /* emulating flock() */
173 #endif /* no flock() */
176 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
178 #if defined(I_SYS_ACCESS) && !defined(R_OK)
179 # include <sys/access.h>
182 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
183 # define FD_CLOEXEC 1 /* NeXT needs this */
189 /* Missing protos on LynxOS */
190 void sethostent(int);
191 void endhostent(void);
193 void endnetent(void);
194 void setprotoent(int);
195 void endprotoent(void);
196 void setservent(int);
197 void endservent(void);
200 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
202 /* AIX 5.2 and below use mktime for localtime, and defines the edge case
203 * for time 0x7fffffff to be valid only in UTC. AIX 5.3 provides localtime64
204 * available in the 32bit environment, which could warrant Configure
205 * checks in the future.
208 #define LOCALTIME_EDGECASE_BROKEN
211 /* F_OK unused: if stat() cannot find it... */
213 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
214 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
215 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
218 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
219 # ifdef I_SYS_SECURITY
220 # include <sys/security.h>
224 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
227 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
231 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
233 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
237 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
238 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
239 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
242 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
244 const Uid_t ruid = getuid();
245 const Uid_t euid = geteuid();
246 const Gid_t rgid = getgid();
247 const Gid_t egid = getegid();
251 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
252 Perl_croak(aTHX_ "switching effective uid is not implemented");
255 if (setreuid(euid, ruid))
258 if (setresuid(euid, ruid, (Uid_t)-1))
261 Perl_croak(aTHX_ "entering effective uid failed");
264 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
265 Perl_croak(aTHX_ "switching effective gid is not implemented");
268 if (setregid(egid, rgid))
271 if (setresgid(egid, rgid, (Gid_t)-1))
274 Perl_croak(aTHX_ "entering effective gid failed");
277 res = access(path, mode);
280 if (setreuid(ruid, euid))
283 if (setresuid(ruid, euid, (Uid_t)-1))
286 Perl_croak(aTHX_ "leaving effective uid failed");
289 if (setregid(rgid, egid))
292 if (setresgid(rgid, egid, (Gid_t)-1))
295 Perl_croak(aTHX_ "leaving effective gid failed");
300 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
307 const char * const tmps = POPpconstx;
308 const I32 gimme = GIMME_V;
309 const char *mode = "r";
312 if (PL_op->op_private & OPpOPEN_IN_RAW)
314 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
316 fp = PerlProc_popen(tmps, mode);
318 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
320 PerlIO_apply_layers(aTHX_ fp,mode,type);
322 if (gimme == G_VOID) {
324 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
327 else if (gimme == G_SCALAR) {
330 PL_rs = &PL_sv_undef;
331 sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */
332 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
340 SV * const sv = newSV(79);
341 if (sv_gets(sv, fp, 0) == NULL) {
346 if (SvLEN(sv) - SvCUR(sv) > 20) {
347 SvPV_shrink_to_cur(sv);
352 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
353 TAINT; /* "I believe that this is not gratuitous!" */
356 STATUS_NATIVE_CHILD_SET(-1);
357 if (gimme == G_SCALAR)
368 tryAMAGICunTARGET(iter, -1);
370 /* Note that we only ever get here if File::Glob fails to load
371 * without at the same time croaking, for some reason, or if
372 * perl was built with PERL_EXTERNAL_GLOB */
379 * The external globbing program may use things we can't control,
380 * so for security reasons we must assume the worst.
383 taint_proper(PL_no_security, "glob");
387 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
388 PL_last_in_gv = (GV*)*PL_stack_sp--;
390 SAVESPTR(PL_rs); /* This is not permanent, either. */
391 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
394 *SvPVX(PL_rs) = '\n';
398 result = do_readline();
406 PL_last_in_gv = cGVOP_gv;
407 return do_readline();
418 do_join(TARG, &PL_sv_no, MARK, SP);
422 else if (SP == MARK) {
430 tmps = SvPV_const(tmpsv, len);
431 if ((!tmps || !len) && PL_errgv) {
432 SV * const error = ERRSV;
433 SvUPGRADE(error, SVt_PV);
434 if (SvPOK(error) && SvCUR(error))
435 sv_catpvs(error, "\t...caught");
437 tmps = SvPV_const(tmpsv, len);
440 tmpsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
442 Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv));
454 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
456 if (SP - MARK != 1) {
458 do_join(TARG, &PL_sv_no, MARK, SP);
460 tmps = SvPV_const(tmpsv, len);
466 tmps = SvROK(tmpsv) ? (const char *)NULL : SvPV_const(tmpsv, len);
469 SV * const error = ERRSV;
470 SvUPGRADE(error, SVt_PV);
471 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
473 SvSetSV(error,tmpsv);
474 else if (sv_isobject(error)) {
475 HV * const stash = SvSTASH(SvRV(error));
476 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
478 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
479 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
486 call_sv((SV*)GvCV(gv),
487 G_SCALAR|G_EVAL|G_KEEPERR);
488 sv_setsv(error,*PL_stack_sp--);
494 if (SvPOK(error) && SvCUR(error))
495 sv_catpvs(error, "\t...propagated");
498 tmps = SvPV_const(tmpsv, len);
504 tmpsv = newSVpvs_flags("Died", SVs_TEMP);
506 DIE(aTHX_ "%"SVf, SVfARG(tmpsv));
522 GV * const gv = (GV *)*++MARK;
525 DIE(aTHX_ PL_no_usym, "filehandle");
527 if ((io = GvIOp(gv))) {
529 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
531 if (IoDIRP(io) && ckWARN2(WARN_IO, WARN_DEPRECATED))
532 Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
533 "Opening dirhandle %s also as a file", GvENAME(gv));
535 mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
537 /* Method's args are same as ours ... */
538 /* ... except handle is replaced by the object */
539 *MARK-- = SvTIED_obj((SV*)io, mg);
543 call_method("OPEN", G_SCALAR);
557 tmps = SvPV_const(sv, len);
558 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
561 PUSHi( (I32)PL_forkprocess );
562 else if (PL_forkprocess == 0) /* we are a new child */
572 GV * const gv = (MAXARG == 0) ? PL_defoutgv : (GV*)POPs;
575 IO * const io = GvIO(gv);
577 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
580 XPUSHs(SvTIED_obj((SV*)io, mg));
583 call_method("CLOSE", G_SCALAR);
591 PUSHs(boolSV(do_close(gv, TRUE)));
604 GV * const wgv = (GV*)POPs;
605 GV * const rgv = (GV*)POPs;
610 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
611 DIE(aTHX_ PL_no_usym, "filehandle");
616 do_close(rgv, FALSE);
618 do_close(wgv, FALSE);
620 if (PerlProc_pipe(fd) < 0)
623 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
624 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
625 IoOFP(rstio) = IoIFP(rstio);
626 IoIFP(wstio) = IoOFP(wstio);
627 IoTYPE(rstio) = IoTYPE_RDONLY;
628 IoTYPE(wstio) = IoTYPE_WRONLY;
630 if (!IoIFP(rstio) || !IoOFP(wstio)) {
632 PerlIO_close(IoIFP(rstio));
634 PerlLIO_close(fd[0]);
636 PerlIO_close(IoOFP(wstio));
638 PerlLIO_close(fd[1]);
641 #if defined(HAS_FCNTL) && defined(F_SETFD)
642 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
643 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
650 DIE(aTHX_ PL_no_func, "pipe");
666 if (gv && (io = GvIO(gv))
667 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
670 XPUSHs(SvTIED_obj((SV*)io, mg));
673 call_method("FILENO", G_SCALAR);
679 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
680 /* Can't do this because people seem to do things like
681 defined(fileno($foo)) to check whether $foo is a valid fh.
682 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
683 report_evil_fh(gv, io, PL_op->op_type);
688 PUSHi(PerlIO_fileno(fp));
701 anum = PerlLIO_umask(022);
702 /* setting it to 022 between the two calls to umask avoids
703 * to have a window where the umask is set to 0 -- meaning
704 * that another thread could create world-writeable files. */
706 (void)PerlLIO_umask(anum);
709 anum = PerlLIO_umask(POPi);
710 TAINT_PROPER("umask");
713 /* Only DIE if trying to restrict permissions on "user" (self).
714 * Otherwise it's harmless and more useful to just return undef
715 * since 'group' and 'other' concepts probably don't exist here. */
716 if (MAXARG >= 1 && (POPi & 0700))
717 DIE(aTHX_ "umask not implemented");
718 XPUSHs(&PL_sv_undef);
739 if (gv && (io = GvIO(gv))) {
740 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
743 XPUSHs(SvTIED_obj((SV*)io, mg));
748 call_method("BINMODE", G_SCALAR);
756 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
757 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
758 report_evil_fh(gv, io, PL_op->op_type);
759 SETERRNO(EBADF,RMS_IFI);
766 const char *d = NULL;
769 d = SvPV_const(discp, len);
770 mode = mode_from_discipline(d, len);
771 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
772 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
773 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
794 const I32 markoff = MARK - PL_stack_base;
795 const char *methname;
796 int how = PERL_MAGIC_tied;
800 switch(SvTYPE(varsv)) {
802 methname = "TIEHASH";
803 HvEITER_set((HV *)varsv, 0);
806 methname = "TIEARRAY";
809 #ifdef GV_UNIQUE_CHECK
810 if (GvUNIQUE((GV*)varsv)) {
811 Perl_croak(aTHX_ "Attempt to tie unique GV");
814 methname = "TIEHANDLE";
815 how = PERL_MAGIC_tiedscalar;
816 /* For tied filehandles, we apply tiedscalar magic to the IO
817 slot of the GP rather than the GV itself. AMS 20010812 */
819 GvIOp(varsv) = newIO();
820 varsv = (SV *)GvIOp(varsv);
823 methname = "TIESCALAR";
824 how = PERL_MAGIC_tiedscalar;
828 if (sv_isobject(*MARK)) { /* Calls GET magic. */
830 PUSHSTACKi(PERLSI_MAGIC);
832 EXTEND(SP,(I32)items);
836 call_method(methname, G_SCALAR);
839 /* Not clear why we don't call call_method here too.
840 * perhaps to get different error message ?
843 const char *name = SvPV_nomg_const(*MARK, len);
844 stash = gv_stashpvn(name, len, 0);
845 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
846 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
847 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
850 PUSHSTACKi(PERLSI_MAGIC);
852 EXTEND(SP,(I32)items);
856 call_sv((SV*)GvCV(gv), G_SCALAR);
862 if (sv_isobject(sv)) {
863 sv_unmagic(varsv, how);
864 /* Croak if a self-tie on an aggregate is attempted. */
865 if (varsv == SvRV(sv) &&
866 (SvTYPE(varsv) == SVt_PVAV ||
867 SvTYPE(varsv) == SVt_PVHV))
869 "Self-ties of arrays and hashes are not supported");
870 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
873 SP = PL_stack_base + markoff;
883 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
884 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
886 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
889 if ((mg = SvTIED_mg(sv, how))) {
890 SV * const obj = SvRV(SvTIED_obj(sv, mg));
892 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
894 if (gv && isGV(gv) && (cv = GvCV(gv))) {
896 XPUSHs(SvTIED_obj((SV*)gv, mg));
897 mXPUSHi(SvREFCNT(obj) - 1);
900 call_sv((SV *)cv, G_VOID);
904 else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
905 Perl_warner(aTHX_ packWARN(WARN_UNTIE),
906 "untie attempted while %"UVuf" inner references still exist",
907 (UV)SvREFCNT(obj) - 1 ) ;
911 sv_unmagic(sv, how) ;
921 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
922 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
924 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
927 if ((mg = SvTIED_mg(sv, how))) {
928 SV *osv = SvTIED_obj(sv, mg);
929 if (osv == mg->mg_obj)
930 osv = sv_mortalcopy(osv);
944 HV * const hv = (HV*)POPs;
945 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
946 stash = gv_stashsv(sv, 0);
947 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
949 require_pv("AnyDBM_File.pm");
951 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
952 DIE(aTHX_ "No dbm on this machine");
962 mPUSHu(O_RDWR|O_CREAT);
967 call_sv((SV*)GvCV(gv), G_SCALAR);
970 if (!sv_isobject(TOPs)) {
978 call_sv((SV*)GvCV(gv), G_SCALAR);
982 if (sv_isobject(TOPs)) {
983 sv_unmagic((SV *) hv, PERL_MAGIC_tied);
984 sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, NULL, 0);
1001 struct timeval timebuf;
1002 struct timeval *tbuf = &timebuf;
1005 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1010 # if BYTEORDER & 0xf0000
1011 # define ORDERBYTE (0x88888888 - BYTEORDER)
1013 # define ORDERBYTE (0x4444 - BYTEORDER)
1019 for (i = 1; i <= 3; i++) {
1020 SV * const sv = SP[i];
1023 if (SvREADONLY(sv)) {
1025 sv_force_normal_flags(sv, 0);
1026 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1027 DIE(aTHX_ PL_no_modify);
1030 if (ckWARN(WARN_MISC))
1031 Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1032 SvPV_force_nolen(sv); /* force string conversion */
1039 /* little endians can use vecs directly */
1040 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1047 masksize = NFDBITS / NBBY;
1049 masksize = sizeof(long); /* documented int, everyone seems to use long */
1051 Zero(&fd_sets[0], 4, char*);
1054 # if SELECT_MIN_BITS == 1
1055 growsize = sizeof(fd_set);
1057 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1058 # undef SELECT_MIN_BITS
1059 # define SELECT_MIN_BITS __FD_SETSIZE
1061 /* If SELECT_MIN_BITS is greater than one we most probably will want
1062 * to align the sizes with SELECT_MIN_BITS/8 because for example
1063 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1064 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1065 * on (sets/tests/clears bits) is 32 bits. */
1066 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1074 timebuf.tv_sec = (long)value;
1075 value -= (NV)timebuf.tv_sec;
1076 timebuf.tv_usec = (long)(value * 1000000.0);
1081 for (i = 1; i <= 3; i++) {
1083 if (!SvOK(sv) || SvCUR(sv) == 0) {
1090 Sv_Grow(sv, growsize);
1094 while (++j <= growsize) {
1098 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1100 Newx(fd_sets[i], growsize, char);
1101 for (offset = 0; offset < growsize; offset += masksize) {
1102 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1103 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1106 fd_sets[i] = SvPVX(sv);
1110 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1111 /* Can't make just the (void*) conditional because that would be
1112 * cpp #if within cpp macro, and not all compilers like that. */
1113 nfound = PerlSock_select(
1115 (Select_fd_set_t) fd_sets[1],
1116 (Select_fd_set_t) fd_sets[2],
1117 (Select_fd_set_t) fd_sets[3],
1118 (void*) tbuf); /* Workaround for compiler bug. */
1120 nfound = PerlSock_select(
1122 (Select_fd_set_t) fd_sets[1],
1123 (Select_fd_set_t) fd_sets[2],
1124 (Select_fd_set_t) fd_sets[3],
1127 for (i = 1; i <= 3; i++) {
1130 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1132 for (offset = 0; offset < growsize; offset += masksize) {
1133 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1134 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1136 Safefree(fd_sets[i]);
1143 if (GIMME == G_ARRAY && tbuf) {
1144 value = (NV)(timebuf.tv_sec) +
1145 (NV)(timebuf.tv_usec) / 1000000.0;
1150 DIE(aTHX_ "select not implemented");
1155 Perl_setdefout(pTHX_ GV *gv)
1158 SvREFCNT_inc_simple_void(gv);
1160 SvREFCNT_dec(PL_defoutgv);
1168 GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : NULL;
1169 GV * egv = GvEGV(PL_defoutgv);
1175 XPUSHs(&PL_sv_undef);
1177 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1178 if (gvp && *gvp == egv) {
1179 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1183 mXPUSHs(newRV((SV*)egv));
1188 if (!GvIO(newdefout))
1189 gv_IOadd(newdefout);
1190 setdefout(newdefout);
1200 GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs;
1202 if (gv && (io = GvIO(gv))) {
1203 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1205 const I32 gimme = GIMME_V;
1207 XPUSHs(SvTIED_obj((SV*)io, mg));
1210 call_method("GETC", gimme);
1213 if (gimme == G_SCALAR)
1214 SvSetMagicSV_nosteal(TARG, TOPs);
1218 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1219 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1220 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1221 report_evil_fh(gv, io, PL_op->op_type);
1222 SETERRNO(EBADF,RMS_IFI);
1226 sv_setpvn(TARG, " ", 1);
1227 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1228 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1229 /* Find out how many bytes the char needs */
1230 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1233 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1234 SvCUR_set(TARG,1+len);
1243 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1246 register PERL_CONTEXT *cx;
1247 const I32 gimme = GIMME_V;
1249 PERL_ARGS_ASSERT_DOFORM;
1254 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1255 PUSHFORMAT(cx, retop);
1257 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1259 setdefout(gv); /* locally select filehandle so $% et al work */
1291 goto not_a_format_reference;
1296 tmpsv = sv_newmortal();
1297 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1298 name = SvPV_nolen_const(tmpsv);
1300 DIE(aTHX_ "Undefined format \"%s\" called", name);
1302 not_a_format_reference:
1303 DIE(aTHX_ "Not a format reference");
1306 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1308 IoFLAGS(io) &= ~IOf_DIDTOP;
1309 return doform(cv,gv,PL_op->op_next);
1315 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1316 register IO * const io = GvIOp(gv);
1321 register PERL_CONTEXT *cx;
1323 if (!io || !(ofp = IoOFP(io)))
1326 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1327 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1329 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1330 PL_formtarget != PL_toptarget)
1334 if (!IoTOP_GV(io)) {
1337 if (!IoTOP_NAME(io)) {
1339 if (!IoFMT_NAME(io))
1340 IoFMT_NAME(io) = savepv(GvNAME(gv));
1341 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1342 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1343 if ((topgv && GvFORM(topgv)) ||
1344 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1345 IoTOP_NAME(io) = savesvpv(topname);
1347 IoTOP_NAME(io) = savepvs("top");
1349 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1350 if (!topgv || !GvFORM(topgv)) {
1351 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1354 IoTOP_GV(io) = topgv;
1356 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1357 I32 lines = IoLINES_LEFT(io);
1358 const char *s = SvPVX_const(PL_formtarget);
1359 if (lines <= 0) /* Yow, header didn't even fit!!! */
1361 while (lines-- > 0) {
1362 s = strchr(s, '\n');
1368 const STRLEN save = SvCUR(PL_formtarget);
1369 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1370 do_print(PL_formtarget, ofp);
1371 SvCUR_set(PL_formtarget, save);
1372 sv_chop(PL_formtarget, s);
1373 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1376 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1377 do_print(PL_formfeed, ofp);
1378 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1380 PL_formtarget = PL_toptarget;
1381 IoFLAGS(io) |= IOf_DIDTOP;
1384 DIE(aTHX_ "bad top format reference");
1387 SV * const sv = sv_newmortal();
1389 gv_efullname4(sv, fgv, NULL, FALSE);
1390 name = SvPV_nolen_const(sv);
1392 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1394 DIE(aTHX_ "Undefined top format called");
1396 if (cv && CvCLONE(cv))
1397 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1398 return doform(cv, gv, PL_op);
1402 POPBLOCK(cx,PL_curpm);
1408 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1410 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1411 else if (ckWARN(WARN_CLOSED))
1412 report_evil_fh(gv, io, PL_op->op_type);
1417 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1418 if (ckWARN(WARN_IO))
1419 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1421 if (!do_print(PL_formtarget, fp))
1424 FmLINES(PL_formtarget) = 0;
1425 SvCUR_set(PL_formtarget, 0);
1426 *SvEND(PL_formtarget) = '\0';
1427 if (IoFLAGS(io) & IOf_FLUSH)
1428 (void)PerlIO_flush(fp);
1433 PL_formtarget = PL_bodytarget;
1435 PERL_UNUSED_VAR(newsp);
1436 PERL_UNUSED_VAR(gimme);
1437 return cx->blk_sub.retop;
1442 dVAR; dSP; dMARK; dORIGMARK;
1447 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
1449 if (gv && (io = GvIO(gv))) {
1450 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1452 if (MARK == ORIGMARK) {
1455 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1459 *MARK = SvTIED_obj((SV*)io, mg);
1462 call_method("PRINTF", G_SCALAR);
1465 MARK = ORIGMARK + 1;
1473 if (!(io = GvIO(gv))) {
1474 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1475 report_evil_fh(gv, io, PL_op->op_type);
1476 SETERRNO(EBADF,RMS_IFI);
1479 else if (!(fp = IoOFP(io))) {
1480 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1482 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1483 else if (ckWARN(WARN_CLOSED))
1484 report_evil_fh(gv, io, PL_op->op_type);
1486 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1490 if (SvTAINTED(MARK[1]))
1491 TAINT_PROPER("printf");
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) || IoTYPE(io) == IoTYPE_RDONLY) {
1836 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1837 if (io && IoIFP(io))
1838 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1840 report_evil_fh(gv, io, PL_op->op_type);
1842 SETERRNO(EBADF,RMS_IFI);
1846 /* Do this first to trigger any overloading. */
1847 buffer = SvPV_const(bufsv, blen);
1848 orig_blen_bytes = blen;
1849 doing_utf8 = DO_UTF8(bufsv);
1851 if (PerlIO_isutf8(IoIFP(io))) {
1852 if (!SvUTF8(bufsv)) {
1853 /* We don't modify the original scalar. */
1854 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1855 buffer = (char *) tmpbuf;
1859 else if (doing_utf8) {
1860 STRLEN tmplen = blen;
1861 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1864 buffer = (char *) tmpbuf;
1868 assert((char *)result == buffer);
1869 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1873 if (op_type == OP_SYSWRITE) {
1874 Size_t length = 0; /* This length is in characters. */
1880 /* The SV is bytes, and we've had to upgrade it. */
1881 blen_chars = orig_blen_bytes;
1883 /* The SV really is UTF-8. */
1884 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1885 /* Don't call sv_len_utf8 again because it will call magic
1886 or overloading a second time, and we might get back a
1887 different result. */
1888 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1890 /* It's safe, and it may well be cached. */
1891 blen_chars = sv_len_utf8(bufsv);
1899 length = blen_chars;
1901 #if Size_t_size > IVSIZE
1902 length = (Size_t)SvNVx(*++MARK);
1904 length = (Size_t)SvIVx(*++MARK);
1906 if ((SSize_t)length < 0) {
1908 DIE(aTHX_ "Negative length");
1913 offset = SvIVx(*++MARK);
1915 if (-offset > (IV)blen_chars) {
1917 DIE(aTHX_ "Offset outside string");
1919 offset += blen_chars;
1920 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1922 DIE(aTHX_ "Offset outside string");
1926 if (length > blen_chars - offset)
1927 length = blen_chars - offset;
1929 /* Here we convert length from characters to bytes. */
1930 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1931 /* Either we had to convert the SV, or the SV is magical, or
1932 the SV has overloading, in which case we can't or mustn't
1933 or mustn't call it again. */
1935 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1936 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1938 /* It's a real UTF-8 SV, and it's not going to change under
1939 us. Take advantage of any cache. */
1941 I32 len_I32 = length;
1943 /* Convert the start and end character positions to bytes.
1944 Remember that the second argument to sv_pos_u2b is relative
1946 sv_pos_u2b(bufsv, &start, &len_I32);
1953 buffer = buffer+offset;
1955 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1956 if (IoTYPE(io) == IoTYPE_SOCKET) {
1957 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1963 /* See the note at doio.c:do_print about filesize limits. --jhi */
1964 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1970 const int flags = SvIVx(*++MARK);
1973 char * const sockbuf = SvPVx(*++MARK, mlen);
1974 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1975 flags, (struct sockaddr *)sockbuf, mlen);
1979 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1984 DIE(aTHX_ PL_no_sock_func, "send");
1991 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
1994 #if Size_t_size > IVSIZE
2013 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
2015 gv = PL_last_in_gv = GvEGV(PL_argvgv);
2017 if (io && !IoIFP(io)) {
2018 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2020 IoFLAGS(io) &= ~IOf_START;
2021 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2023 sv_setpvn(GvSV(gv), "-", 1);
2026 GvSV(gv) = newSVpvn("-", 1);
2028 SvSETMAGIC(GvSV(gv));
2030 else if (!nextargv(gv))
2035 gv = PL_last_in_gv; /* eof */
2038 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
2041 IO * const io = GvIO(gv);
2043 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
2045 XPUSHs(SvTIED_obj((SV*)io, mg));
2048 call_method("EOF", G_SCALAR);
2055 PUSHs(boolSV(!gv || do_eof(gv)));
2066 PL_last_in_gv = (GV*)POPs;
2069 if (gv && (io = GvIO(gv))) {
2070 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2073 XPUSHs(SvTIED_obj((SV*)io, mg));
2076 call_method("TELL", G_SCALAR);
2083 #if LSEEKSIZE > IVSIZE
2084 PUSHn( do_tell(gv) );
2086 PUSHi( do_tell(gv) );
2094 const int whence = POPi;
2095 #if LSEEKSIZE > IVSIZE
2096 const Off_t offset = (Off_t)SvNVx(POPs);
2098 const Off_t offset = (Off_t)SvIVx(POPs);
2101 GV * const gv = PL_last_in_gv = (GV*)POPs;
2104 if (gv && (io = GvIO(gv))) {
2105 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2108 XPUSHs(SvTIED_obj((SV*)io, mg));
2109 #if LSEEKSIZE > IVSIZE
2110 mXPUSHn((NV) offset);
2117 call_method("SEEK", G_SCALAR);
2124 if (PL_op->op_type == OP_SEEK)
2125 PUSHs(boolSV(do_seek(gv, offset, whence)));
2127 const Off_t sought = do_sysseek(gv, offset, whence);
2129 PUSHs(&PL_sv_undef);
2131 SV* const sv = sought ?
2132 #if LSEEKSIZE > IVSIZE
2137 : newSVpvn(zero_but_true, ZBTLEN);
2148 /* There seems to be no consensus on the length type of truncate()
2149 * and ftruncate(), both off_t and size_t have supporters. In
2150 * general one would think that when using large files, off_t is
2151 * at least as wide as size_t, so using an off_t should be okay. */
2152 /* XXX Configure probe for the length type of *truncate() needed XXX */
2155 #if Off_t_size > IVSIZE
2160 /* Checking for length < 0 is problematic as the type might or
2161 * might not be signed: if it is not, clever compilers will moan. */
2162 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2169 if (PL_op->op_flags & OPf_SPECIAL) {
2170 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2179 TAINT_PROPER("truncate");
2180 if (!(fp = IoIFP(io))) {
2186 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2188 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2195 SV * const sv = POPs;
2198 if (SvTYPE(sv) == SVt_PVGV) {
2199 tmpgv = (GV*)sv; /* *main::FRED for example */
2200 goto do_ftruncate_gv;
2202 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2203 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
2204 goto do_ftruncate_gv;
2206 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2207 io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
2208 goto do_ftruncate_io;
2211 name = SvPV_nolen_const(sv);
2212 TAINT_PROPER("truncate");
2214 if (truncate(name, len) < 0)
2218 const int tmpfd = PerlLIO_open(name, O_RDWR);
2223 if (my_chsize(tmpfd, len) < 0)
2225 PerlLIO_close(tmpfd);
2234 SETERRNO(EBADF,RMS_IFI);
2242 SV * const argsv = POPs;
2243 const unsigned int func = POPu;
2244 const int optype = PL_op->op_type;
2245 GV * const gv = (GV*)POPs;
2246 IO * const io = gv ? GvIOn(gv) : NULL;
2250 if (!io || !argsv || !IoIFP(io)) {
2251 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2252 report_evil_fh(gv, io, PL_op->op_type);
2253 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2257 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2260 s = SvPV_force(argsv, len);
2261 need = IOCPARM_LEN(func);
2263 s = Sv_Grow(argsv, need + 1);
2264 SvCUR_set(argsv, need);
2267 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2270 retval = SvIV(argsv);
2271 s = INT2PTR(char*,retval); /* ouch */
2274 TAINT_PROPER(PL_op_desc[optype]);
2276 if (optype == OP_IOCTL)
2278 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2280 DIE(aTHX_ "ioctl is not implemented");
2284 DIE(aTHX_ "fcntl is not implemented");
2286 #if defined(OS2) && defined(__EMX__)
2287 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2289 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2293 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2295 if (s[SvCUR(argsv)] != 17)
2296 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2298 s[SvCUR(argsv)] = 0; /* put our null back */
2299 SvSETMAGIC(argsv); /* Assume it has changed */
2308 PUSHp(zero_but_true, ZBTLEN);
2321 const int argtype = POPi;
2322 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
2324 if (gv && (io = GvIO(gv)))
2330 /* XXX Looks to me like io is always NULL at this point */
2332 (void)PerlIO_flush(fp);
2333 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2336 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2337 report_evil_fh(gv, io, PL_op->op_type);
2339 SETERRNO(EBADF,RMS_IFI);
2344 DIE(aTHX_ PL_no_func, "flock()");
2354 const int protocol = POPi;
2355 const int type = POPi;
2356 const int domain = POPi;
2357 GV * const gv = (GV*)POPs;
2358 register IO * const io = gv ? GvIOn(gv) : NULL;
2362 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2363 report_evil_fh(gv, io, PL_op->op_type);
2364 if (io && IoIFP(io))
2365 do_close(gv, FALSE);
2366 SETERRNO(EBADF,LIB_INVARG);
2371 do_close(gv, FALSE);
2373 TAINT_PROPER("socket");
2374 fd = PerlSock_socket(domain, type, protocol);
2377 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2378 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2379 IoTYPE(io) = IoTYPE_SOCKET;
2380 if (!IoIFP(io) || !IoOFP(io)) {
2381 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2382 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2383 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2386 #if defined(HAS_FCNTL) && defined(F_SETFD)
2387 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2391 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2396 DIE(aTHX_ PL_no_sock_func, "socket");
2402 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2404 const int protocol = POPi;
2405 const int type = POPi;
2406 const int domain = POPi;
2407 GV * const gv2 = (GV*)POPs;
2408 GV * const gv1 = (GV*)POPs;
2409 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2410 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2413 if (!gv1 || !gv2 || !io1 || !io2) {
2414 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2416 report_evil_fh(gv1, io1, PL_op->op_type);
2418 report_evil_fh(gv1, io2, PL_op->op_type);
2420 if (io1 && IoIFP(io1))
2421 do_close(gv1, FALSE);
2422 if (io2 && IoIFP(io2))
2423 do_close(gv2, FALSE);
2428 do_close(gv1, FALSE);
2430 do_close(gv2, FALSE);
2432 TAINT_PROPER("socketpair");
2433 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2435 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2436 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2437 IoTYPE(io1) = IoTYPE_SOCKET;
2438 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2439 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2440 IoTYPE(io2) = IoTYPE_SOCKET;
2441 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2442 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2443 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2444 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2445 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2446 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2447 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2450 #if defined(HAS_FCNTL) && defined(F_SETFD)
2451 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2452 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2457 DIE(aTHX_ PL_no_sock_func, "socketpair");
2465 SV * const addrsv = POPs;
2466 /* OK, so on what platform does bind modify addr? */
2468 GV * const gv = (GV*)POPs;
2469 register IO * const io = GvIOn(gv);
2472 if (!io || !IoIFP(io))
2475 addr = SvPV_const(addrsv, len);
2476 TAINT_PROPER("bind");
2477 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2483 if (ckWARN(WARN_CLOSED))
2484 report_evil_fh(gv, io, PL_op->op_type);
2485 SETERRNO(EBADF,SS_IVCHAN);
2488 DIE(aTHX_ PL_no_sock_func, "bind");
2496 SV * const addrsv = POPs;
2497 GV * const gv = (GV*)POPs;
2498 register IO * const io = GvIOn(gv);
2502 if (!io || !IoIFP(io))
2505 addr = SvPV_const(addrsv, len);
2506 TAINT_PROPER("connect");
2507 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2513 if (ckWARN(WARN_CLOSED))
2514 report_evil_fh(gv, io, PL_op->op_type);
2515 SETERRNO(EBADF,SS_IVCHAN);
2518 DIE(aTHX_ PL_no_sock_func, "connect");
2526 const int backlog = POPi;
2527 GV * const gv = (GV*)POPs;
2528 register IO * const io = gv ? GvIOn(gv) : NULL;
2530 if (!gv || !io || !IoIFP(io))
2533 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2539 if (ckWARN(WARN_CLOSED))
2540 report_evil_fh(gv, io, PL_op->op_type);
2541 SETERRNO(EBADF,SS_IVCHAN);
2544 DIE(aTHX_ PL_no_sock_func, "listen");
2554 char namebuf[MAXPATHLEN];
2555 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2556 Sock_size_t len = sizeof (struct sockaddr_in);
2558 Sock_size_t len = sizeof namebuf;
2560 GV * const ggv = (GV*)POPs;
2561 GV * const ngv = (GV*)POPs;
2570 if (!gstio || !IoIFP(gstio))
2574 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2577 /* Some platforms indicate zero length when an AF_UNIX client is
2578 * not bound. Simulate a non-zero-length sockaddr structure in
2580 namebuf[0] = 0; /* sun_len */
2581 namebuf[1] = AF_UNIX; /* sun_family */
2589 do_close(ngv, FALSE);
2590 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2591 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2592 IoTYPE(nstio) = IoTYPE_SOCKET;
2593 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2594 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2595 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2596 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2599 #if defined(HAS_FCNTL) && defined(F_SETFD)
2600 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2604 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2605 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2607 #ifdef __SCO_VERSION__
2608 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2611 PUSHp(namebuf, len);
2615 if (ckWARN(WARN_CLOSED))
2616 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2617 SETERRNO(EBADF,SS_IVCHAN);
2623 DIE(aTHX_ PL_no_sock_func, "accept");
2631 const int how = POPi;
2632 GV * const gv = (GV*)POPs;
2633 register IO * const io = GvIOn(gv);
2635 if (!io || !IoIFP(io))
2638 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2642 if (ckWARN(WARN_CLOSED))
2643 report_evil_fh(gv, io, PL_op->op_type);
2644 SETERRNO(EBADF,SS_IVCHAN);
2647 DIE(aTHX_ PL_no_sock_func, "shutdown");
2655 const int optype = PL_op->op_type;
2656 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2657 const unsigned int optname = (unsigned int) POPi;
2658 const unsigned int lvl = (unsigned int) POPi;
2659 GV * const gv = (GV*)POPs;
2660 register IO * const io = GvIOn(gv);
2664 if (!io || !IoIFP(io))
2667 fd = PerlIO_fileno(IoIFP(io));
2671 (void)SvPOK_only(sv);
2675 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2682 #if defined(__SYMBIAN32__)
2683 # define SETSOCKOPT_OPTION_VALUE_T void *
2685 # define SETSOCKOPT_OPTION_VALUE_T const char *
2687 /* XXX TODO: We need to have a proper type (a Configure probe,
2688 * etc.) for what the C headers think of the third argument of
2689 * setsockopt(), the option_value read-only buffer: is it
2690 * a "char *", or a "void *", const or not. Some compilers
2691 * don't take kindly to e.g. assuming that "char *" implicitly
2692 * promotes to a "void *", or to explicitly promoting/demoting
2693 * consts to non/vice versa. The "const void *" is the SUS
2694 * definition, but that does not fly everywhere for the above
2696 SETSOCKOPT_OPTION_VALUE_T buf;
2700 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2704 aint = (int)SvIV(sv);
2705 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2708 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2717 if (ckWARN(WARN_CLOSED))
2718 report_evil_fh(gv, io, optype);
2719 SETERRNO(EBADF,SS_IVCHAN);
2724 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2732 const int optype = PL_op->op_type;
2733 GV * const gv = (GV*)POPs;
2734 register IO * const io = GvIOn(gv);
2739 if (!io || !IoIFP(io))
2742 sv = sv_2mortal(newSV(257));
2743 (void)SvPOK_only(sv);
2747 fd = PerlIO_fileno(IoIFP(io));
2749 case OP_GETSOCKNAME:
2750 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2753 case OP_GETPEERNAME:
2754 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2756 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2758 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";
2759 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2760 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2761 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2762 sizeof(u_short) + sizeof(struct in_addr))) {
2769 #ifdef BOGUS_GETNAME_RETURN
2770 /* Interactive Unix, getpeername() and getsockname()
2771 does not return valid namelen */
2772 if (len == BOGUS_GETNAME_RETURN)
2773 len = sizeof(struct sockaddr);
2781 if (ckWARN(WARN_CLOSED))
2782 report_evil_fh(gv, io, optype);
2783 SETERRNO(EBADF,SS_IVCHAN);
2788 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2803 if (PL_op->op_flags & OPf_REF) {
2805 if (PL_op->op_type == OP_LSTAT) {
2806 if (gv != PL_defgv) {
2807 do_fstat_warning_check:
2808 if (ckWARN(WARN_IO))
2809 Perl_warner(aTHX_ packWARN(WARN_IO),
2810 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2811 } else if (PL_laststype != OP_LSTAT)
2812 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2816 if (gv != PL_defgv) {
2817 PL_laststype = OP_STAT;
2819 sv_setpvn(PL_statname, "", 0);
2826 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2827 } else if (IoDIRP(io)) {
2829 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2831 PL_laststatval = -1;
2837 if (PL_laststatval < 0) {
2838 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2839 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2844 SV* const sv = POPs;
2845 if (SvTYPE(sv) == SVt_PVGV) {
2848 } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2850 if (PL_op->op_type == OP_LSTAT)
2851 goto do_fstat_warning_check;
2853 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2855 if (PL_op->op_type == OP_LSTAT)
2856 goto do_fstat_warning_check;
2857 goto do_fstat_have_io;
2860 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2862 PL_laststype = PL_op->op_type;
2863 if (PL_op->op_type == OP_LSTAT)
2864 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2866 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2867 if (PL_laststatval < 0) {
2868 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2869 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2875 if (gimme != G_ARRAY) {
2876 if (gimme != G_VOID)
2877 XPUSHs(boolSV(max));
2883 mPUSHi(PL_statcache.st_dev);
2884 mPUSHi(PL_statcache.st_ino);
2885 mPUSHu(PL_statcache.st_mode);
2886 mPUSHu(PL_statcache.st_nlink);
2887 #if Uid_t_size > IVSIZE
2888 mPUSHn(PL_statcache.st_uid);
2890 # if Uid_t_sign <= 0
2891 mPUSHi(PL_statcache.st_uid);
2893 mPUSHu(PL_statcache.st_uid);
2896 #if Gid_t_size > IVSIZE
2897 mPUSHn(PL_statcache.st_gid);
2899 # if Gid_t_sign <= 0
2900 mPUSHi(PL_statcache.st_gid);
2902 mPUSHu(PL_statcache.st_gid);
2905 #ifdef USE_STAT_RDEV
2906 mPUSHi(PL_statcache.st_rdev);
2908 PUSHs(newSVpvs_flags("", SVs_TEMP));
2910 #if Off_t_size > IVSIZE
2911 mPUSHn(PL_statcache.st_size);
2913 mPUSHi(PL_statcache.st_size);
2916 mPUSHn(PL_statcache.st_atime);
2917 mPUSHn(PL_statcache.st_mtime);
2918 mPUSHn(PL_statcache.st_ctime);
2920 mPUSHi(PL_statcache.st_atime);
2921 mPUSHi(PL_statcache.st_mtime);
2922 mPUSHi(PL_statcache.st_ctime);
2924 #ifdef USE_STAT_BLOCKS
2925 mPUSHu(PL_statcache.st_blksize);
2926 mPUSHu(PL_statcache.st_blocks);
2928 PUSHs(newSVpvs_flags("", SVs_TEMP));
2929 PUSHs(newSVpvs_flags("", SVs_TEMP));
2935 /* This macro is used by the stacked filetest operators :
2936 * if the previous filetest failed, short-circuit and pass its value.
2937 * Else, discard it from the stack and continue. --rgs
2939 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2940 if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
2941 else { (void)POPs; PUTBACK; } \
2948 /* Not const, because things tweak this below. Not bool, because there's
2949 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2950 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2951 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2952 /* Giving some sort of initial value silences compilers. */
2954 int access_mode = R_OK;
2956 int access_mode = 0;
2959 /* access_mode is never used, but leaving use_access in makes the
2960 conditional compiling below much clearer. */
2963 int stat_mode = S_IRUSR;
2965 bool effective = FALSE;
2968 STACKED_FTEST_CHECK;
2970 switch (PL_op->op_type) {
2972 #if !(defined(HAS_ACCESS) && defined(R_OK))
2978 #if defined(HAS_ACCESS) && defined(W_OK)
2983 stat_mode = S_IWUSR;
2987 #if defined(HAS_ACCESS) && defined(X_OK)
2992 stat_mode = S_IXUSR;
2996 #ifdef PERL_EFF_ACCESS
2999 stat_mode = S_IWUSR;
3003 #ifndef PERL_EFF_ACCESS
3010 #ifdef PERL_EFF_ACCESS
3015 stat_mode = S_IXUSR;
3021 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3022 const char *name = POPpx;
3024 # ifdef PERL_EFF_ACCESS
3025 result = PERL_EFF_ACCESS(name, access_mode);
3027 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3033 result = access(name, access_mode);
3035 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3050 if (cando(stat_mode, effective, &PL_statcache))
3059 const int op_type = PL_op->op_type;
3061 STACKED_FTEST_CHECK;
3066 if (op_type == OP_FTIS)
3069 /* You can't dTARGET inside OP_FTIS, because you'll get
3070 "panic: pad_sv po" - the op is not flagged to have a target. */
3074 #if Off_t_size > IVSIZE
3075 PUSHn(PL_statcache.st_size);
3077 PUSHi(PL_statcache.st_size);
3081 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3084 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3087 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3100 /* I believe that all these three are likely to be defined on most every
3101 system these days. */
3103 if(PL_op->op_type == OP_FTSUID)
3107 if(PL_op->op_type == OP_FTSGID)
3111 if(PL_op->op_type == OP_FTSVTX)
3115 STACKED_FTEST_CHECK;
3120 switch (PL_op->op_type) {
3122 if (PL_statcache.st_uid == PL_uid)
3126 if (PL_statcache.st_uid == PL_euid)
3130 if (PL_statcache.st_size == 0)
3134 if (S_ISSOCK(PL_statcache.st_mode))
3138 if (S_ISCHR(PL_statcache.st_mode))
3142 if (S_ISBLK(PL_statcache.st_mode))
3146 if (S_ISREG(PL_statcache.st_mode))
3150 if (S_ISDIR(PL_statcache.st_mode))
3154 if (S_ISFIFO(PL_statcache.st_mode))
3159 if (PL_statcache.st_mode & S_ISUID)
3165 if (PL_statcache.st_mode & S_ISGID)
3171 if (PL_statcache.st_mode & S_ISVTX)
3182 I32 result = my_lstat();
3186 if (S_ISLNK(PL_statcache.st_mode))
3199 STACKED_FTEST_CHECK;
3201 if (PL_op->op_flags & OPf_REF)
3203 else if (isGV(TOPs))
3205 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3206 gv = (GV*)SvRV(POPs);
3208 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3210 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3211 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3212 else if (tmpsv && SvOK(tmpsv)) {
3213 const char *tmps = SvPV_nolen_const(tmpsv);
3221 if (PerlLIO_isatty(fd))
3226 #if defined(atarist) /* this will work with atariST. Configure will
3227 make guesses for other systems. */
3228 # define FILE_base(f) ((f)->_base)
3229 # define FILE_ptr(f) ((f)->_ptr)
3230 # define FILE_cnt(f) ((f)->_cnt)
3231 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3242 register STDCHAR *s;
3248 STACKED_FTEST_CHECK;
3250 if (PL_op->op_flags & OPf_REF)
3252 else if (isGV(TOPs))
3254 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3255 gv = (GV*)SvRV(POPs);
3261 if (gv == PL_defgv) {
3263 io = GvIO(PL_statgv);
3266 goto really_filename;
3271 PL_laststatval = -1;
3272 sv_setpvn(PL_statname, "", 0);
3273 io = GvIO(PL_statgv);
3275 if (io && IoIFP(io)) {
3276 if (! PerlIO_has_base(IoIFP(io)))
3277 DIE(aTHX_ "-T and -B not implemented on filehandles");
3278 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3279 if (PL_laststatval < 0)
3281 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3282 if (PL_op->op_type == OP_FTTEXT)
3287 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3288 i = PerlIO_getc(IoIFP(io));
3290 (void)PerlIO_ungetc(IoIFP(io),i);
3292 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3294 len = PerlIO_get_bufsiz(IoIFP(io));
3295 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3296 /* sfio can have large buffers - limit to 512 */
3301 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3303 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3305 SETERRNO(EBADF,RMS_IFI);
3313 PL_laststype = OP_STAT;
3314 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3315 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3316 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3318 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3321 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3322 if (PL_laststatval < 0) {
3323 (void)PerlIO_close(fp);
3326 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3327 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3328 (void)PerlIO_close(fp);
3330 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3331 RETPUSHNO; /* special case NFS directories */
3332 RETPUSHYES; /* null file is anything */
3337 /* now scan s to look for textiness */
3338 /* XXX ASCII dependent code */
3340 #if defined(DOSISH) || defined(USEMYBINMODE)
3341 /* ignore trailing ^Z on short files */
3342 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3346 for (i = 0; i < len; i++, s++) {
3347 if (!*s) { /* null never allowed in text */
3352 else if (!(isPRINT(*s) || isSPACE(*s)))
3355 else if (*s & 128) {
3357 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3360 /* utf8 characters don't count as odd */
3361 if (UTF8_IS_START(*s)) {
3362 int ulen = UTF8SKIP(s);
3363 if (ulen < len - i) {
3365 for (j = 1; j < ulen; j++) {
3366 if (!UTF8_IS_CONTINUATION(s[j]))
3369 --ulen; /* loop does extra increment */
3379 *s != '\n' && *s != '\r' && *s != '\b' &&
3380 *s != '\t' && *s != '\f' && *s != 27)
3385 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3396 const char *tmps = NULL;
3400 SV * const sv = POPs;
3401 if (PL_op->op_flags & OPf_SPECIAL) {
3402 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3404 else if (SvTYPE(sv) == SVt_PVGV) {
3407 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
3411 tmps = SvPV_nolen_const(sv);
3415 if( !gv && (!tmps || !*tmps) ) {
3416 HV * const table = GvHVn(PL_envgv);
3419 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3420 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3422 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3427 deprecate("chdir('') or chdir(undef) as chdir()");
3428 tmps = SvPV_nolen_const(*svp);
3432 TAINT_PROPER("chdir");
3437 TAINT_PROPER("chdir");
3440 IO* const io = GvIO(gv);
3443 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3444 } else if (IoIFP(io)) {
3445 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3448 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3449 report_evil_fh(gv, io, PL_op->op_type);
3450 SETERRNO(EBADF, RMS_IFI);
3455 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3456 report_evil_fh(gv, io, PL_op->op_type);
3457 SETERRNO(EBADF,RMS_IFI);
3461 DIE(aTHX_ PL_no_func, "fchdir");
3465 PUSHi( PerlDir_chdir(tmps) >= 0 );
3467 /* Clear the DEFAULT element of ENV so we'll get the new value
3469 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3476 dVAR; dSP; dMARK; dTARGET;
3477 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3488 char * const tmps = POPpx;
3489 TAINT_PROPER("chroot");
3490 PUSHi( chroot(tmps) >= 0 );
3493 DIE(aTHX_ PL_no_func, "chroot");
3501 const char * const tmps2 = POPpconstx;
3502 const char * const tmps = SvPV_nolen_const(TOPs);
3503 TAINT_PROPER("rename");
3505 anum = PerlLIO_rename(tmps, tmps2);
3507 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3508 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3511 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3512 (void)UNLINK(tmps2);
3513 if (!(anum = link(tmps, tmps2)))
3514 anum = UNLINK(tmps);
3522 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3526 const int op_type = PL_op->op_type;
3530 if (op_type == OP_LINK)
3531 DIE(aTHX_ PL_no_func, "link");
3533 # ifndef HAS_SYMLINK
3534 if (op_type == OP_SYMLINK)
3535 DIE(aTHX_ PL_no_func, "symlink");
3539 const char * const tmps2 = POPpconstx;
3540 const char * const tmps = SvPV_nolen_const(TOPs);
3541 TAINT_PROPER(PL_op_desc[op_type]);
3543 # if defined(HAS_LINK)
3544 # if defined(HAS_SYMLINK)
3545 /* Both present - need to choose which. */
3546 (op_type == OP_LINK) ?
3547 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3549 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3550 PerlLIO_link(tmps, tmps2);
3553 # if defined(HAS_SYMLINK)
3554 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3555 symlink(tmps, tmps2);
3560 SETi( result >= 0 );
3567 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3578 char buf[MAXPATHLEN];
3581 #ifndef INCOMPLETE_TAINTS
3585 len = readlink(tmps, buf, sizeof(buf) - 1);
3593 RETSETUNDEF; /* just pretend it's a normal file */
3597 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3599 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3601 char * const save_filename = filename;
3606 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3608 PERL_ARGS_ASSERT_DOONELINER;
3610 Newx(cmdline, size, char);
3611 my_strlcpy(cmdline, cmd, size);
3612 my_strlcat(cmdline, " ", size);
3613 for (s = cmdline + strlen(cmdline); *filename; ) {
3617 if (s - cmdline < size)
3618 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3619 myfp = PerlProc_popen(cmdline, "r");
3623 SV * const tmpsv = sv_newmortal();
3624 /* Need to save/restore 'PL_rs' ?? */
3625 s = sv_gets(tmpsv, myfp, 0);
3626 (void)PerlProc_pclose(myfp);
3630 #ifdef HAS_SYS_ERRLIST
3635 /* you don't see this */
3636 const char * const errmsg =
3637 #ifdef HAS_SYS_ERRLIST
3645 if (instr(s, errmsg)) {
3652 #define EACCES EPERM
3654 if (instr(s, "cannot make"))
3655 SETERRNO(EEXIST,RMS_FEX);
3656 else if (instr(s, "existing file"))
3657 SETERRNO(EEXIST,RMS_FEX);
3658 else if (instr(s, "ile exists"))
3659 SETERRNO(EEXIST,RMS_FEX);
3660 else if (instr(s, "non-exist"))
3661 SETERRNO(ENOENT,RMS_FNF);
3662 else if (instr(s, "does not exist"))
3663 SETERRNO(ENOENT,RMS_FNF);
3664 else if (instr(s, "not empty"))
3665 SETERRNO(EBUSY,SS_DEVOFFLINE);
3666 else if (instr(s, "cannot access"))
3667 SETERRNO(EACCES,RMS_PRV);
3669 SETERRNO(EPERM,RMS_PRV);
3672 else { /* some mkdirs return no failure indication */
3673 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3674 if (PL_op->op_type == OP_RMDIR)
3679 SETERRNO(EACCES,RMS_PRV); /* a guess */
3688 /* This macro removes trailing slashes from a directory name.
3689 * Different operating and file systems take differently to
3690 * trailing slashes. According to POSIX 1003.1 1996 Edition
3691 * any number of trailing slashes should be allowed.
3692 * Thusly we snip them away so that even non-conforming
3693 * systems are happy.
3694 * We should probably do this "filtering" for all
3695 * the functions that expect (potentially) directory names:
3696 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3697 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3699 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3700 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3703 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3704 (tmps) = savepvn((tmps), (len)); \
3714 const int mode = (MAXARG > 1) ? POPi : 0777;
3716 TRIMSLASHES(tmps,len,copy);
3718 TAINT_PROPER("mkdir");
3720 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3724 SETi( dooneliner("mkdir", tmps) );
3725 oldumask = PerlLIO_umask(0);
3726 PerlLIO_umask(oldumask);
3727 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3742 TRIMSLASHES(tmps,len,copy);
3743 TAINT_PROPER("rmdir");
3745 SETi( PerlDir_rmdir(tmps) >= 0 );
3747 SETi( dooneliner("rmdir", tmps) );
3754 /* Directory calls. */
3758 #if defined(Direntry_t) && defined(HAS_READDIR)
3760 const char * const dirname = POPpconstx;
3761 GV * const gv = (GV*)POPs;
3762 register IO * const io = GvIOn(gv);
3767 if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED))
3768 Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3769 "Opening filehandle %s also as a directory", GvENAME(gv));
3771 PerlDir_close(IoDIRP(io));
3772 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3778 SETERRNO(EBADF,RMS_DIR);
3781 DIE(aTHX_ PL_no_dir_func, "opendir");
3787 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3788 DIE(aTHX_ PL_no_dir_func, "readdir");
3790 #if !defined(I_DIRENT) && !defined(VMS)
3791 Direntry_t *readdir (DIR *);
3797 const I32 gimme = GIMME;
3798 GV * const gv = (GV *)POPs;
3799 register const Direntry_t *dp;
3800 register IO * const io = GvIOn(gv);
3802 if (!io || !IoDIRP(io)) {
3803 if(ckWARN(WARN_IO)) {
3804 Perl_warner(aTHX_ packWARN(WARN_IO),
3805 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3811 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3815 sv = newSVpvn(dp->d_name, dp->d_namlen);
3817 sv = newSVpv(dp->d_name, 0);
3819 #ifndef INCOMPLETE_TAINTS
3820 if (!(IoFLAGS(io) & IOf_UNTAINT))
3824 } while (gimme == G_ARRAY);
3826 if (!dp && gimme != G_ARRAY)
3833 SETERRNO(EBADF,RMS_ISI);
3834 if (GIMME == G_ARRAY)
3843 #if defined(HAS_TELLDIR) || defined(telldir)
3845 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3846 /* XXX netbsd still seemed to.
3847 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3848 --JHI 1999-Feb-02 */
3849 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3850 long telldir (DIR *);
3852 GV * const gv = (GV*)POPs;
3853 register IO * const io = GvIOn(gv);
3855 if (!io || !IoDIRP(io)) {
3856 if(ckWARN(WARN_IO)) {
3857 Perl_warner(aTHX_ packWARN(WARN_IO),
3858 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3863 PUSHi( PerlDir_tell(IoDIRP(io)) );
3867 SETERRNO(EBADF,RMS_ISI);
3870 DIE(aTHX_ PL_no_dir_func, "telldir");
3876 #if defined(HAS_SEEKDIR) || defined(seekdir)
3878 const long along = POPl;
3879 GV * const gv = (GV*)POPs;
3880 register IO * const io = GvIOn(gv);
3882 if (!io || !IoDIRP(io)) {
3883 if(ckWARN(WARN_IO)) {
3884 Perl_warner(aTHX_ packWARN(WARN_IO),
3885 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3889 (void)PerlDir_seek(IoDIRP(io), along);
3894 SETERRNO(EBADF,RMS_ISI);
3897 DIE(aTHX_ PL_no_dir_func, "seekdir");
3903 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3905 GV * const gv = (GV*)POPs;
3906 register IO * const io = GvIOn(gv);
3908 if (!io || !IoDIRP(io)) {
3909 if(ckWARN(WARN_IO)) {
3910 Perl_warner(aTHX_ packWARN(WARN_IO),
3911 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3915 (void)PerlDir_rewind(IoDIRP(io));
3919 SETERRNO(EBADF,RMS_ISI);
3922 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3928 #if defined(Direntry_t) && defined(HAS_READDIR)
3930 GV * const gv = (GV*)POPs;
3931 register IO * const io = GvIOn(gv);
3933 if (!io || !IoDIRP(io)) {
3934 if(ckWARN(WARN_IO)) {
3935 Perl_warner(aTHX_ packWARN(WARN_IO),
3936 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3940 #ifdef VOID_CLOSEDIR
3941 PerlDir_close(IoDIRP(io));
3943 if (PerlDir_close(IoDIRP(io)) < 0) {
3944 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3953 SETERRNO(EBADF,RMS_IFI);
3956 DIE(aTHX_ PL_no_dir_func, "closedir");
3960 /* Process control. */
3969 PERL_FLUSHALL_FOR_CHILD;
3970 childpid = PerlProc_fork();
3974 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3976 SvREADONLY_off(GvSV(tmpgv));
3977 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3978 SvREADONLY_on(GvSV(tmpgv));
3980 #ifdef THREADS_HAVE_PIDS
3981 PL_ppid = (IV)getppid();
3983 #ifdef PERL_USES_PL_PIDSTATUS
3984 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3990 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3995 PERL_FLUSHALL_FOR_CHILD;
3996 childpid = PerlProc_fork();
4002 DIE(aTHX_ PL_no_func, "fork");
4009 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4014 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4015 childpid = wait4pid(-1, &argflags, 0);
4017 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4022 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4023 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4024 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4026 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4031 DIE(aTHX_ PL_no_func, "wait");
4037 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4039 const int optype = POPi;
4040 const Pid_t pid = TOPi;
4044 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4045 result = wait4pid(pid, &argflags, optype);
4047 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4052 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4053 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4054 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4056 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4061 DIE(aTHX_ PL_no_func, "waitpid");
4067 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4068 #if defined(__LIBCATAMOUNT__)
4069 PL_statusvalue = -1;
4078 while (++MARK <= SP) {
4079 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4084 TAINT_PROPER("system");
4086 PERL_FLUSHALL_FOR_CHILD;
4087 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4093 if (PerlProc_pipe(pp) >= 0)
4095 while ((childpid = PerlProc_fork()) == -1) {
4096 if (errno != EAGAIN) {
4101 PerlLIO_close(pp[0]);
4102 PerlLIO_close(pp[1]);
4109 Sigsave_t ihand,qhand; /* place to save signals during system() */
4113 PerlLIO_close(pp[1]);
4115 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4116 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4119 result = wait4pid(childpid, &status, 0);
4120 } while (result == -1 && errno == EINTR);
4122 (void)rsignal_restore(SIGINT, &ihand);
4123 (void)rsignal_restore(SIGQUIT, &qhand);
4125 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4126 do_execfree(); /* free any memory child malloced on fork */
4133 while (n < sizeof(int)) {
4134 n1 = PerlLIO_read(pp[0],
4135 (void*)(((char*)&errkid)+n),
4141 PerlLIO_close(pp[0]);
4142 if (n) { /* Error */
4143 if (n != sizeof(int))
4144 DIE(aTHX_ "panic: kid popen errno read");
4145 errno = errkid; /* Propagate errno from kid */
4146 STATUS_NATIVE_CHILD_SET(-1);
4149 XPUSHi(STATUS_CURRENT);
4153 PerlLIO_close(pp[0]);
4154 #if defined(HAS_FCNTL) && defined(F_SETFD)
4155 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4158 if (PL_op->op_flags & OPf_STACKED) {
4159 SV * const really = *++MARK;
4160 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4162 else if (SP - MARK != 1)
4163 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4165 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4169 #else /* ! FORK or VMS or OS/2 */
4172 if (PL_op->op_flags & OPf_STACKED) {
4173 SV * const really = *++MARK;
4174 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4175 value = (I32)do_aspawn(really, MARK, SP);
4177 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4180 else if (SP - MARK != 1) {
4181 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4182 value = (I32)do_aspawn(NULL, MARK, SP);
4184 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4188 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4190 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4192 STATUS_NATIVE_CHILD_SET(value);
4195 XPUSHi(result ? value : STATUS_CURRENT);
4196 #endif /* !FORK or VMS or OS/2 */
4203 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4208 while (++MARK <= SP) {
4209 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4214 TAINT_PROPER("exec");
4216 PERL_FLUSHALL_FOR_CHILD;
4217 if (PL_op->op_flags & OPf_STACKED) {
4218 SV * const really = *++MARK;
4219 value = (I32)do_aexec(really, MARK, SP);
4221 else if (SP - MARK != 1)
4223 value = (I32)vms_do_aexec(NULL, MARK, SP);
4227 (void ) do_aspawn(NULL, MARK, SP);
4231 value = (I32)do_aexec(NULL, MARK, SP);
4236 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4239 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4242 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4256 # ifdef THREADS_HAVE_PIDS
4257 if (PL_ppid != 1 && getppid() == 1)
4258 /* maybe the parent process has died. Refresh ppid cache */
4262 XPUSHi( getppid() );
4266 DIE(aTHX_ PL_no_func, "getppid");
4275 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4278 pgrp = (I32)BSD_GETPGRP(pid);
4280 if (pid != 0 && pid != PerlProc_getpid())
4281 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4287 DIE(aTHX_ PL_no_func, "getpgrp()");
4306 TAINT_PROPER("setpgrp");
4308 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4310 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4311 || (pid != 0 && pid != PerlProc_getpid()))
4313 DIE(aTHX_ "setpgrp can't take arguments");
4315 SETi( setpgrp() >= 0 );
4316 #endif /* USE_BSDPGRP */
4319 DIE(aTHX_ PL_no_func, "setpgrp()");
4325 #ifdef HAS_GETPRIORITY
4327 const int who = POPi;
4328 const int which = TOPi;
4329 SETi( getpriority(which, who) );
4332 DIE(aTHX_ PL_no_func, "getpriority()");
4338 #ifdef HAS_SETPRIORITY
4340 const int niceval = POPi;
4341 const int who = POPi;
4342 const int which = TOPi;
4343 TAINT_PROPER("setpriority");
4344 SETi( setpriority(which, who, niceval) >= 0 );
4347 DIE(aTHX_ PL_no_func, "setpriority()");
4357 XPUSHn( time(NULL) );
4359 XPUSHi( time(NULL) );
4371 (void)PerlProc_times(&PL_timesbuf);
4373 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4374 /* struct tms, though same data */
4378 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4379 if (GIMME == G_ARRAY) {
4380 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4381 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4382 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4390 if (GIMME == G_ARRAY) {
4397 DIE(aTHX_ "times not implemented");
4399 #endif /* HAS_TIMES */
4402 #ifdef LOCALTIME_EDGECASE_BROKEN
4403 static struct tm *S_my_localtime (pTHX_ Time_t *tp)
4408 /* No workarounds in the valid range */
4409 if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4410 return (localtime (tp));
4412 /* This edge case is to workaround the undefined behaviour, where the
4413 * TIMEZONE makes the time go beyond the defined range.
4414 * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4415 * If there is a negative offset in TZ, like MET-1METDST, some broken
4416 * implementations of localtime () (like AIX 5.2) barf with bogus
4418 * 0x7fffffff gmtime 2038-01-19 03:14:07
4419 * 0x7fffffff localtime 1901-12-13 21:45:51
4420 * 0x7fffffff mylocaltime 2038-01-19 04:14:07
4421 * 0x3c19137f gmtime 2001-12-13 20:45:51
4422 * 0x3c19137f localtime 2001-12-13 21:45:51
4423 * 0x3c19137f mylocaltime 2001-12-13 21:45:51
4424 * Given that legal timezones are typically between GMT-12 and GMT+12
4425 * we turn back the clock 23 hours before calling the localtime
4426 * function, and add those to the return value. This will never cause
4427 * day wrapping problems, since the edge case is Tue Jan *19*
4429 T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4432 if (P->tm_hour >= 24) {
4434 P->tm_mday++; /* 18 -> 19 */
4435 P->tm_wday++; /* Mon -> Tue */
4436 P->tm_yday++; /* 18 -> 19 */
4439 } /* S_my_localtime */
4447 const struct tm *tmbuf;
4448 static const char * const dayname[] =
4449 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4450 static const char * const monname[] =
4451 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4452 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4458 when = (Time_t)SvNVx(POPs);
4460 when = (Time_t)SvIVx(POPs);
4463 if (PL_op->op_type == OP_LOCALTIME)
4464 #ifdef LOCALTIME_EDGECASE_BROKEN
4465 tmbuf = S_my_localtime(aTHX_ &when);
4467 tmbuf = localtime(&when);
4470 tmbuf = gmtime(&when);
4472 if (GIMME != G_ARRAY) {
4478 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4479 dayname[tmbuf->tm_wday],
4480 monname[tmbuf->tm_mon],
4485 tmbuf->tm_year + 1900);
4491 mPUSHi(tmbuf->tm_sec);
4492 mPUSHi(tmbuf->tm_min);
4493 mPUSHi(tmbuf->tm_hour);
4494 mPUSHi(tmbuf->tm_mday);
4495 mPUSHi(tmbuf->tm_mon);
4496 mPUSHi(tmbuf->tm_year);
4497 mPUSHi(tmbuf->tm_wday);
4498 mPUSHi(tmbuf->tm_yday);
4499 mPUSHi(tmbuf->tm_isdst);
4510 anum = alarm((unsigned int)anum);
4517 DIE(aTHX_ PL_no_func, "alarm");
4528 (void)time(&lasttime);
4533 PerlProc_sleep((unsigned int)duration);
4536 XPUSHi(when - lasttime);
4540 /* Shared memory. */
4541 /* Merged with some message passing. */
4545 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4546 dVAR; dSP; dMARK; dTARGET;
4547 const int op_type = PL_op->op_type;
4552 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4555 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4558 value = (I32)(do_semop(MARK, SP) >= 0);
4561 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4577 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4578 dVAR; dSP; dMARK; dTARGET;
4579 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4586 DIE(aTHX_ "System V IPC is not implemented on this machine");
4592 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4593 dVAR; dSP; dMARK; dTARGET;
4594 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4602 PUSHp(zero_but_true, ZBTLEN);
4610 /* I can't const this further without getting warnings about the types of
4611 various arrays passed in from structures. */
4613 S_space_join_names_mortal(pTHX_ char *const *array)
4617 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4619 if (array && *array) {
4620 target = newSVpvs_flags("", SVs_TEMP);
4622 sv_catpv(target, *array);
4625 sv_catpvs(target, " ");
4628 target = sv_mortalcopy(&PL_sv_no);
4633 /* Get system info. */
4637 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4639 I32 which = PL_op->op_type;
4640 register char **elem;
4642 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4643 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4644 struct hostent *gethostbyname(Netdb_name_t);
4645 struct hostent *gethostent(void);
4647 struct hostent *hent;
4651 if (which == OP_GHBYNAME) {
4652 #ifdef HAS_GETHOSTBYNAME
4653 const char* const name = POPpbytex;
4654 hent = PerlSock_gethostbyname(name);
4656 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4659 else if (which == OP_GHBYADDR) {
4660 #ifdef HAS_GETHOSTBYADDR
4661 const int addrtype = POPi;
4662 SV * const addrsv = POPs;
4664 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4666 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4668 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4672 #ifdef HAS_GETHOSTENT
4673 hent = PerlSock_gethostent();
4675 DIE(aTHX_ PL_no_sock_func, "gethostent");
4678 #ifdef HOST_NOT_FOUND
4680 #ifdef USE_REENTRANT_API
4681 # ifdef USE_GETHOSTENT_ERRNO
4682 h_errno = PL_reentrant_buffer->_gethostent_errno;
4685 STATUS_UNIX_SET(h_errno);
4689 if (GIMME != G_ARRAY) {
4690 PUSHs(sv = sv_newmortal());
4692 if (which == OP_GHBYNAME) {
4694 sv_setpvn(sv, hent->h_addr, hent->h_length);
4697 sv_setpv(sv, (char*)hent->h_name);
4703 mPUSHs(newSVpv((char*)hent->h_name, 0));
4704 PUSHs(space_join_names_mortal(hent->h_aliases));
4705 mPUSHi(hent->h_addrtype);
4706 len = hent->h_length;
4709 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4710 mXPUSHp(*elem, len);
4714 mPUSHp(hent->h_addr, len);
4716 PUSHs(sv_mortalcopy(&PL_sv_no));
4721 DIE(aTHX_ PL_no_sock_func, "gethostent");
4727 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4729 I32 which = PL_op->op_type;
4731 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4732 struct netent *getnetbyaddr(Netdb_net_t, int);
4733 struct netent *getnetbyname(Netdb_name_t);
4734 struct netent *getnetent(void);
4736 struct netent *nent;
4738 if (which == OP_GNBYNAME){
4739 #ifdef HAS_GETNETBYNAME
4740 const char * const name = POPpbytex;
4741 nent = PerlSock_getnetbyname(name);
4743 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4746 else if (which == OP_GNBYADDR) {
4747 #ifdef HAS_GETNETBYADDR
4748 const int addrtype = POPi;
4749 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4750 nent = PerlSock_getnetbyaddr(addr, addrtype);
4752 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4756 #ifdef HAS_GETNETENT
4757 nent = PerlSock_getnetent();
4759 DIE(aTHX_ PL_no_sock_func, "getnetent");
4762 #ifdef HOST_NOT_FOUND
4764 #ifdef USE_REENTRANT_API
4765 # ifdef USE_GETNETENT_ERRNO
4766 h_errno = PL_reentrant_buffer->_getnetent_errno;
4769 STATUS_UNIX_SET(h_errno);
4774 if (GIMME != G_ARRAY) {
4775 PUSHs(sv = sv_newmortal());
4777 if (which == OP_GNBYNAME)
4778 sv_setiv(sv, (IV)nent->n_net);
4780 sv_setpv(sv, nent->n_name);
4786 mPUSHs(newSVpv(nent->n_name, 0));
4787 PUSHs(space_join_names_mortal(nent->n_aliases));
4788 mPUSHi(nent->n_addrtype);
4789 mPUSHi(nent->n_net);
4794 DIE(aTHX_ PL_no_sock_func, "getnetent");
4800 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4802 I32 which = PL_op->op_type;
4804 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4805 struct protoent *getprotobyname(Netdb_name_t);
4806 struct protoent *getprotobynumber(int);
4807 struct protoent *getprotoent(void);
4809 struct protoent *pent;
4811 if (which == OP_GPBYNAME) {
4812 #ifdef HAS_GETPROTOBYNAME
4813 const char* const name = POPpbytex;
4814 pent = PerlSock_getprotobyname(name);
4816 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4819 else if (which == OP_GPBYNUMBER) {
4820 #ifdef HAS_GETPROTOBYNUMBER
4821 const int number = POPi;
4822 pent = PerlSock_getprotobynumber(number);
4824 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4828 #ifdef HAS_GETPROTOENT
4829 pent = PerlSock_getprotoent();
4831 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4835 if (GIMME != G_ARRAY) {
4836 PUSHs(sv = sv_newmortal());
4838 if (which == OP_GPBYNAME)
4839 sv_setiv(sv, (IV)pent->p_proto);
4841 sv_setpv(sv, pent->p_name);
4847 mPUSHs(newSVpv(pent->p_name, 0));
4848 PUSHs(space_join_names_mortal(pent->p_aliases));
4849 mPUSHi(pent->p_proto);
4854 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4860 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4862 I32 which = PL_op->op_type;
4864 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4865 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4866 struct servent *getservbyport(int, Netdb_name_t);
4867 struct servent *getservent(void);
4869 struct servent *sent;
4871 if (which == OP_GSBYNAME) {
4872 #ifdef HAS_GETSERVBYNAME
4873 const char * const proto = POPpbytex;
4874 const char * const name = POPpbytex;
4875 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4877 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4880 else if (which == OP_GSBYPORT) {
4881 #ifdef HAS_GETSERVBYPORT
4882 const char * const proto = POPpbytex;
4883 unsigned short port = (unsigned short)POPu;
4885 port = PerlSock_htons(port);
4887 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4889 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4893 #ifdef HAS_GETSERVENT
4894 sent = PerlSock_getservent();
4896 DIE(aTHX_ PL_no_sock_func, "getservent");
4900 if (GIMME != G_ARRAY) {
4901 PUSHs(sv = sv_newmortal());
4903 if (which == OP_GSBYNAME) {
4905 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4907 sv_setiv(sv, (IV)(sent->s_port));
4911 sv_setpv(sv, sent->s_name);
4917 mPUSHs(newSVpv(sent->s_name, 0));
4918 PUSHs(space_join_names_mortal(sent->s_aliases));
4920 mPUSHi(PerlSock_ntohs(sent->s_port));
4922 mPUSHi(sent->s_port);
4924 mPUSHs(newSVpv(sent->s_proto, 0));
4929 DIE(aTHX_ PL_no_sock_func, "getservent");
4935 #ifdef HAS_SETHOSTENT
4937 PerlSock_sethostent(TOPi);
4940 DIE(aTHX_ PL_no_sock_func, "sethostent");
4946 #ifdef HAS_SETNETENT
4948 (void)PerlSock_setnetent(TOPi);
4951 DIE(aTHX_ PL_no_sock_func, "setnetent");
4957 #ifdef HAS_SETPROTOENT
4959 (void)PerlSock_setprotoent(TOPi);
4962 DIE(aTHX_ PL_no_sock_func, "setprotoent");
4968 #ifdef HAS_SETSERVENT
4970 (void)PerlSock_setservent(TOPi);
4973 DIE(aTHX_ PL_no_sock_func, "setservent");
4979 #ifdef HAS_ENDHOSTENT
4981 PerlSock_endhostent();
4985 DIE(aTHX_ PL_no_sock_func, "endhostent");
4991 #ifdef HAS_ENDNETENT
4993 PerlSock_endnetent();
4997 DIE(aTHX_ PL_no_sock_func, "endnetent");
5003 #ifdef HAS_ENDPROTOENT
5005 PerlSock_endprotoent();
5009 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5015 #ifdef HAS_ENDSERVENT
5017 PerlSock_endservent();
5021 DIE(aTHX_ PL_no_sock_func, "endservent");
5029 I32 which = PL_op->op_type;
5031 struct passwd *pwent = NULL;
5033 * We currently support only the SysV getsp* shadow password interface.
5034 * The interface is declared in <shadow.h> and often one needs to link
5035 * with -lsecurity or some such.
5036 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5039 * AIX getpwnam() is clever enough to return the encrypted password
5040 * only if the caller (euid?) is root.
5042 * There are at least three other shadow password APIs. Many platforms
5043 * seem to contain more than one interface for accessing the shadow
5044 * password databases, possibly for compatibility reasons.
5045 * The getsp*() is by far he simplest one, the other two interfaces
5046 * are much more complicated, but also very similar to each other.
5051 * struct pr_passwd *getprpw*();
5052 * The password is in
5053 * char getprpw*(...).ufld.fd_encrypt[]
5054 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5059 * struct es_passwd *getespw*();
5060 * The password is in
5061 * char *(getespw*(...).ufld.fd_encrypt)
5062 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5065 * struct userpw *getuserpw();
5066 * The password is in
5067 * char *(getuserpw(...)).spw_upw_passwd
5068 * (but the de facto standard getpwnam() should work okay)
5070 * Mention I_PROT here so that Configure probes for it.
5072 * In HP-UX for getprpw*() the manual page claims that one should include
5073 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5074 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5075 * and pp_sys.c already includes <shadow.h> if there is such.
5077 * Note that <sys/security.h> is already probed for, but currently
5078 * it is only included in special cases.
5080 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5081 * be preferred interface, even though also the getprpw*() interface
5082 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5083 * One also needs to call set_auth_parameters() in main() before
5084 * doing anything else, whether one is using getespw*() or getprpw*().
5086 * Note that accessing the shadow databases can be magnitudes
5087 * slower than accessing the standard databases.
5092 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5093 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5094 * the pw_comment is left uninitialized. */
5095 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5101 const char* const name = POPpbytex;
5102 pwent = getpwnam(name);
5108 pwent = getpwuid(uid);
5112 # ifdef HAS_GETPWENT
5114 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5115 if (pwent) pwent = getpwnam(pwent->pw_name);
5118 DIE(aTHX_ PL_no_func, "getpwent");
5124 if (GIMME != G_ARRAY) {
5125 PUSHs(sv = sv_newmortal());
5127 if (which == OP_GPWNAM)
5128 # if Uid_t_sign <= 0
5129 sv_setiv(sv, (IV)pwent->pw_uid);
5131 sv_setuv(sv, (UV)pwent->pw_uid);
5134 sv_setpv(sv, pwent->pw_name);
5140 mPUSHs(newSVpv(pwent->pw_name, 0));
5144 /* If we have getspnam(), we try to dig up the shadow
5145 * password. If we are underprivileged, the shadow
5146 * interface will set the errno to EACCES or similar,
5147 * and return a null pointer. If this happens, we will
5148 * use the dummy password (usually "*" or "x") from the
5149 * standard password database.
5151 * In theory we could skip the shadow call completely
5152 * if euid != 0 but in practice we cannot know which
5153 * security measures are guarding the shadow databases
5154 * on a random platform.
5156 * Resist the urge to use additional shadow interfaces.
5157 * Divert the urge to writing an extension instead.
5160 /* Some AIX setups falsely(?) detect some getspnam(), which
5161 * has a different API than the Solaris/IRIX one. */
5162 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5164 const int saverrno = errno;
5165 const struct spwd * const spwent = getspnam(pwent->pw_name);
5166 /* Save and restore errno so that
5167 * underprivileged attempts seem
5168 * to have never made the unsccessful
5169 * attempt to retrieve the shadow password. */
5171 if (spwent && spwent->sp_pwdp)
5172 sv_setpv(sv, spwent->sp_pwdp);
5176 if (!SvPOK(sv)) /* Use the standard password, then. */
5177 sv_setpv(sv, pwent->pw_passwd);
5180 # ifndef INCOMPLETE_TAINTS
5181 /* passwd is tainted because user himself can diddle with it.
5182 * admittedly not much and in a very limited way, but nevertheless. */
5186 # if Uid_t_sign <= 0
5187 mPUSHi(pwent->pw_uid);
5189 mPUSHu(pwent->pw_uid);
5192 # if Uid_t_sign <= 0
5193 mPUSHi(pwent->pw_gid);
5195 mPUSHu(pwent->pw_gid);
5197 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5198 * because of the poor interface of the Perl getpw*(),
5199 * not because there's some standard/convention saying so.
5200 * A better interface would have been to return a hash,
5201 * but we are accursed by our history, alas. --jhi. */
5203 mPUSHi(pwent->pw_change);
5206 mPUSHi(pwent->pw_quota);
5209 mPUSHs(newSVpv(pwent->pw_age, 0));
5211 /* I think that you can never get this compiled, but just in case. */
5212 PUSHs(sv_mortalcopy(&PL_sv_no));
5217 /* pw_class and pw_comment are mutually exclusive--.
5218 * see the above note for pw_change, pw_quota, and pw_age. */
5220 mPUSHs(newSVpv(pwent->pw_class, 0));
5223 mPUSHs(newSVpv(pwent->pw_comment, 0));
5225 /* I think that you can never get this compiled, but just in case. */
5226 PUSHs(sv_mortalcopy(&PL_sv_no));
5231 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5233 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5235 # ifndef INCOMPLETE_TAINTS
5236 /* pw_gecos is tainted because user himself can diddle with it. */
5240 mPUSHs(newSVpv(pwent->pw_dir, 0));
5242 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5243 # ifndef INCOMPLETE_TAINTS
5244 /* pw_shell is tainted because user himself can diddle with it. */
5249 mPUSHi(pwent->pw_expire);
5254 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5260 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5265 DIE(aTHX_ PL_no_func, "setpwent");
5271 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5276 DIE(aTHX_ PL_no_func, "endpwent");
5284 const I32 which = PL_op->op_type;
5285 const struct group *grent;
5287 if (which == OP_GGRNAM) {
5288 const char* const name = POPpbytex;
5289 grent = (const struct group *)getgrnam(name);
5291 else if (which == OP_GGRGID) {
5292 const Gid_t gid = POPi;
5293 grent = (const struct group *)getgrgid(gid);
5297 grent = (struct group *)getgrent();
5299 DIE(aTHX_ PL_no_func, "getgrent");
5303 if (GIMME != G_ARRAY) {
5304 SV * const sv = sv_newmortal();
5308 if (which == OP_GGRNAM)
5309 sv_setiv(sv, (IV)grent->gr_gid);
5311 sv_setpv(sv, grent->gr_name);
5317 mPUSHs(newSVpv(grent->gr_name, 0));
5320 mPUSHs(newSVpv(grent->gr_passwd, 0));
5322 PUSHs(sv_mortalcopy(&PL_sv_no));
5325 mPUSHi(grent->gr_gid);
5327 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5328 /* In UNICOS/mk (_CRAYMPP) the multithreading
5329 * versions (getgrnam_r, getgrgid_r)
5330 * seem to return an illegal pointer
5331 * as the group members list, gr_mem.
5332 * getgrent() doesn't even have a _r version
5333 * but the gr_mem is poisonous anyway.
5334 * So yes, you cannot get the list of group
5335 * members if building multithreaded in UNICOS/mk. */
5336 PUSHs(space_join_names_mortal(grent->gr_mem));
5342 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5348 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5353 DIE(aTHX_ PL_no_func, "setgrent");
5359 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5364 DIE(aTHX_ PL_no_func, "endgrent");
5374 if (!(tmps = PerlProc_getlogin()))
5376 PUSHp(tmps, strlen(tmps));
5379 DIE(aTHX_ PL_no_func, "getlogin");
5383 /* Miscellaneous. */
5388 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5389 register I32 items = SP - MARK;
5390 unsigned long a[20];
5395 while (++MARK <= SP) {
5396 if (SvTAINTED(*MARK)) {
5402 TAINT_PROPER("syscall");
5405 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5406 * or where sizeof(long) != sizeof(char*). But such machines will
5407 * not likely have syscall implemented either, so who cares?
5409 while (++MARK <= SP) {
5410 if (SvNIOK(*MARK) || !i)
5411 a[i++] = SvIV(*MARK);
5412 else if (*MARK == &PL_sv_undef)
5415 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5421 DIE(aTHX_ "Too many args to syscall");
5423 DIE(aTHX_ "Too few args to syscall");
5425 retval = syscall(a[0]);
5428 retval = syscall(a[0],a[1]);
5431 retval = syscall(a[0],a[1],a[2]);
5434 retval = syscall(a[0],a[1],a[2],a[3]);
5437 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5440 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5443 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5446 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5450 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5453 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5456 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5460 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5464 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5468 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5469 a[10],a[11],a[12],a[13]);
5471 #endif /* atarist */
5477 DIE(aTHX_ PL_no_func, "syscall");
5481 #ifdef FCNTL_EMULATE_FLOCK
5483 /* XXX Emulate flock() with fcntl().
5484 What's really needed is a good file locking module.
5488 fcntl_emulate_flock(int fd, int operation)
5492 switch (operation & ~LOCK_NB) {
5494 flock.l_type = F_RDLCK;
5497 flock.l_type = F_WRLCK;
5500 flock.l_type = F_UNLCK;
5506 flock.l_whence = SEEK_SET;
5507 flock.l_start = flock.l_len = (Off_t)0;
5509 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5512 #endif /* FCNTL_EMULATE_FLOCK */
5514 #ifdef LOCKF_EMULATE_FLOCK
5516 /* XXX Emulate flock() with lockf(). This is just to increase
5517 portability of scripts. The calls are not completely
5518 interchangeable. What's really needed is a good file
5522 /* The lockf() constants might have been defined in <unistd.h>.
5523 Unfortunately, <unistd.h> causes troubles on some mixed
5524 (BSD/POSIX) systems, such as SunOS 4.1.3.
5526 Further, the lockf() constants aren't POSIX, so they might not be
5527 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5528 just stick in the SVID values and be done with it. Sigh.
5532 # define F_ULOCK 0 /* Unlock a previously locked region */
5535 # define F_LOCK 1 /* Lock a region for exclusive use */
5538 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5541 # define F_TEST 3 /* Test a region for other processes locks */
5545 lockf_emulate_flock(int fd, int operation)
5548 const int save_errno = errno;
5551 /* flock locks entire file so for lockf we need to do the same */
5552 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5553 if (pos > 0) /* is seekable and needs to be repositioned */
5554 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5555 pos = -1; /* seek failed, so don't seek back afterwards */
5558 switch (operation) {
5560 /* LOCK_SH - get a shared lock */
5562 /* LOCK_EX - get an exclusive lock */
5564 i = lockf (fd, F_LOCK, 0);
5567 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5568 case LOCK_SH|LOCK_NB:
5569 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5570 case LOCK_EX|LOCK_NB:
5571 i = lockf (fd, F_TLOCK, 0);
5573 if ((errno == EAGAIN) || (errno == EACCES))
5574 errno = EWOULDBLOCK;
5577 /* LOCK_UN - unlock (non-blocking is a no-op) */
5579 case LOCK_UN|LOCK_NB:
5580 i = lockf (fd, F_ULOCK, 0);
5583 /* Default - can't decipher operation */
5590 if (pos > 0) /* need to restore position of the handle */
5591 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5596 #endif /* LOCKF_EMULATE_FLOCK */
5600 * c-indentation-style: bsd
5602 * indent-tabs-mode: t
5605 * ex: set ts=8 sts=4 sw=4 noet: