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);
765 const int mode = mode_from_discipline(discp);
766 const char *const d = (discp ? SvPV_nolen_const(discp) : NULL);
767 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
768 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
769 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
790 const I32 markoff = MARK - PL_stack_base;
791 const char *methname;
792 int how = PERL_MAGIC_tied;
796 switch(SvTYPE(varsv)) {
798 methname = "TIEHASH";
799 HvEITER_set((HV *)varsv, 0);
802 methname = "TIEARRAY";
805 #ifdef GV_UNIQUE_CHECK
806 if (GvUNIQUE((GV*)varsv)) {
807 Perl_croak(aTHX_ "Attempt to tie unique GV");
810 methname = "TIEHANDLE";
811 how = PERL_MAGIC_tiedscalar;
812 /* For tied filehandles, we apply tiedscalar magic to the IO
813 slot of the GP rather than the GV itself. AMS 20010812 */
815 GvIOp(varsv) = newIO();
816 varsv = (SV *)GvIOp(varsv);
819 methname = "TIESCALAR";
820 how = PERL_MAGIC_tiedscalar;
824 if (sv_isobject(*MARK)) {
826 PUSHSTACKi(PERLSI_MAGIC);
828 EXTEND(SP,(I32)items);
832 call_method(methname, G_SCALAR);
835 /* Not clear why we don't call call_method here too.
836 * perhaps to get different error message ?
838 stash = gv_stashsv(*MARK, 0);
839 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
840 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
841 methname, SVfARG(*MARK));
844 PUSHSTACKi(PERLSI_MAGIC);
846 EXTEND(SP,(I32)items);
850 call_sv((SV*)GvCV(gv), G_SCALAR);
856 if (sv_isobject(sv)) {
857 sv_unmagic(varsv, how);
858 /* Croak if a self-tie on an aggregate is attempted. */
859 if (varsv == SvRV(sv) &&
860 (SvTYPE(varsv) == SVt_PVAV ||
861 SvTYPE(varsv) == SVt_PVHV))
863 "Self-ties of arrays and hashes are not supported");
864 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
867 SP = PL_stack_base + markoff;
877 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
878 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
880 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
883 if ((mg = SvTIED_mg(sv, how))) {
884 SV * const obj = SvRV(SvTIED_obj(sv, mg));
886 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
888 if (gv && isGV(gv) && (cv = GvCV(gv))) {
890 XPUSHs(SvTIED_obj((SV*)gv, mg));
891 mXPUSHi(SvREFCNT(obj) - 1);
894 call_sv((SV *)cv, G_VOID);
898 else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
899 Perl_warner(aTHX_ packWARN(WARN_UNTIE),
900 "untie attempted while %"UVuf" inner references still exist",
901 (UV)SvREFCNT(obj) - 1 ) ;
905 sv_unmagic(sv, how) ;
915 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
916 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
918 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
921 if ((mg = SvTIED_mg(sv, how))) {
922 SV *osv = SvTIED_obj(sv, mg);
923 if (osv == mg->mg_obj)
924 osv = sv_mortalcopy(osv);
938 HV * const hv = (HV*)POPs;
939 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
940 stash = gv_stashsv(sv, 0);
941 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
943 require_pv("AnyDBM_File.pm");
945 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
946 DIE(aTHX_ "No dbm on this machine");
956 mPUSHu(O_RDWR|O_CREAT);
961 call_sv((SV*)GvCV(gv), G_SCALAR);
964 if (!sv_isobject(TOPs)) {
972 call_sv((SV*)GvCV(gv), G_SCALAR);
976 if (sv_isobject(TOPs)) {
977 sv_unmagic((SV *) hv, PERL_MAGIC_tied);
978 sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, NULL, 0);
995 struct timeval timebuf;
996 struct timeval *tbuf = &timebuf;
999 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1004 # if BYTEORDER & 0xf0000
1005 # define ORDERBYTE (0x88888888 - BYTEORDER)
1007 # define ORDERBYTE (0x4444 - BYTEORDER)
1013 for (i = 1; i <= 3; i++) {
1014 SV * const sv = SP[i];
1017 if (SvREADONLY(sv)) {
1019 sv_force_normal_flags(sv, 0);
1020 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1021 DIE(aTHX_ PL_no_modify);
1024 if (ckWARN(WARN_MISC))
1025 Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1026 SvPV_force_nolen(sv); /* force string conversion */
1033 /* little endians can use vecs directly */
1034 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1041 masksize = NFDBITS / NBBY;
1043 masksize = sizeof(long); /* documented int, everyone seems to use long */
1045 Zero(&fd_sets[0], 4, char*);
1048 # if SELECT_MIN_BITS == 1
1049 growsize = sizeof(fd_set);
1051 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1052 # undef SELECT_MIN_BITS
1053 # define SELECT_MIN_BITS __FD_SETSIZE
1055 /* If SELECT_MIN_BITS is greater than one we most probably will want
1056 * to align the sizes with SELECT_MIN_BITS/8 because for example
1057 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1058 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1059 * on (sets/tests/clears bits) is 32 bits. */
1060 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1068 timebuf.tv_sec = (long)value;
1069 value -= (NV)timebuf.tv_sec;
1070 timebuf.tv_usec = (long)(value * 1000000.0);
1075 for (i = 1; i <= 3; i++) {
1077 if (!SvOK(sv) || SvCUR(sv) == 0) {
1084 Sv_Grow(sv, growsize);
1088 while (++j <= growsize) {
1092 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1094 Newx(fd_sets[i], growsize, char);
1095 for (offset = 0; offset < growsize; offset += masksize) {
1096 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1097 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1100 fd_sets[i] = SvPVX(sv);
1104 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1105 /* Can't make just the (void*) conditional because that would be
1106 * cpp #if within cpp macro, and not all compilers like that. */
1107 nfound = PerlSock_select(
1109 (Select_fd_set_t) fd_sets[1],
1110 (Select_fd_set_t) fd_sets[2],
1111 (Select_fd_set_t) fd_sets[3],
1112 (void*) tbuf); /* Workaround for compiler bug. */
1114 nfound = PerlSock_select(
1116 (Select_fd_set_t) fd_sets[1],
1117 (Select_fd_set_t) fd_sets[2],
1118 (Select_fd_set_t) fd_sets[3],
1121 for (i = 1; i <= 3; i++) {
1124 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1126 for (offset = 0; offset < growsize; offset += masksize) {
1127 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1128 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1130 Safefree(fd_sets[i]);
1137 if (GIMME == G_ARRAY && tbuf) {
1138 value = (NV)(timebuf.tv_sec) +
1139 (NV)(timebuf.tv_usec) / 1000000.0;
1144 DIE(aTHX_ "select not implemented");
1149 Perl_setdefout(pTHX_ GV *gv)
1152 SvREFCNT_inc_simple_void(gv);
1154 SvREFCNT_dec(PL_defoutgv);
1162 GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : NULL;
1163 GV * egv = GvEGV(PL_defoutgv);
1169 XPUSHs(&PL_sv_undef);
1171 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1172 if (gvp && *gvp == egv) {
1173 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1177 mXPUSHs(newRV((SV*)egv));
1182 if (!GvIO(newdefout))
1183 gv_IOadd(newdefout);
1184 setdefout(newdefout);
1194 GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs;
1196 if (gv && (io = GvIO(gv))) {
1197 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1199 const I32 gimme = GIMME_V;
1201 XPUSHs(SvTIED_obj((SV*)io, mg));
1204 call_method("GETC", gimme);
1207 if (gimme == G_SCALAR)
1208 SvSetMagicSV_nosteal(TARG, TOPs);
1212 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1213 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1214 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1215 report_evil_fh(gv, io, PL_op->op_type);
1216 SETERRNO(EBADF,RMS_IFI);
1220 sv_setpvn(TARG, " ", 1);
1221 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1222 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1223 /* Find out how many bytes the char needs */
1224 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1227 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1228 SvCUR_set(TARG,1+len);
1237 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1240 register PERL_CONTEXT *cx;
1241 const I32 gimme = GIMME_V;
1246 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1247 PUSHFORMAT(cx, retop);
1249 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1251 setdefout(gv); /* locally select filehandle so $% et al work */
1283 goto not_a_format_reference;
1288 tmpsv = sv_newmortal();
1289 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1290 name = SvPV_nolen_const(tmpsv);
1292 DIE(aTHX_ "Undefined format \"%s\" called", name);
1294 not_a_format_reference:
1295 DIE(aTHX_ "Not a format reference");
1298 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1300 IoFLAGS(io) &= ~IOf_DIDTOP;
1301 return doform(cv,gv,PL_op->op_next);
1307 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1308 register IO * const io = GvIOp(gv);
1313 register PERL_CONTEXT *cx;
1315 if (!io || !(ofp = IoOFP(io)))
1318 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1319 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1321 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1322 PL_formtarget != PL_toptarget)
1326 if (!IoTOP_GV(io)) {
1329 if (!IoTOP_NAME(io)) {
1331 if (!IoFMT_NAME(io))
1332 IoFMT_NAME(io) = savepv(GvNAME(gv));
1333 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1334 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1335 if ((topgv && GvFORM(topgv)) ||
1336 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1337 IoTOP_NAME(io) = savesvpv(topname);
1339 IoTOP_NAME(io) = savepvs("top");
1341 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1342 if (!topgv || !GvFORM(topgv)) {
1343 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1346 IoTOP_GV(io) = topgv;
1348 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1349 I32 lines = IoLINES_LEFT(io);
1350 const char *s = SvPVX_const(PL_formtarget);
1351 if (lines <= 0) /* Yow, header didn't even fit!!! */
1353 while (lines-- > 0) {
1354 s = strchr(s, '\n');
1360 const STRLEN save = SvCUR(PL_formtarget);
1361 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1362 do_print(PL_formtarget, ofp);
1363 SvCUR_set(PL_formtarget, save);
1364 sv_chop(PL_formtarget, s);
1365 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1368 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1369 do_print(PL_formfeed, ofp);
1370 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1372 PL_formtarget = PL_toptarget;
1373 IoFLAGS(io) |= IOf_DIDTOP;
1376 DIE(aTHX_ "bad top format reference");
1379 SV * const sv = sv_newmortal();
1381 gv_efullname4(sv, fgv, NULL, FALSE);
1382 name = SvPV_nolen_const(sv);
1384 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1386 DIE(aTHX_ "Undefined top format called");
1388 if (cv && CvCLONE(cv))
1389 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1390 return doform(cv, gv, PL_op);
1394 POPBLOCK(cx,PL_curpm);
1400 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1402 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1403 else if (ckWARN(WARN_CLOSED))
1404 report_evil_fh(gv, io, PL_op->op_type);
1409 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1410 if (ckWARN(WARN_IO))
1411 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1413 if (!do_print(PL_formtarget, fp))
1416 FmLINES(PL_formtarget) = 0;
1417 SvCUR_set(PL_formtarget, 0);
1418 *SvEND(PL_formtarget) = '\0';
1419 if (IoFLAGS(io) & IOf_FLUSH)
1420 (void)PerlIO_flush(fp);
1425 PL_formtarget = PL_bodytarget;
1427 PERL_UNUSED_VAR(newsp);
1428 PERL_UNUSED_VAR(gimme);
1429 return cx->blk_sub.retop;
1434 dVAR; dSP; dMARK; dORIGMARK;
1439 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
1441 if (gv && (io = GvIO(gv))) {
1442 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1444 if (MARK == ORIGMARK) {
1447 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1451 *MARK = SvTIED_obj((SV*)io, mg);
1454 call_method("PRINTF", G_SCALAR);
1457 MARK = ORIGMARK + 1;
1465 if (!(io = GvIO(gv))) {
1466 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1467 report_evil_fh(gv, io, PL_op->op_type);
1468 SETERRNO(EBADF,RMS_IFI);
1471 else if (!(fp = IoOFP(io))) {
1472 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1474 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1475 else if (ckWARN(WARN_CLOSED))
1476 report_evil_fh(gv, io, PL_op->op_type);
1478 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1482 if (SvTAINTED(MARK[1]))
1483 TAINT_PROPER("printf");
1484 do_sprintf(sv, SP - MARK, MARK + 1);
1485 if (!do_print(sv, fp))
1488 if (IoFLAGS(io) & IOf_FLUSH)
1489 if (PerlIO_flush(fp) == EOF)
1500 PUSHs(&PL_sv_undef);
1508 const int perm = (MAXARG > 3) ? POPi : 0666;
1509 const int mode = POPi;
1510 SV * const sv = POPs;
1511 GV * const gv = (GV *)POPs;
1514 /* Need TIEHANDLE method ? */
1515 const char * const tmps = SvPV_const(sv, len);
1516 /* FIXME? do_open should do const */
1517 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1518 IoLINES(GvIOp(gv)) = 0;
1522 PUSHs(&PL_sv_undef);
1529 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1535 Sock_size_t bufsize;
1543 bool charstart = FALSE;
1544 STRLEN charskip = 0;
1547 GV * const gv = (GV*)*++MARK;
1548 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1549 && gv && (io = GvIO(gv)) )
1551 const MAGIC * mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1555 *MARK = SvTIED_obj((SV*)io, mg);
1557 call_method("READ", G_SCALAR);
1571 sv_setpvn(bufsv, "", 0);
1572 length = SvIVx(*++MARK);
1575 offset = SvIVx(*++MARK);
1579 if (!io || !IoIFP(io)) {
1580 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1581 report_evil_fh(gv, io, PL_op->op_type);
1582 SETERRNO(EBADF,RMS_IFI);
1585 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1586 buffer = SvPVutf8_force(bufsv, blen);
1587 /* UTF-8 may not have been set if they are all low bytes */
1592 buffer = SvPV_force(bufsv, blen);
1593 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1596 DIE(aTHX_ "Negative length");
1604 if (PL_op->op_type == OP_RECV) {
1605 char namebuf[MAXPATHLEN];
1606 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1607 bufsize = sizeof (struct sockaddr_in);
1609 bufsize = sizeof namebuf;
1611 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1615 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1616 /* 'offset' means 'flags' here */
1617 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1618 (struct sockaddr *)namebuf, &bufsize);
1622 /* Bogus return without padding */
1623 bufsize = sizeof (struct sockaddr_in);
1625 SvCUR_set(bufsv, count);
1626 *SvEND(bufsv) = '\0';
1627 (void)SvPOK_only(bufsv);
1631 /* This should not be marked tainted if the fp is marked clean */
1632 if (!(IoFLAGS(io) & IOf_UNTAINT))
1633 SvTAINTED_on(bufsv);
1635 sv_setpvn(TARG, namebuf, bufsize);
1640 if (PL_op->op_type == OP_RECV)
1641 DIE(aTHX_ PL_no_sock_func, "recv");
1643 if (DO_UTF8(bufsv)) {
1644 /* offset adjust in characters not bytes */
1645 blen = sv_len_utf8(bufsv);
1648 if (-offset > (int)blen)
1649 DIE(aTHX_ "Offset outside string");
1652 if (DO_UTF8(bufsv)) {
1653 /* convert offset-as-chars to offset-as-bytes */
1654 if (offset >= (int)blen)
1655 offset += SvCUR(bufsv) - blen;
1657 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1660 bufsize = SvCUR(bufsv);
1661 /* Allocating length + offset + 1 isn't perfect in the case of reading
1662 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1664 (should be 2 * length + offset + 1, or possibly something longer if
1665 PL_encoding is true) */
1666 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1667 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1668 Zero(buffer+bufsize, offset-bufsize, char);
1670 buffer = buffer + offset;
1672 read_target = bufsv;
1674 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1675 concatenate it to the current buffer. */
1677 /* Truncate the existing buffer to the start of where we will be
1679 SvCUR_set(bufsv, offset);
1681 read_target = sv_newmortal();
1682 SvUPGRADE(read_target, SVt_PV);
1683 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1686 if (PL_op->op_type == OP_SYSREAD) {
1687 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1688 if (IoTYPE(io) == IoTYPE_SOCKET) {
1689 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1695 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1700 #ifdef HAS_SOCKET__bad_code_maybe
1701 if (IoTYPE(io) == IoTYPE_SOCKET) {
1702 char namebuf[MAXPATHLEN];
1703 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1704 bufsize = sizeof (struct sockaddr_in);
1706 bufsize = sizeof namebuf;
1708 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1709 (struct sockaddr *)namebuf, &bufsize);
1714 count = PerlIO_read(IoIFP(io), buffer, length);
1715 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1716 if (count == 0 && PerlIO_error(IoIFP(io)))
1720 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1721 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1724 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1725 *SvEND(read_target) = '\0';
1726 (void)SvPOK_only(read_target);
1727 if (fp_utf8 && !IN_BYTES) {
1728 /* Look at utf8 we got back and count the characters */
1729 const char *bend = buffer + count;
1730 while (buffer < bend) {
1732 skip = UTF8SKIP(buffer);
1735 if (buffer - charskip + skip > bend) {
1736 /* partial character - try for rest of it */
1737 length = skip - (bend-buffer);
1738 offset = bend - SvPVX_const(bufsv);
1750 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1751 provided amount read (count) was what was requested (length)
1753 if (got < wanted && count == length) {
1754 length = wanted - got;
1755 offset = bend - SvPVX_const(bufsv);
1758 /* return value is character count */
1762 else if (buffer_utf8) {
1763 /* Let svcatsv upgrade the bytes we read in to utf8.
1764 The buffer is a mortal so will be freed soon. */
1765 sv_catsv_nomg(bufsv, read_target);
1768 /* This should not be marked tainted if the fp is marked clean */
1769 if (!(IoFLAGS(io) & IOf_UNTAINT))
1770 SvTAINTED_on(bufsv);
1782 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1788 STRLEN orig_blen_bytes;
1789 const int op_type = PL_op->op_type;
1793 GV *const gv = (GV*)*++MARK;
1794 if (PL_op->op_type == OP_SYSWRITE
1795 && gv && (io = GvIO(gv))) {
1796 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1800 if (MARK == SP - 1) {
1802 sv = sv_2mortal(newSViv(sv_len(*SP)));
1808 *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg);
1810 call_method("WRITE", G_SCALAR);
1826 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1828 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1829 if (io && IoIFP(io))
1830 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1832 report_evil_fh(gv, io, PL_op->op_type);
1834 SETERRNO(EBADF,RMS_IFI);
1838 /* Do this first to trigger any overloading. */
1839 buffer = SvPV_const(bufsv, blen);
1840 orig_blen_bytes = blen;
1841 doing_utf8 = DO_UTF8(bufsv);
1843 if (PerlIO_isutf8(IoIFP(io))) {
1844 if (!SvUTF8(bufsv)) {
1845 /* We don't modify the original scalar. */
1846 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1847 buffer = (char *) tmpbuf;
1851 else if (doing_utf8) {
1852 STRLEN tmplen = blen;
1853 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1856 buffer = (char *) tmpbuf;
1860 assert((char *)result == buffer);
1861 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1865 if (op_type == OP_SYSWRITE) {
1866 Size_t length = 0; /* This length is in characters. */
1872 /* The SV is bytes, and we've had to upgrade it. */
1873 blen_chars = orig_blen_bytes;
1875 /* The SV really is UTF-8. */
1876 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1877 /* Don't call sv_len_utf8 again because it will call magic
1878 or overloading a second time, and we might get back a
1879 different result. */
1880 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1882 /* It's safe, and it may well be cached. */
1883 blen_chars = sv_len_utf8(bufsv);
1891 length = blen_chars;
1893 #if Size_t_size > IVSIZE
1894 length = (Size_t)SvNVx(*++MARK);
1896 length = (Size_t)SvIVx(*++MARK);
1898 if ((SSize_t)length < 0) {
1900 DIE(aTHX_ "Negative length");
1905 offset = SvIVx(*++MARK);
1907 if (-offset > (IV)blen_chars) {
1909 DIE(aTHX_ "Offset outside string");
1911 offset += blen_chars;
1912 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1914 DIE(aTHX_ "Offset outside string");
1918 if (length > blen_chars - offset)
1919 length = blen_chars - offset;
1921 /* Here we convert length from characters to bytes. */
1922 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1923 /* Either we had to convert the SV, or the SV is magical, or
1924 the SV has overloading, in which case we can't or mustn't
1925 or mustn't call it again. */
1927 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1928 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1930 /* It's a real UTF-8 SV, and it's not going to change under
1931 us. Take advantage of any cache. */
1933 I32 len_I32 = length;
1935 /* Convert the start and end character positions to bytes.
1936 Remember that the second argument to sv_pos_u2b is relative
1938 sv_pos_u2b(bufsv, &start, &len_I32);
1945 buffer = buffer+offset;
1947 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1948 if (IoTYPE(io) == IoTYPE_SOCKET) {
1949 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1955 /* See the note at doio.c:do_print about filesize limits. --jhi */
1956 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1962 const int flags = SvIVx(*++MARK);
1965 char * const sockbuf = SvPVx(*++MARK, mlen);
1966 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1967 flags, (struct sockaddr *)sockbuf, mlen);
1971 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1976 DIE(aTHX_ PL_no_sock_func, "send");
1983 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
1986 #if Size_t_size > IVSIZE
2005 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
2007 gv = PL_last_in_gv = GvEGV(PL_argvgv);
2009 if (io && !IoIFP(io)) {
2010 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2012 IoFLAGS(io) &= ~IOf_START;
2013 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2015 sv_setpvn(GvSV(gv), "-", 1);
2018 GvSV(gv) = newSVpvn("-", 1);
2020 SvSETMAGIC(GvSV(gv));
2022 else if (!nextargv(gv))
2027 gv = PL_last_in_gv; /* eof */
2030 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
2033 IO * const io = GvIO(gv);
2035 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
2037 XPUSHs(SvTIED_obj((SV*)io, mg));
2040 call_method("EOF", G_SCALAR);
2047 PUSHs(boolSV(!gv || do_eof(gv)));
2058 PL_last_in_gv = (GV*)POPs;
2061 if (gv && (io = GvIO(gv))) {
2062 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2065 XPUSHs(SvTIED_obj((SV*)io, mg));
2068 call_method("TELL", G_SCALAR);
2075 #if LSEEKSIZE > IVSIZE
2076 PUSHn( do_tell(gv) );
2078 PUSHi( do_tell(gv) );
2086 const int whence = POPi;
2087 #if LSEEKSIZE > IVSIZE
2088 const Off_t offset = (Off_t)SvNVx(POPs);
2090 const Off_t offset = (Off_t)SvIVx(POPs);
2093 GV * const gv = PL_last_in_gv = (GV*)POPs;
2096 if (gv && (io = GvIO(gv))) {
2097 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2100 XPUSHs(SvTIED_obj((SV*)io, mg));
2101 #if LSEEKSIZE > IVSIZE
2102 mXPUSHn((NV) offset);
2109 call_method("SEEK", G_SCALAR);
2116 if (PL_op->op_type == OP_SEEK)
2117 PUSHs(boolSV(do_seek(gv, offset, whence)));
2119 const Off_t sought = do_sysseek(gv, offset, whence);
2121 PUSHs(&PL_sv_undef);
2123 SV* const sv = sought ?
2124 #if LSEEKSIZE > IVSIZE
2129 : newSVpvn(zero_but_true, ZBTLEN);
2140 /* There seems to be no consensus on the length type of truncate()
2141 * and ftruncate(), both off_t and size_t have supporters. In
2142 * general one would think that when using large files, off_t is
2143 * at least as wide as size_t, so using an off_t should be okay. */
2144 /* XXX Configure probe for the length type of *truncate() needed XXX */
2147 #if Off_t_size > IVSIZE
2152 /* Checking for length < 0 is problematic as the type might or
2153 * might not be signed: if it is not, clever compilers will moan. */
2154 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2161 if (PL_op->op_flags & OPf_SPECIAL) {
2162 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2171 TAINT_PROPER("truncate");
2172 if (!(fp = IoIFP(io))) {
2178 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2180 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2187 SV * const sv = POPs;
2190 if (SvTYPE(sv) == SVt_PVGV) {
2191 tmpgv = (GV*)sv; /* *main::FRED for example */
2192 goto do_ftruncate_gv;
2194 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2195 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
2196 goto do_ftruncate_gv;
2198 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2199 io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
2200 goto do_ftruncate_io;
2203 name = SvPV_nolen_const(sv);
2204 TAINT_PROPER("truncate");
2206 if (truncate(name, len) < 0)
2210 const int tmpfd = PerlLIO_open(name, O_RDWR);
2215 if (my_chsize(tmpfd, len) < 0)
2217 PerlLIO_close(tmpfd);
2226 SETERRNO(EBADF,RMS_IFI);
2234 SV * const argsv = POPs;
2235 const unsigned int func = POPu;
2236 const int optype = PL_op->op_type;
2237 GV * const gv = (GV*)POPs;
2238 IO * const io = gv ? GvIOn(gv) : NULL;
2242 if (!io || !argsv || !IoIFP(io)) {
2243 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2244 report_evil_fh(gv, io, PL_op->op_type);
2245 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2249 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2252 s = SvPV_force(argsv, len);
2253 need = IOCPARM_LEN(func);
2255 s = Sv_Grow(argsv, need + 1);
2256 SvCUR_set(argsv, need);
2259 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2262 retval = SvIV(argsv);
2263 s = INT2PTR(char*,retval); /* ouch */
2266 TAINT_PROPER(PL_op_desc[optype]);
2268 if (optype == OP_IOCTL)
2270 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2272 DIE(aTHX_ "ioctl is not implemented");
2276 DIE(aTHX_ "fcntl is not implemented");
2278 #if defined(OS2) && defined(__EMX__)
2279 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2281 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2285 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2287 if (s[SvCUR(argsv)] != 17)
2288 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2290 s[SvCUR(argsv)] = 0; /* put our null back */
2291 SvSETMAGIC(argsv); /* Assume it has changed */
2300 PUSHp(zero_but_true, ZBTLEN);
2313 const int argtype = POPi;
2314 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
2316 if (gv && (io = GvIO(gv)))
2322 /* XXX Looks to me like io is always NULL at this point */
2324 (void)PerlIO_flush(fp);
2325 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2328 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2329 report_evil_fh(gv, io, PL_op->op_type);
2331 SETERRNO(EBADF,RMS_IFI);
2336 DIE(aTHX_ PL_no_func, "flock()");
2346 const int protocol = POPi;
2347 const int type = POPi;
2348 const int domain = POPi;
2349 GV * const gv = (GV*)POPs;
2350 register IO * const io = gv ? GvIOn(gv) : NULL;
2354 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2355 report_evil_fh(gv, io, PL_op->op_type);
2356 if (io && IoIFP(io))
2357 do_close(gv, FALSE);
2358 SETERRNO(EBADF,LIB_INVARG);
2363 do_close(gv, FALSE);
2365 TAINT_PROPER("socket");
2366 fd = PerlSock_socket(domain, type, protocol);
2369 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2370 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2371 IoTYPE(io) = IoTYPE_SOCKET;
2372 if (!IoIFP(io) || !IoOFP(io)) {
2373 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2374 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2375 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2378 #if defined(HAS_FCNTL) && defined(F_SETFD)
2379 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2383 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2388 DIE(aTHX_ PL_no_sock_func, "socket");
2394 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2396 const int protocol = POPi;
2397 const int type = POPi;
2398 const int domain = POPi;
2399 GV * const gv2 = (GV*)POPs;
2400 GV * const gv1 = (GV*)POPs;
2401 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2402 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2405 if (!gv1 || !gv2 || !io1 || !io2) {
2406 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2408 report_evil_fh(gv1, io1, PL_op->op_type);
2410 report_evil_fh(gv1, io2, PL_op->op_type);
2412 if (io1 && IoIFP(io1))
2413 do_close(gv1, FALSE);
2414 if (io2 && IoIFP(io2))
2415 do_close(gv2, FALSE);
2420 do_close(gv1, FALSE);
2422 do_close(gv2, FALSE);
2424 TAINT_PROPER("socketpair");
2425 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2427 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2428 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2429 IoTYPE(io1) = IoTYPE_SOCKET;
2430 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2431 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2432 IoTYPE(io2) = IoTYPE_SOCKET;
2433 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2434 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2435 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2436 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2437 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2438 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2439 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2442 #if defined(HAS_FCNTL) && defined(F_SETFD)
2443 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2444 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2449 DIE(aTHX_ PL_no_sock_func, "socketpair");
2457 SV * const addrsv = POPs;
2458 /* OK, so on what platform does bind modify addr? */
2460 GV * const gv = (GV*)POPs;
2461 register IO * const io = GvIOn(gv);
2464 if (!io || !IoIFP(io))
2467 addr = SvPV_const(addrsv, len);
2468 TAINT_PROPER("bind");
2469 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2475 if (ckWARN(WARN_CLOSED))
2476 report_evil_fh(gv, io, PL_op->op_type);
2477 SETERRNO(EBADF,SS_IVCHAN);
2480 DIE(aTHX_ PL_no_sock_func, "bind");
2488 SV * const addrsv = POPs;
2489 GV * const gv = (GV*)POPs;
2490 register IO * const io = GvIOn(gv);
2494 if (!io || !IoIFP(io))
2497 addr = SvPV_const(addrsv, len);
2498 TAINT_PROPER("connect");
2499 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2505 if (ckWARN(WARN_CLOSED))
2506 report_evil_fh(gv, io, PL_op->op_type);
2507 SETERRNO(EBADF,SS_IVCHAN);
2510 DIE(aTHX_ PL_no_sock_func, "connect");
2518 const int backlog = POPi;
2519 GV * const gv = (GV*)POPs;
2520 register IO * const io = gv ? GvIOn(gv) : NULL;
2522 if (!gv || !io || !IoIFP(io))
2525 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2531 if (ckWARN(WARN_CLOSED))
2532 report_evil_fh(gv, io, PL_op->op_type);
2533 SETERRNO(EBADF,SS_IVCHAN);
2536 DIE(aTHX_ PL_no_sock_func, "listen");
2546 char namebuf[MAXPATHLEN];
2547 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2548 Sock_size_t len = sizeof (struct sockaddr_in);
2550 Sock_size_t len = sizeof namebuf;
2552 GV * const ggv = (GV*)POPs;
2553 GV * const ngv = (GV*)POPs;
2562 if (!gstio || !IoIFP(gstio))
2566 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2569 /* Some platforms indicate zero length when an AF_UNIX client is
2570 * not bound. Simulate a non-zero-length sockaddr structure in
2572 namebuf[0] = 0; /* sun_len */
2573 namebuf[1] = AF_UNIX; /* sun_family */
2581 do_close(ngv, FALSE);
2582 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2583 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2584 IoTYPE(nstio) = IoTYPE_SOCKET;
2585 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2586 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2587 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2588 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2591 #if defined(HAS_FCNTL) && defined(F_SETFD)
2592 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2596 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2597 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2599 #ifdef __SCO_VERSION__
2600 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2603 PUSHp(namebuf, len);
2607 if (ckWARN(WARN_CLOSED))
2608 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2609 SETERRNO(EBADF,SS_IVCHAN);
2615 DIE(aTHX_ PL_no_sock_func, "accept");
2623 const int how = POPi;
2624 GV * const gv = (GV*)POPs;
2625 register IO * const io = GvIOn(gv);
2627 if (!io || !IoIFP(io))
2630 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2634 if (ckWARN(WARN_CLOSED))
2635 report_evil_fh(gv, io, PL_op->op_type);
2636 SETERRNO(EBADF,SS_IVCHAN);
2639 DIE(aTHX_ PL_no_sock_func, "shutdown");
2647 const int optype = PL_op->op_type;
2648 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2649 const unsigned int optname = (unsigned int) POPi;
2650 const unsigned int lvl = (unsigned int) POPi;
2651 GV * const gv = (GV*)POPs;
2652 register IO * const io = GvIOn(gv);
2656 if (!io || !IoIFP(io))
2659 fd = PerlIO_fileno(IoIFP(io));
2663 (void)SvPOK_only(sv);
2667 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2674 #if defined(__SYMBIAN32__)
2675 # define SETSOCKOPT_OPTION_VALUE_T void *
2677 # define SETSOCKOPT_OPTION_VALUE_T const char *
2679 /* XXX TODO: We need to have a proper type (a Configure probe,
2680 * etc.) for what the C headers think of the third argument of
2681 * setsockopt(), the option_value read-only buffer: is it
2682 * a "char *", or a "void *", const or not. Some compilers
2683 * don't take kindly to e.g. assuming that "char *" implicitly
2684 * promotes to a "void *", or to explicitly promoting/demoting
2685 * consts to non/vice versa. The "const void *" is the SUS
2686 * definition, but that does not fly everywhere for the above
2688 SETSOCKOPT_OPTION_VALUE_T buf;
2692 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2696 aint = (int)SvIV(sv);
2697 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2700 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2709 if (ckWARN(WARN_CLOSED))
2710 report_evil_fh(gv, io, optype);
2711 SETERRNO(EBADF,SS_IVCHAN);
2716 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2724 const int optype = PL_op->op_type;
2725 GV * const gv = (GV*)POPs;
2726 register IO * const io = GvIOn(gv);
2731 if (!io || !IoIFP(io))
2734 sv = sv_2mortal(newSV(257));
2735 (void)SvPOK_only(sv);
2739 fd = PerlIO_fileno(IoIFP(io));
2741 case OP_GETSOCKNAME:
2742 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2745 case OP_GETPEERNAME:
2746 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2748 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2750 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";
2751 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2752 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2753 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2754 sizeof(u_short) + sizeof(struct in_addr))) {
2761 #ifdef BOGUS_GETNAME_RETURN
2762 /* Interactive Unix, getpeername() and getsockname()
2763 does not return valid namelen */
2764 if (len == BOGUS_GETNAME_RETURN)
2765 len = sizeof(struct sockaddr);
2773 if (ckWARN(WARN_CLOSED))
2774 report_evil_fh(gv, io, optype);
2775 SETERRNO(EBADF,SS_IVCHAN);
2780 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2795 if (PL_op->op_flags & OPf_REF) {
2797 if (PL_op->op_type == OP_LSTAT) {
2798 if (gv != PL_defgv) {
2799 do_fstat_warning_check:
2800 if (ckWARN(WARN_IO))
2801 Perl_warner(aTHX_ packWARN(WARN_IO),
2802 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2803 } else if (PL_laststype != OP_LSTAT)
2804 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2808 if (gv != PL_defgv) {
2809 PL_laststype = OP_STAT;
2811 sv_setpvn(PL_statname, "", 0);
2818 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2819 } else if (IoDIRP(io)) {
2821 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2823 PL_laststatval = -1;
2829 if (PL_laststatval < 0) {
2830 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2831 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2836 SV* const sv = POPs;
2837 if (SvTYPE(sv) == SVt_PVGV) {
2840 } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2842 if (PL_op->op_type == OP_LSTAT)
2843 goto do_fstat_warning_check;
2845 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2847 if (PL_op->op_type == OP_LSTAT)
2848 goto do_fstat_warning_check;
2849 goto do_fstat_have_io;
2852 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2854 PL_laststype = PL_op->op_type;
2855 if (PL_op->op_type == OP_LSTAT)
2856 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2858 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2859 if (PL_laststatval < 0) {
2860 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2861 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2867 if (gimme != G_ARRAY) {
2868 if (gimme != G_VOID)
2869 XPUSHs(boolSV(max));
2875 mPUSHi(PL_statcache.st_dev);
2876 mPUSHi(PL_statcache.st_ino);
2877 mPUSHu(PL_statcache.st_mode);
2878 mPUSHu(PL_statcache.st_nlink);
2879 #if Uid_t_size > IVSIZE
2880 mPUSHn(PL_statcache.st_uid);
2882 # if Uid_t_sign <= 0
2883 mPUSHi(PL_statcache.st_uid);
2885 mPUSHu(PL_statcache.st_uid);
2888 #if Gid_t_size > IVSIZE
2889 mPUSHn(PL_statcache.st_gid);
2891 # if Gid_t_sign <= 0
2892 mPUSHi(PL_statcache.st_gid);
2894 mPUSHu(PL_statcache.st_gid);
2897 #ifdef USE_STAT_RDEV
2898 mPUSHi(PL_statcache.st_rdev);
2900 PUSHs(newSVpvs_flags("", SVs_TEMP));
2902 #if Off_t_size > IVSIZE
2903 mPUSHn(PL_statcache.st_size);
2905 mPUSHi(PL_statcache.st_size);
2908 mPUSHn(PL_statcache.st_atime);
2909 mPUSHn(PL_statcache.st_mtime);
2910 mPUSHn(PL_statcache.st_ctime);
2912 mPUSHi(PL_statcache.st_atime);
2913 mPUSHi(PL_statcache.st_mtime);
2914 mPUSHi(PL_statcache.st_ctime);
2916 #ifdef USE_STAT_BLOCKS
2917 mPUSHu(PL_statcache.st_blksize);
2918 mPUSHu(PL_statcache.st_blocks);
2920 PUSHs(newSVpvs_flags("", SVs_TEMP));
2921 PUSHs(newSVpvs_flags("", SVs_TEMP));
2927 /* This macro is used by the stacked filetest operators :
2928 * if the previous filetest failed, short-circuit and pass its value.
2929 * Else, discard it from the stack and continue. --rgs
2931 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2932 if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
2933 else { (void)POPs; PUTBACK; } \
2940 /* Not const, because things tweak this below. Not bool, because there's
2941 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2942 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2943 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2944 /* Giving some sort of initial value silences compilers. */
2946 int access_mode = R_OK;
2948 int access_mode = 0;
2951 /* access_mode is never used, but leaving use_access in makes the
2952 conditional compiling below much clearer. */
2955 int stat_mode = S_IRUSR;
2957 bool effective = FALSE;
2960 STACKED_FTEST_CHECK;
2962 switch (PL_op->op_type) {
2964 #if !(defined(HAS_ACCESS) && defined(R_OK))
2970 #if defined(HAS_ACCESS) && defined(W_OK)
2975 stat_mode = S_IWUSR;
2979 #if defined(HAS_ACCESS) && defined(X_OK)
2984 stat_mode = S_IXUSR;
2988 #ifdef PERL_EFF_ACCESS
2991 stat_mode = S_IWUSR;
2995 #ifndef PERL_EFF_ACCESS
3002 #ifdef PERL_EFF_ACCESS
3007 stat_mode = S_IXUSR;
3013 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3014 const char *name = POPpx;
3016 # ifdef PERL_EFF_ACCESS
3017 result = PERL_EFF_ACCESS(name, access_mode);
3019 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3025 result = access(name, access_mode);
3027 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3042 if (cando(stat_mode, effective, &PL_statcache))
3051 const int op_type = PL_op->op_type;
3053 STACKED_FTEST_CHECK;
3058 if (op_type == OP_FTIS)
3061 /* You can't dTARGET inside OP_FTIS, because you'll get
3062 "panic: pad_sv po" - the op is not flagged to have a target. */
3066 #if Off_t_size > IVSIZE
3067 PUSHn(PL_statcache.st_size);
3069 PUSHi(PL_statcache.st_size);
3073 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3076 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3079 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3092 /* I believe that all these three are likely to be defined on most every
3093 system these days. */
3095 if(PL_op->op_type == OP_FTSUID)
3099 if(PL_op->op_type == OP_FTSGID)
3103 if(PL_op->op_type == OP_FTSVTX)
3107 STACKED_FTEST_CHECK;
3112 switch (PL_op->op_type) {
3114 if (PL_statcache.st_uid == PL_uid)
3118 if (PL_statcache.st_uid == PL_euid)
3122 if (PL_statcache.st_size == 0)
3126 if (S_ISSOCK(PL_statcache.st_mode))
3130 if (S_ISCHR(PL_statcache.st_mode))
3134 if (S_ISBLK(PL_statcache.st_mode))
3138 if (S_ISREG(PL_statcache.st_mode))
3142 if (S_ISDIR(PL_statcache.st_mode))
3146 if (S_ISFIFO(PL_statcache.st_mode))
3151 if (PL_statcache.st_mode & S_ISUID)
3157 if (PL_statcache.st_mode & S_ISGID)
3163 if (PL_statcache.st_mode & S_ISVTX)
3174 I32 result = my_lstat();
3178 if (S_ISLNK(PL_statcache.st_mode))
3191 STACKED_FTEST_CHECK;
3193 if (PL_op->op_flags & OPf_REF)
3195 else if (isGV(TOPs))
3197 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3198 gv = (GV*)SvRV(POPs);
3200 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3202 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3203 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3204 else if (tmpsv && SvOK(tmpsv)) {
3205 const char *tmps = SvPV_nolen_const(tmpsv);
3213 if (PerlLIO_isatty(fd))
3218 #if defined(atarist) /* this will work with atariST. Configure will
3219 make guesses for other systems. */
3220 # define FILE_base(f) ((f)->_base)
3221 # define FILE_ptr(f) ((f)->_ptr)
3222 # define FILE_cnt(f) ((f)->_cnt)
3223 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3234 register STDCHAR *s;
3240 STACKED_FTEST_CHECK;
3242 if (PL_op->op_flags & OPf_REF)
3244 else if (isGV(TOPs))
3246 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3247 gv = (GV*)SvRV(POPs);
3253 if (gv == PL_defgv) {
3255 io = GvIO(PL_statgv);
3258 goto really_filename;
3263 PL_laststatval = -1;
3264 sv_setpvn(PL_statname, "", 0);
3265 io = GvIO(PL_statgv);
3267 if (io && IoIFP(io)) {
3268 if (! PerlIO_has_base(IoIFP(io)))
3269 DIE(aTHX_ "-T and -B not implemented on filehandles");
3270 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3271 if (PL_laststatval < 0)
3273 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3274 if (PL_op->op_type == OP_FTTEXT)
3279 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3280 i = PerlIO_getc(IoIFP(io));
3282 (void)PerlIO_ungetc(IoIFP(io),i);
3284 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3286 len = PerlIO_get_bufsiz(IoIFP(io));
3287 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3288 /* sfio can have large buffers - limit to 512 */
3293 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3295 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3297 SETERRNO(EBADF,RMS_IFI);
3305 PL_laststype = OP_STAT;
3306 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3307 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3308 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3310 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3313 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3314 if (PL_laststatval < 0) {
3315 (void)PerlIO_close(fp);
3318 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3319 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3320 (void)PerlIO_close(fp);
3322 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3323 RETPUSHNO; /* special case NFS directories */
3324 RETPUSHYES; /* null file is anything */
3329 /* now scan s to look for textiness */
3330 /* XXX ASCII dependent code */
3332 #if defined(DOSISH) || defined(USEMYBINMODE)
3333 /* ignore trailing ^Z on short files */
3334 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3338 for (i = 0; i < len; i++, s++) {
3339 if (!*s) { /* null never allowed in text */
3344 else if (!(isPRINT(*s) || isSPACE(*s)))
3347 else if (*s & 128) {
3349 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3352 /* utf8 characters don't count as odd */
3353 if (UTF8_IS_START(*s)) {
3354 int ulen = UTF8SKIP(s);
3355 if (ulen < len - i) {
3357 for (j = 1; j < ulen; j++) {
3358 if (!UTF8_IS_CONTINUATION(s[j]))
3361 --ulen; /* loop does extra increment */
3371 *s != '\n' && *s != '\r' && *s != '\b' &&
3372 *s != '\t' && *s != '\f' && *s != 27)
3377 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3388 const char *tmps = NULL;
3392 SV * const sv = POPs;
3393 if (PL_op->op_flags & OPf_SPECIAL) {
3394 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3396 else if (SvTYPE(sv) == SVt_PVGV) {
3399 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
3403 tmps = SvPV_nolen_const(sv);
3407 if( !gv && (!tmps || !*tmps) ) {
3408 HV * const table = GvHVn(PL_envgv);
3411 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3412 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3414 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3419 deprecate("chdir('') or chdir(undef) as chdir()");
3420 tmps = SvPV_nolen_const(*svp);
3424 TAINT_PROPER("chdir");
3429 TAINT_PROPER("chdir");
3432 IO* const io = GvIO(gv);
3435 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3436 } else if (IoIFP(io)) {
3437 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3440 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3441 report_evil_fh(gv, io, PL_op->op_type);
3442 SETERRNO(EBADF, RMS_IFI);
3447 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3448 report_evil_fh(gv, io, PL_op->op_type);
3449 SETERRNO(EBADF,RMS_IFI);
3453 DIE(aTHX_ PL_no_func, "fchdir");
3457 PUSHi( PerlDir_chdir(tmps) >= 0 );
3459 /* Clear the DEFAULT element of ENV so we'll get the new value
3461 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3468 dVAR; dSP; dMARK; dTARGET;
3469 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3480 char * const tmps = POPpx;
3481 TAINT_PROPER("chroot");
3482 PUSHi( chroot(tmps) >= 0 );
3485 DIE(aTHX_ PL_no_func, "chroot");
3493 const char * const tmps2 = POPpconstx;
3494 const char * const tmps = SvPV_nolen_const(TOPs);
3495 TAINT_PROPER("rename");
3497 anum = PerlLIO_rename(tmps, tmps2);
3499 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3500 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3503 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3504 (void)UNLINK(tmps2);
3505 if (!(anum = link(tmps, tmps2)))
3506 anum = UNLINK(tmps);
3514 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3518 const int op_type = PL_op->op_type;
3522 if (op_type == OP_LINK)
3523 DIE(aTHX_ PL_no_func, "link");
3525 # ifndef HAS_SYMLINK
3526 if (op_type == OP_SYMLINK)
3527 DIE(aTHX_ PL_no_func, "symlink");
3531 const char * const tmps2 = POPpconstx;
3532 const char * const tmps = SvPV_nolen_const(TOPs);
3533 TAINT_PROPER(PL_op_desc[op_type]);
3535 # if defined(HAS_LINK)
3536 # if defined(HAS_SYMLINK)
3537 /* Both present - need to choose which. */
3538 (op_type == OP_LINK) ?
3539 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3541 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3542 PerlLIO_link(tmps, tmps2);
3545 # if defined(HAS_SYMLINK)
3546 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3547 symlink(tmps, tmps2);
3552 SETi( result >= 0 );
3559 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3570 char buf[MAXPATHLEN];
3573 #ifndef INCOMPLETE_TAINTS
3577 len = readlink(tmps, buf, sizeof(buf) - 1);
3585 RETSETUNDEF; /* just pretend it's a normal file */
3589 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3591 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3593 char * const save_filename = filename;
3598 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3600 Newx(cmdline, size, char);
3601 my_strlcpy(cmdline, cmd, size);
3602 my_strlcat(cmdline, " ", size);
3603 for (s = cmdline + strlen(cmdline); *filename; ) {
3607 if (s - cmdline < size)
3608 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3609 myfp = PerlProc_popen(cmdline, "r");
3613 SV * const tmpsv = sv_newmortal();
3614 /* Need to save/restore 'PL_rs' ?? */
3615 s = sv_gets(tmpsv, myfp, 0);
3616 (void)PerlProc_pclose(myfp);
3620 #ifdef HAS_SYS_ERRLIST
3625 /* you don't see this */
3626 const char * const errmsg =
3627 #ifdef HAS_SYS_ERRLIST
3635 if (instr(s, errmsg)) {
3642 #define EACCES EPERM
3644 if (instr(s, "cannot make"))
3645 SETERRNO(EEXIST,RMS_FEX);
3646 else if (instr(s, "existing file"))
3647 SETERRNO(EEXIST,RMS_FEX);
3648 else if (instr(s, "ile exists"))
3649 SETERRNO(EEXIST,RMS_FEX);
3650 else if (instr(s, "non-exist"))
3651 SETERRNO(ENOENT,RMS_FNF);
3652 else if (instr(s, "does not exist"))
3653 SETERRNO(ENOENT,RMS_FNF);
3654 else if (instr(s, "not empty"))
3655 SETERRNO(EBUSY,SS_DEVOFFLINE);
3656 else if (instr(s, "cannot access"))
3657 SETERRNO(EACCES,RMS_PRV);
3659 SETERRNO(EPERM,RMS_PRV);
3662 else { /* some mkdirs return no failure indication */
3663 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3664 if (PL_op->op_type == OP_RMDIR)
3669 SETERRNO(EACCES,RMS_PRV); /* a guess */
3678 /* This macro removes trailing slashes from a directory name.
3679 * Different operating and file systems take differently to
3680 * trailing slashes. According to POSIX 1003.1 1996 Edition
3681 * any number of trailing slashes should be allowed.
3682 * Thusly we snip them away so that even non-conforming
3683 * systems are happy.
3684 * We should probably do this "filtering" for all
3685 * the functions that expect (potentially) directory names:
3686 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3687 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3689 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3690 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3693 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3694 (tmps) = savepvn((tmps), (len)); \
3704 const int mode = (MAXARG > 1) ? POPi : 0777;
3706 TRIMSLASHES(tmps,len,copy);
3708 TAINT_PROPER("mkdir");
3710 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3714 SETi( dooneliner("mkdir", tmps) );
3715 oldumask = PerlLIO_umask(0);
3716 PerlLIO_umask(oldumask);
3717 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3732 TRIMSLASHES(tmps,len,copy);
3733 TAINT_PROPER("rmdir");
3735 SETi( PerlDir_rmdir(tmps) >= 0 );
3737 SETi( dooneliner("rmdir", tmps) );
3744 /* Directory calls. */
3748 #if defined(Direntry_t) && defined(HAS_READDIR)
3750 const char * const dirname = POPpconstx;
3751 GV * const gv = (GV*)POPs;
3752 register IO * const io = GvIOn(gv);
3757 if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED))
3758 Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3759 "Opening filehandle %s also as a directory", GvENAME(gv));
3761 PerlDir_close(IoDIRP(io));
3762 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3768 SETERRNO(EBADF,RMS_DIR);
3771 DIE(aTHX_ PL_no_dir_func, "opendir");
3777 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3778 DIE(aTHX_ PL_no_dir_func, "readdir");
3780 #if !defined(I_DIRENT) && !defined(VMS)
3781 Direntry_t *readdir (DIR *);
3787 const I32 gimme = GIMME;
3788 GV * const gv = (GV *)POPs;
3789 register const Direntry_t *dp;
3790 register IO * const io = GvIOn(gv);
3792 if (!io || !IoDIRP(io)) {
3793 if(ckWARN(WARN_IO)) {
3794 Perl_warner(aTHX_ packWARN(WARN_IO),
3795 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3801 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3805 sv = newSVpvn(dp->d_name, dp->d_namlen);
3807 sv = newSVpv(dp->d_name, 0);
3809 #ifndef INCOMPLETE_TAINTS
3810 if (!(IoFLAGS(io) & IOf_UNTAINT))
3814 } while (gimme == G_ARRAY);
3816 if (!dp && gimme != G_ARRAY)
3823 SETERRNO(EBADF,RMS_ISI);
3824 if (GIMME == G_ARRAY)
3833 #if defined(HAS_TELLDIR) || defined(telldir)
3835 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3836 /* XXX netbsd still seemed to.
3837 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3838 --JHI 1999-Feb-02 */
3839 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3840 long telldir (DIR *);
3842 GV * const gv = (GV*)POPs;
3843 register IO * const io = GvIOn(gv);
3845 if (!io || !IoDIRP(io)) {
3846 if(ckWARN(WARN_IO)) {
3847 Perl_warner(aTHX_ packWARN(WARN_IO),
3848 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3853 PUSHi( PerlDir_tell(IoDIRP(io)) );
3857 SETERRNO(EBADF,RMS_ISI);
3860 DIE(aTHX_ PL_no_dir_func, "telldir");
3866 #if defined(HAS_SEEKDIR) || defined(seekdir)
3868 const long along = POPl;
3869 GV * const gv = (GV*)POPs;
3870 register IO * const io = GvIOn(gv);
3872 if (!io || !IoDIRP(io)) {
3873 if(ckWARN(WARN_IO)) {
3874 Perl_warner(aTHX_ packWARN(WARN_IO),
3875 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3879 (void)PerlDir_seek(IoDIRP(io), along);
3884 SETERRNO(EBADF,RMS_ISI);
3887 DIE(aTHX_ PL_no_dir_func, "seekdir");
3893 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3895 GV * const gv = (GV*)POPs;
3896 register IO * const io = GvIOn(gv);
3898 if (!io || !IoDIRP(io)) {
3899 if(ckWARN(WARN_IO)) {
3900 Perl_warner(aTHX_ packWARN(WARN_IO),
3901 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3905 (void)PerlDir_rewind(IoDIRP(io));
3909 SETERRNO(EBADF,RMS_ISI);
3912 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3918 #if defined(Direntry_t) && defined(HAS_READDIR)
3920 GV * const gv = (GV*)POPs;
3921 register IO * const io = GvIOn(gv);
3923 if (!io || !IoDIRP(io)) {
3924 if(ckWARN(WARN_IO)) {
3925 Perl_warner(aTHX_ packWARN(WARN_IO),
3926 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3930 #ifdef VOID_CLOSEDIR
3931 PerlDir_close(IoDIRP(io));
3933 if (PerlDir_close(IoDIRP(io)) < 0) {
3934 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3943 SETERRNO(EBADF,RMS_IFI);
3946 DIE(aTHX_ PL_no_dir_func, "closedir");
3950 /* Process control. */
3959 PERL_FLUSHALL_FOR_CHILD;
3960 childpid = PerlProc_fork();
3964 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3966 SvREADONLY_off(GvSV(tmpgv));
3967 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3968 SvREADONLY_on(GvSV(tmpgv));
3970 #ifdef THREADS_HAVE_PIDS
3971 PL_ppid = (IV)getppid();
3973 #ifdef PERL_USES_PL_PIDSTATUS
3974 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3980 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3985 PERL_FLUSHALL_FOR_CHILD;
3986 childpid = PerlProc_fork();
3992 DIE(aTHX_ PL_no_func, "fork");
3999 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4004 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4005 childpid = wait4pid(-1, &argflags, 0);
4007 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4012 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4013 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4014 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4016 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4021 DIE(aTHX_ PL_no_func, "wait");
4027 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4029 const int optype = POPi;
4030 const Pid_t pid = TOPi;
4034 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4035 result = wait4pid(pid, &argflags, optype);
4037 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4042 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4043 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4044 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4046 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4051 DIE(aTHX_ PL_no_func, "waitpid");
4057 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4058 #if defined(__LIBCATAMOUNT__)
4059 PL_statusvalue = -1;
4068 while (++MARK <= SP) {
4069 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4074 TAINT_PROPER("system");
4076 PERL_FLUSHALL_FOR_CHILD;
4077 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4083 if (PerlProc_pipe(pp) >= 0)
4085 while ((childpid = PerlProc_fork()) == -1) {
4086 if (errno != EAGAIN) {
4091 PerlLIO_close(pp[0]);
4092 PerlLIO_close(pp[1]);
4099 Sigsave_t ihand,qhand; /* place to save signals during system() */
4103 PerlLIO_close(pp[1]);
4105 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4106 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4109 result = wait4pid(childpid, &status, 0);
4110 } while (result == -1 && errno == EINTR);
4112 (void)rsignal_restore(SIGINT, &ihand);
4113 (void)rsignal_restore(SIGQUIT, &qhand);
4115 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4116 do_execfree(); /* free any memory child malloced on fork */
4123 while (n < sizeof(int)) {
4124 n1 = PerlLIO_read(pp[0],
4125 (void*)(((char*)&errkid)+n),
4131 PerlLIO_close(pp[0]);
4132 if (n) { /* Error */
4133 if (n != sizeof(int))
4134 DIE(aTHX_ "panic: kid popen errno read");
4135 errno = errkid; /* Propagate errno from kid */
4136 STATUS_NATIVE_CHILD_SET(-1);
4139 XPUSHi(STATUS_CURRENT);
4143 PerlLIO_close(pp[0]);
4144 #if defined(HAS_FCNTL) && defined(F_SETFD)
4145 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4148 if (PL_op->op_flags & OPf_STACKED) {
4149 SV * const really = *++MARK;
4150 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4152 else if (SP - MARK != 1)
4153 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4155 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4159 #else /* ! FORK or VMS or OS/2 */
4162 if (PL_op->op_flags & OPf_STACKED) {
4163 SV * const really = *++MARK;
4164 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4165 value = (I32)do_aspawn(really, MARK, SP);
4167 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4170 else if (SP - MARK != 1) {
4171 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4172 value = (I32)do_aspawn(NULL, MARK, SP);
4174 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4178 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4180 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4182 STATUS_NATIVE_CHILD_SET(value);
4185 XPUSHi(result ? value : STATUS_CURRENT);
4186 #endif /* !FORK or VMS or OS/2 */
4193 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4198 while (++MARK <= SP) {
4199 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4204 TAINT_PROPER("exec");
4206 PERL_FLUSHALL_FOR_CHILD;
4207 if (PL_op->op_flags & OPf_STACKED) {
4208 SV * const really = *++MARK;
4209 value = (I32)do_aexec(really, MARK, SP);
4211 else if (SP - MARK != 1)
4213 value = (I32)vms_do_aexec(NULL, MARK, SP);
4217 (void ) do_aspawn(NULL, MARK, SP);
4221 value = (I32)do_aexec(NULL, MARK, SP);
4226 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4229 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4232 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4246 # ifdef THREADS_HAVE_PIDS
4247 if (PL_ppid != 1 && getppid() == 1)
4248 /* maybe the parent process has died. Refresh ppid cache */
4252 XPUSHi( getppid() );
4256 DIE(aTHX_ PL_no_func, "getppid");
4265 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4268 pgrp = (I32)BSD_GETPGRP(pid);
4270 if (pid != 0 && pid != PerlProc_getpid())
4271 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4277 DIE(aTHX_ PL_no_func, "getpgrp()");
4296 TAINT_PROPER("setpgrp");
4298 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4300 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4301 || (pid != 0 && pid != PerlProc_getpid()))
4303 DIE(aTHX_ "setpgrp can't take arguments");
4305 SETi( setpgrp() >= 0 );
4306 #endif /* USE_BSDPGRP */
4309 DIE(aTHX_ PL_no_func, "setpgrp()");
4315 #ifdef HAS_GETPRIORITY
4317 const int who = POPi;
4318 const int which = TOPi;
4319 SETi( getpriority(which, who) );
4322 DIE(aTHX_ PL_no_func, "getpriority()");
4328 #ifdef HAS_SETPRIORITY
4330 const int niceval = POPi;
4331 const int who = POPi;
4332 const int which = TOPi;
4333 TAINT_PROPER("setpriority");
4334 SETi( setpriority(which, who, niceval) >= 0 );
4337 DIE(aTHX_ PL_no_func, "setpriority()");
4347 XPUSHn( time(NULL) );
4349 XPUSHi( time(NULL) );
4361 (void)PerlProc_times(&PL_timesbuf);
4363 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4364 /* struct tms, though same data */
4368 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4369 if (GIMME == G_ARRAY) {
4370 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4371 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4372 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4380 if (GIMME == G_ARRAY) {
4387 DIE(aTHX_ "times not implemented");
4389 #endif /* HAS_TIMES */
4392 #ifdef LOCALTIME_EDGECASE_BROKEN
4393 static struct tm *S_my_localtime (pTHX_ Time_t *tp)
4398 /* No workarounds in the valid range */
4399 if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4400 return (localtime (tp));
4402 /* This edge case is to workaround the undefined behaviour, where the
4403 * TIMEZONE makes the time go beyond the defined range.
4404 * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4405 * If there is a negative offset in TZ, like MET-1METDST, some broken
4406 * implementations of localtime () (like AIX 5.2) barf with bogus
4408 * 0x7fffffff gmtime 2038-01-19 03:14:07
4409 * 0x7fffffff localtime 1901-12-13 21:45:51
4410 * 0x7fffffff mylocaltime 2038-01-19 04:14:07
4411 * 0x3c19137f gmtime 2001-12-13 20:45:51
4412 * 0x3c19137f localtime 2001-12-13 21:45:51
4413 * 0x3c19137f mylocaltime 2001-12-13 21:45:51
4414 * Given that legal timezones are typically between GMT-12 and GMT+12
4415 * we turn back the clock 23 hours before calling the localtime
4416 * function, and add those to the return value. This will never cause
4417 * day wrapping problems, since the edge case is Tue Jan *19*
4419 T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4422 if (P->tm_hour >= 24) {
4424 P->tm_mday++; /* 18 -> 19 */
4425 P->tm_wday++; /* Mon -> Tue */
4426 P->tm_yday++; /* 18 -> 19 */
4429 } /* S_my_localtime */
4437 const struct tm *tmbuf;
4438 static const char * const dayname[] =
4439 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4440 static const char * const monname[] =
4441 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4442 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4448 when = (Time_t)SvNVx(POPs);
4450 when = (Time_t)SvIVx(POPs);
4453 if (PL_op->op_type == OP_LOCALTIME)
4454 #ifdef LOCALTIME_EDGECASE_BROKEN
4455 tmbuf = S_my_localtime(aTHX_ &when);
4457 tmbuf = localtime(&when);
4460 tmbuf = gmtime(&when);
4462 if (GIMME != G_ARRAY) {
4468 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4469 dayname[tmbuf->tm_wday],
4470 monname[tmbuf->tm_mon],
4475 tmbuf->tm_year + 1900);
4481 mPUSHi(tmbuf->tm_sec);
4482 mPUSHi(tmbuf->tm_min);
4483 mPUSHi(tmbuf->tm_hour);
4484 mPUSHi(tmbuf->tm_mday);
4485 mPUSHi(tmbuf->tm_mon);
4486 mPUSHi(tmbuf->tm_year);
4487 mPUSHi(tmbuf->tm_wday);
4488 mPUSHi(tmbuf->tm_yday);
4489 mPUSHi(tmbuf->tm_isdst);
4500 anum = alarm((unsigned int)anum);
4507 DIE(aTHX_ PL_no_func, "alarm");
4518 (void)time(&lasttime);
4523 PerlProc_sleep((unsigned int)duration);
4526 XPUSHi(when - lasttime);
4530 /* Shared memory. */
4531 /* Merged with some message passing. */
4535 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4536 dVAR; dSP; dMARK; dTARGET;
4537 const int op_type = PL_op->op_type;
4542 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4545 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4548 value = (I32)(do_semop(MARK, SP) >= 0);
4551 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4567 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4568 dVAR; dSP; dMARK; dTARGET;
4569 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4576 DIE(aTHX_ "System V IPC is not implemented on this machine");
4582 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4583 dVAR; dSP; dMARK; dTARGET;
4584 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4592 PUSHp(zero_but_true, ZBTLEN);
4600 /* I can't const this further without getting warnings about the types of
4601 various arrays passed in from structures. */
4603 S_space_join_names_mortal(pTHX_ char *const *array)
4607 if (array && *array) {
4608 target = newSVpvs_flags("", SVs_TEMP);
4610 sv_catpv(target, *array);
4613 sv_catpvs(target, " ");
4616 target = sv_mortalcopy(&PL_sv_no);
4621 /* Get system info. */
4625 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4627 I32 which = PL_op->op_type;
4628 register char **elem;
4630 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4631 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4632 struct hostent *gethostbyname(Netdb_name_t);
4633 struct hostent *gethostent(void);
4635 struct hostent *hent;
4639 if (which == OP_GHBYNAME) {
4640 #ifdef HAS_GETHOSTBYNAME
4641 const char* const name = POPpbytex;
4642 hent = PerlSock_gethostbyname(name);
4644 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4647 else if (which == OP_GHBYADDR) {
4648 #ifdef HAS_GETHOSTBYADDR
4649 const int addrtype = POPi;
4650 SV * const addrsv = POPs;
4652 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4654 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4656 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4660 #ifdef HAS_GETHOSTENT
4661 hent = PerlSock_gethostent();
4663 DIE(aTHX_ PL_no_sock_func, "gethostent");
4666 #ifdef HOST_NOT_FOUND
4668 #ifdef USE_REENTRANT_API
4669 # ifdef USE_GETHOSTENT_ERRNO
4670 h_errno = PL_reentrant_buffer->_gethostent_errno;
4673 STATUS_UNIX_SET(h_errno);
4677 if (GIMME != G_ARRAY) {
4678 PUSHs(sv = sv_newmortal());
4680 if (which == OP_GHBYNAME) {
4682 sv_setpvn(sv, hent->h_addr, hent->h_length);
4685 sv_setpv(sv, (char*)hent->h_name);
4691 mPUSHs(newSVpv((char*)hent->h_name, 0));
4692 PUSHs(space_join_names_mortal(hent->h_aliases));
4693 mPUSHi(hent->h_addrtype);
4694 len = hent->h_length;
4697 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4698 mXPUSHp(*elem, len);
4702 mPUSHp(hent->h_addr, len);
4704 PUSHs(sv_mortalcopy(&PL_sv_no));
4709 DIE(aTHX_ PL_no_sock_func, "gethostent");
4715 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4717 I32 which = PL_op->op_type;
4719 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4720 struct netent *getnetbyaddr(Netdb_net_t, int);
4721 struct netent *getnetbyname(Netdb_name_t);
4722 struct netent *getnetent(void);
4724 struct netent *nent;
4726 if (which == OP_GNBYNAME){
4727 #ifdef HAS_GETNETBYNAME
4728 const char * const name = POPpbytex;
4729 nent = PerlSock_getnetbyname(name);
4731 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4734 else if (which == OP_GNBYADDR) {
4735 #ifdef HAS_GETNETBYADDR
4736 const int addrtype = POPi;
4737 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4738 nent = PerlSock_getnetbyaddr(addr, addrtype);
4740 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4744 #ifdef HAS_GETNETENT
4745 nent = PerlSock_getnetent();
4747 DIE(aTHX_ PL_no_sock_func, "getnetent");
4750 #ifdef HOST_NOT_FOUND
4752 #ifdef USE_REENTRANT_API
4753 # ifdef USE_GETNETENT_ERRNO
4754 h_errno = PL_reentrant_buffer->_getnetent_errno;
4757 STATUS_UNIX_SET(h_errno);
4762 if (GIMME != G_ARRAY) {
4763 PUSHs(sv = sv_newmortal());
4765 if (which == OP_GNBYNAME)
4766 sv_setiv(sv, (IV)nent->n_net);
4768 sv_setpv(sv, nent->n_name);
4774 mPUSHs(newSVpv(nent->n_name, 0));
4775 PUSHs(space_join_names_mortal(nent->n_aliases));
4776 mPUSHi(nent->n_addrtype);
4777 mPUSHi(nent->n_net);
4782 DIE(aTHX_ PL_no_sock_func, "getnetent");
4788 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4790 I32 which = PL_op->op_type;
4792 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4793 struct protoent *getprotobyname(Netdb_name_t);
4794 struct protoent *getprotobynumber(int);
4795 struct protoent *getprotoent(void);
4797 struct protoent *pent;
4799 if (which == OP_GPBYNAME) {
4800 #ifdef HAS_GETPROTOBYNAME
4801 const char* const name = POPpbytex;
4802 pent = PerlSock_getprotobyname(name);
4804 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4807 else if (which == OP_GPBYNUMBER) {
4808 #ifdef HAS_GETPROTOBYNUMBER
4809 const int number = POPi;
4810 pent = PerlSock_getprotobynumber(number);
4812 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4816 #ifdef HAS_GETPROTOENT
4817 pent = PerlSock_getprotoent();
4819 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4823 if (GIMME != G_ARRAY) {
4824 PUSHs(sv = sv_newmortal());
4826 if (which == OP_GPBYNAME)
4827 sv_setiv(sv, (IV)pent->p_proto);
4829 sv_setpv(sv, pent->p_name);
4835 mPUSHs(newSVpv(pent->p_name, 0));
4836 PUSHs(space_join_names_mortal(pent->p_aliases));
4837 mPUSHi(pent->p_proto);
4842 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4848 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4850 I32 which = PL_op->op_type;
4852 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4853 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4854 struct servent *getservbyport(int, Netdb_name_t);
4855 struct servent *getservent(void);
4857 struct servent *sent;
4859 if (which == OP_GSBYNAME) {
4860 #ifdef HAS_GETSERVBYNAME
4861 const char * const proto = POPpbytex;
4862 const char * const name = POPpbytex;
4863 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4865 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4868 else if (which == OP_GSBYPORT) {
4869 #ifdef HAS_GETSERVBYPORT
4870 const char * const proto = POPpbytex;
4871 unsigned short port = (unsigned short)POPu;
4873 port = PerlSock_htons(port);
4875 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4877 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4881 #ifdef HAS_GETSERVENT
4882 sent = PerlSock_getservent();
4884 DIE(aTHX_ PL_no_sock_func, "getservent");
4888 if (GIMME != G_ARRAY) {
4889 PUSHs(sv = sv_newmortal());
4891 if (which == OP_GSBYNAME) {
4893 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4895 sv_setiv(sv, (IV)(sent->s_port));
4899 sv_setpv(sv, sent->s_name);
4905 mPUSHs(newSVpv(sent->s_name, 0));
4906 PUSHs(space_join_names_mortal(sent->s_aliases));
4908 mPUSHi(PerlSock_ntohs(sent->s_port));
4910 mPUSHi(sent->s_port);
4912 mPUSHs(newSVpv(sent->s_proto, 0));
4917 DIE(aTHX_ PL_no_sock_func, "getservent");
4923 #ifdef HAS_SETHOSTENT
4925 PerlSock_sethostent(TOPi);
4928 DIE(aTHX_ PL_no_sock_func, "sethostent");
4934 #ifdef HAS_SETNETENT
4936 PerlSock_setnetent(TOPi);
4939 DIE(aTHX_ PL_no_sock_func, "setnetent");
4945 #ifdef HAS_SETPROTOENT
4947 PerlSock_setprotoent(TOPi);
4950 DIE(aTHX_ PL_no_sock_func, "setprotoent");
4956 #ifdef HAS_SETSERVENT
4958 PerlSock_setservent(TOPi);
4961 DIE(aTHX_ PL_no_sock_func, "setservent");
4967 #ifdef HAS_ENDHOSTENT
4969 PerlSock_endhostent();
4973 DIE(aTHX_ PL_no_sock_func, "endhostent");
4979 #ifdef HAS_ENDNETENT
4981 PerlSock_endnetent();
4985 DIE(aTHX_ PL_no_sock_func, "endnetent");
4991 #ifdef HAS_ENDPROTOENT
4993 PerlSock_endprotoent();
4997 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5003 #ifdef HAS_ENDSERVENT
5005 PerlSock_endservent();
5009 DIE(aTHX_ PL_no_sock_func, "endservent");
5017 I32 which = PL_op->op_type;
5019 struct passwd *pwent = NULL;
5021 * We currently support only the SysV getsp* shadow password interface.
5022 * The interface is declared in <shadow.h> and often one needs to link
5023 * with -lsecurity or some such.
5024 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5027 * AIX getpwnam() is clever enough to return the encrypted password
5028 * only if the caller (euid?) is root.
5030 * There are at least three other shadow password APIs. Many platforms
5031 * seem to contain more than one interface for accessing the shadow
5032 * password databases, possibly for compatibility reasons.
5033 * The getsp*() is by far he simplest one, the other two interfaces
5034 * are much more complicated, but also very similar to each other.
5039 * struct pr_passwd *getprpw*();
5040 * The password is in
5041 * char getprpw*(...).ufld.fd_encrypt[]
5042 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5047 * struct es_passwd *getespw*();
5048 * The password is in
5049 * char *(getespw*(...).ufld.fd_encrypt)
5050 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5053 * struct userpw *getuserpw();
5054 * The password is in
5055 * char *(getuserpw(...)).spw_upw_passwd
5056 * (but the de facto standard getpwnam() should work okay)
5058 * Mention I_PROT here so that Configure probes for it.
5060 * In HP-UX for getprpw*() the manual page claims that one should include
5061 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5062 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5063 * and pp_sys.c already includes <shadow.h> if there is such.
5065 * Note that <sys/security.h> is already probed for, but currently
5066 * it is only included in special cases.
5068 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5069 * be preferred interface, even though also the getprpw*() interface
5070 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5071 * One also needs to call set_auth_parameters() in main() before
5072 * doing anything else, whether one is using getespw*() or getprpw*().
5074 * Note that accessing the shadow databases can be magnitudes
5075 * slower than accessing the standard databases.
5080 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5081 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5082 * the pw_comment is left uninitialized. */
5083 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5089 const char* const name = POPpbytex;
5090 pwent = getpwnam(name);
5096 pwent = getpwuid(uid);
5100 # ifdef HAS_GETPWENT
5102 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5103 if (pwent) pwent = getpwnam(pwent->pw_name);
5106 DIE(aTHX_ PL_no_func, "getpwent");
5112 if (GIMME != G_ARRAY) {
5113 PUSHs(sv = sv_newmortal());
5115 if (which == OP_GPWNAM)
5116 # if Uid_t_sign <= 0
5117 sv_setiv(sv, (IV)pwent->pw_uid);
5119 sv_setuv(sv, (UV)pwent->pw_uid);
5122 sv_setpv(sv, pwent->pw_name);
5128 mPUSHs(newSVpv(pwent->pw_name, 0));
5132 /* If we have getspnam(), we try to dig up the shadow
5133 * password. If we are underprivileged, the shadow
5134 * interface will set the errno to EACCES or similar,
5135 * and return a null pointer. If this happens, we will
5136 * use the dummy password (usually "*" or "x") from the
5137 * standard password database.
5139 * In theory we could skip the shadow call completely
5140 * if euid != 0 but in practice we cannot know which
5141 * security measures are guarding the shadow databases
5142 * on a random platform.
5144 * Resist the urge to use additional shadow interfaces.
5145 * Divert the urge to writing an extension instead.
5148 /* Some AIX setups falsely(?) detect some getspnam(), which
5149 * has a different API than the Solaris/IRIX one. */
5150 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5152 const int saverrno = errno;
5153 const struct spwd * const spwent = getspnam(pwent->pw_name);
5154 /* Save and restore errno so that
5155 * underprivileged attempts seem
5156 * to have never made the unsccessful
5157 * attempt to retrieve the shadow password. */
5159 if (spwent && spwent->sp_pwdp)
5160 sv_setpv(sv, spwent->sp_pwdp);
5164 if (!SvPOK(sv)) /* Use the standard password, then. */
5165 sv_setpv(sv, pwent->pw_passwd);
5168 # ifndef INCOMPLETE_TAINTS
5169 /* passwd is tainted because user himself can diddle with it.
5170 * admittedly not much and in a very limited way, but nevertheless. */
5174 # if Uid_t_sign <= 0
5175 mPUSHi(pwent->pw_uid);
5177 mPUSHu(pwent->pw_uid);
5180 # if Uid_t_sign <= 0
5181 mPUSHi(pwent->pw_gid);
5183 mPUSHu(pwent->pw_gid);
5185 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5186 * because of the poor interface of the Perl getpw*(),
5187 * not because there's some standard/convention saying so.
5188 * A better interface would have been to return a hash,
5189 * but we are accursed by our history, alas. --jhi. */
5191 mPUSHi(pwent->pw_change);
5194 mPUSHi(pwent->pw_quota);
5197 mPUSHs(newSVpv(pwent->pw_age, 0));
5199 /* I think that you can never get this compiled, but just in case. */
5200 PUSHs(sv_mortalcopy(&PL_sv_no));
5205 /* pw_class and pw_comment are mutually exclusive--.
5206 * see the above note for pw_change, pw_quota, and pw_age. */
5208 mPUSHs(newSVpv(pwent->pw_class, 0));
5211 mPUSHs(newSVpv(pwent->pw_comment, 0));
5213 /* I think that you can never get this compiled, but just in case. */
5214 PUSHs(sv_mortalcopy(&PL_sv_no));
5219 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5221 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5223 # ifndef INCOMPLETE_TAINTS
5224 /* pw_gecos is tainted because user himself can diddle with it. */
5228 mPUSHs(newSVpv(pwent->pw_dir, 0));
5230 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5231 # ifndef INCOMPLETE_TAINTS
5232 /* pw_shell is tainted because user himself can diddle with it. */
5237 mPUSHi(pwent->pw_expire);
5242 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5248 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5253 DIE(aTHX_ PL_no_func, "setpwent");
5259 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5264 DIE(aTHX_ PL_no_func, "endpwent");
5272 const I32 which = PL_op->op_type;
5273 const struct group *grent;
5275 if (which == OP_GGRNAM) {
5276 const char* const name = POPpbytex;
5277 grent = (const struct group *)getgrnam(name);
5279 else if (which == OP_GGRGID) {
5280 const Gid_t gid = POPi;
5281 grent = (const struct group *)getgrgid(gid);
5285 grent = (struct group *)getgrent();
5287 DIE(aTHX_ PL_no_func, "getgrent");
5291 if (GIMME != G_ARRAY) {
5292 SV * const sv = sv_newmortal();
5296 if (which == OP_GGRNAM)
5297 sv_setiv(sv, (IV)grent->gr_gid);
5299 sv_setpv(sv, grent->gr_name);
5305 mPUSHs(newSVpv(grent->gr_name, 0));
5308 mPUSHs(newSVpv(grent->gr_passwd, 0));
5310 PUSHs(sv_mortalcopy(&PL_sv_no));
5313 mPUSHi(grent->gr_gid);
5315 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5316 /* In UNICOS/mk (_CRAYMPP) the multithreading
5317 * versions (getgrnam_r, getgrgid_r)
5318 * seem to return an illegal pointer
5319 * as the group members list, gr_mem.
5320 * getgrent() doesn't even have a _r version
5321 * but the gr_mem is poisonous anyway.
5322 * So yes, you cannot get the list of group
5323 * members if building multithreaded in UNICOS/mk. */
5324 PUSHs(space_join_names_mortal(grent->gr_mem));
5330 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5336 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5341 DIE(aTHX_ PL_no_func, "setgrent");
5347 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5352 DIE(aTHX_ PL_no_func, "endgrent");
5362 if (!(tmps = PerlProc_getlogin()))
5364 PUSHp(tmps, strlen(tmps));
5367 DIE(aTHX_ PL_no_func, "getlogin");
5371 /* Miscellaneous. */
5376 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5377 register I32 items = SP - MARK;
5378 unsigned long a[20];
5383 while (++MARK <= SP) {
5384 if (SvTAINTED(*MARK)) {
5390 TAINT_PROPER("syscall");
5393 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5394 * or where sizeof(long) != sizeof(char*). But such machines will
5395 * not likely have syscall implemented either, so who cares?
5397 while (++MARK <= SP) {
5398 if (SvNIOK(*MARK) || !i)
5399 a[i++] = SvIV(*MARK);
5400 else if (*MARK == &PL_sv_undef)
5403 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5409 DIE(aTHX_ "Too many args to syscall");
5411 DIE(aTHX_ "Too few args to syscall");
5413 retval = syscall(a[0]);
5416 retval = syscall(a[0],a[1]);
5419 retval = syscall(a[0],a[1],a[2]);
5422 retval = syscall(a[0],a[1],a[2],a[3]);
5425 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5428 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5431 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5434 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5438 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5441 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5444 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5448 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5452 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],
5457 a[10],a[11],a[12],a[13]);
5459 #endif /* atarist */
5465 DIE(aTHX_ PL_no_func, "syscall");
5469 #ifdef FCNTL_EMULATE_FLOCK
5471 /* XXX Emulate flock() with fcntl().
5472 What's really needed is a good file locking module.
5476 fcntl_emulate_flock(int fd, int operation)
5480 switch (operation & ~LOCK_NB) {
5482 flock.l_type = F_RDLCK;
5485 flock.l_type = F_WRLCK;
5488 flock.l_type = F_UNLCK;
5494 flock.l_whence = SEEK_SET;
5495 flock.l_start = flock.l_len = (Off_t)0;
5497 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5500 #endif /* FCNTL_EMULATE_FLOCK */
5502 #ifdef LOCKF_EMULATE_FLOCK
5504 /* XXX Emulate flock() with lockf(). This is just to increase
5505 portability of scripts. The calls are not completely
5506 interchangeable. What's really needed is a good file
5510 /* The lockf() constants might have been defined in <unistd.h>.
5511 Unfortunately, <unistd.h> causes troubles on some mixed
5512 (BSD/POSIX) systems, such as SunOS 4.1.3.
5514 Further, the lockf() constants aren't POSIX, so they might not be
5515 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5516 just stick in the SVID values and be done with it. Sigh.
5520 # define F_ULOCK 0 /* Unlock a previously locked region */
5523 # define F_LOCK 1 /* Lock a region for exclusive use */
5526 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5529 # define F_TEST 3 /* Test a region for other processes locks */
5533 lockf_emulate_flock(int fd, int operation)
5536 const int save_errno = errno;
5539 /* flock locks entire file so for lockf we need to do the same */
5540 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5541 if (pos > 0) /* is seekable and needs to be repositioned */
5542 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5543 pos = -1; /* seek failed, so don't seek back afterwards */
5546 switch (operation) {
5548 /* LOCK_SH - get a shared lock */
5550 /* LOCK_EX - get an exclusive lock */
5552 i = lockf (fd, F_LOCK, 0);
5555 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5556 case LOCK_SH|LOCK_NB:
5557 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5558 case LOCK_EX|LOCK_NB:
5559 i = lockf (fd, F_TLOCK, 0);
5561 if ((errno == EAGAIN) || (errno == EACCES))
5562 errno = EWOULDBLOCK;
5565 /* LOCK_UN - unlock (non-blocking is a no-op) */
5567 case LOCK_UN|LOCK_NB:
5568 i = lockf (fd, F_ULOCK, 0);
5571 /* Default - can't decipher operation */
5578 if (pos > 0) /* need to restore position of the handle */
5579 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5584 #endif /* LOCKF_EMULATE_FLOCK */
5588 * c-indentation-style: bsd
5590 * indent-tabs-mode: t
5593 * ex: set ts=8 sts=4 sw=4 noet: