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;
1243 PERL_ARGS_ASSERT_DOFORM;
1248 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1249 PUSHFORMAT(cx, retop);
1251 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1253 setdefout(gv); /* locally select filehandle so $% et al work */
1285 goto not_a_format_reference;
1290 tmpsv = sv_newmortal();
1291 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1292 name = SvPV_nolen_const(tmpsv);
1294 DIE(aTHX_ "Undefined format \"%s\" called", name);
1296 not_a_format_reference:
1297 DIE(aTHX_ "Not a format reference");
1300 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1302 IoFLAGS(io) &= ~IOf_DIDTOP;
1303 return doform(cv,gv,PL_op->op_next);
1309 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1310 register IO * const io = GvIOp(gv);
1315 register PERL_CONTEXT *cx;
1317 if (!io || !(ofp = IoOFP(io)))
1320 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1321 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1323 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1324 PL_formtarget != PL_toptarget)
1328 if (!IoTOP_GV(io)) {
1331 if (!IoTOP_NAME(io)) {
1333 if (!IoFMT_NAME(io))
1334 IoFMT_NAME(io) = savepv(GvNAME(gv));
1335 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1336 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1337 if ((topgv && GvFORM(topgv)) ||
1338 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1339 IoTOP_NAME(io) = savesvpv(topname);
1341 IoTOP_NAME(io) = savepvs("top");
1343 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1344 if (!topgv || !GvFORM(topgv)) {
1345 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1348 IoTOP_GV(io) = topgv;
1350 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1351 I32 lines = IoLINES_LEFT(io);
1352 const char *s = SvPVX_const(PL_formtarget);
1353 if (lines <= 0) /* Yow, header didn't even fit!!! */
1355 while (lines-- > 0) {
1356 s = strchr(s, '\n');
1362 const STRLEN save = SvCUR(PL_formtarget);
1363 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1364 do_print(PL_formtarget, ofp);
1365 SvCUR_set(PL_formtarget, save);
1366 sv_chop(PL_formtarget, s);
1367 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1370 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1371 do_print(PL_formfeed, ofp);
1372 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1374 PL_formtarget = PL_toptarget;
1375 IoFLAGS(io) |= IOf_DIDTOP;
1378 DIE(aTHX_ "bad top format reference");
1381 SV * const sv = sv_newmortal();
1383 gv_efullname4(sv, fgv, NULL, FALSE);
1384 name = SvPV_nolen_const(sv);
1386 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1388 DIE(aTHX_ "Undefined top format called");
1390 if (cv && CvCLONE(cv))
1391 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1392 return doform(cv, gv, PL_op);
1396 POPBLOCK(cx,PL_curpm);
1402 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1404 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1405 else if (ckWARN(WARN_CLOSED))
1406 report_evil_fh(gv, io, PL_op->op_type);
1411 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1412 if (ckWARN(WARN_IO))
1413 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1415 if (!do_print(PL_formtarget, fp))
1418 FmLINES(PL_formtarget) = 0;
1419 SvCUR_set(PL_formtarget, 0);
1420 *SvEND(PL_formtarget) = '\0';
1421 if (IoFLAGS(io) & IOf_FLUSH)
1422 (void)PerlIO_flush(fp);
1427 PL_formtarget = PL_bodytarget;
1429 PERL_UNUSED_VAR(newsp);
1430 PERL_UNUSED_VAR(gimme);
1431 return cx->blk_sub.retop;
1436 dVAR; dSP; dMARK; dORIGMARK;
1441 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
1443 if (gv && (io = GvIO(gv))) {
1444 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1446 if (MARK == ORIGMARK) {
1449 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1453 *MARK = SvTIED_obj((SV*)io, mg);
1456 call_method("PRINTF", G_SCALAR);
1459 MARK = ORIGMARK + 1;
1467 if (!(io = GvIO(gv))) {
1468 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1469 report_evil_fh(gv, io, PL_op->op_type);
1470 SETERRNO(EBADF,RMS_IFI);
1473 else if (!(fp = IoOFP(io))) {
1474 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1476 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1477 else if (ckWARN(WARN_CLOSED))
1478 report_evil_fh(gv, io, PL_op->op_type);
1480 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1484 if (SvTAINTED(MARK[1]))
1485 TAINT_PROPER("printf");
1486 do_sprintf(sv, SP - MARK, MARK + 1);
1487 if (!do_print(sv, fp))
1490 if (IoFLAGS(io) & IOf_FLUSH)
1491 if (PerlIO_flush(fp) == EOF)
1502 PUSHs(&PL_sv_undef);
1510 const int perm = (MAXARG > 3) ? POPi : 0666;
1511 const int mode = POPi;
1512 SV * const sv = POPs;
1513 GV * const gv = (GV *)POPs;
1516 /* Need TIEHANDLE method ? */
1517 const char * const tmps = SvPV_const(sv, len);
1518 /* FIXME? do_open should do const */
1519 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1520 IoLINES(GvIOp(gv)) = 0;
1524 PUSHs(&PL_sv_undef);
1531 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1537 Sock_size_t bufsize;
1545 bool charstart = FALSE;
1546 STRLEN charskip = 0;
1549 GV * const gv = (GV*)*++MARK;
1550 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1551 && gv && (io = GvIO(gv)) )
1553 const MAGIC * mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1557 *MARK = SvTIED_obj((SV*)io, mg);
1559 call_method("READ", G_SCALAR);
1573 sv_setpvn(bufsv, "", 0);
1574 length = SvIVx(*++MARK);
1577 offset = SvIVx(*++MARK);
1581 if (!io || !IoIFP(io)) {
1582 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1583 report_evil_fh(gv, io, PL_op->op_type);
1584 SETERRNO(EBADF,RMS_IFI);
1587 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1588 buffer = SvPVutf8_force(bufsv, blen);
1589 /* UTF-8 may not have been set if they are all low bytes */
1594 buffer = SvPV_force(bufsv, blen);
1595 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1598 DIE(aTHX_ "Negative length");
1606 if (PL_op->op_type == OP_RECV) {
1607 char namebuf[MAXPATHLEN];
1608 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1609 bufsize = sizeof (struct sockaddr_in);
1611 bufsize = sizeof namebuf;
1613 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1617 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1618 /* 'offset' means 'flags' here */
1619 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1620 (struct sockaddr *)namebuf, &bufsize);
1624 /* Bogus return without padding */
1625 bufsize = sizeof (struct sockaddr_in);
1627 SvCUR_set(bufsv, count);
1628 *SvEND(bufsv) = '\0';
1629 (void)SvPOK_only(bufsv);
1633 /* This should not be marked tainted if the fp is marked clean */
1634 if (!(IoFLAGS(io) & IOf_UNTAINT))
1635 SvTAINTED_on(bufsv);
1637 sv_setpvn(TARG, namebuf, bufsize);
1642 if (PL_op->op_type == OP_RECV)
1643 DIE(aTHX_ PL_no_sock_func, "recv");
1645 if (DO_UTF8(bufsv)) {
1646 /* offset adjust in characters not bytes */
1647 blen = sv_len_utf8(bufsv);
1650 if (-offset > (int)blen)
1651 DIE(aTHX_ "Offset outside string");
1654 if (DO_UTF8(bufsv)) {
1655 /* convert offset-as-chars to offset-as-bytes */
1656 if (offset >= (int)blen)
1657 offset += SvCUR(bufsv) - blen;
1659 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1662 bufsize = SvCUR(bufsv);
1663 /* Allocating length + offset + 1 isn't perfect in the case of reading
1664 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1666 (should be 2 * length + offset + 1, or possibly something longer if
1667 PL_encoding is true) */
1668 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1669 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1670 Zero(buffer+bufsize, offset-bufsize, char);
1672 buffer = buffer + offset;
1674 read_target = bufsv;
1676 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1677 concatenate it to the current buffer. */
1679 /* Truncate the existing buffer to the start of where we will be
1681 SvCUR_set(bufsv, offset);
1683 read_target = sv_newmortal();
1684 SvUPGRADE(read_target, SVt_PV);
1685 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1688 if (PL_op->op_type == OP_SYSREAD) {
1689 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1690 if (IoTYPE(io) == IoTYPE_SOCKET) {
1691 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1697 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1702 #ifdef HAS_SOCKET__bad_code_maybe
1703 if (IoTYPE(io) == IoTYPE_SOCKET) {
1704 char namebuf[MAXPATHLEN];
1705 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1706 bufsize = sizeof (struct sockaddr_in);
1708 bufsize = sizeof namebuf;
1710 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1711 (struct sockaddr *)namebuf, &bufsize);
1716 count = PerlIO_read(IoIFP(io), buffer, length);
1717 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1718 if (count == 0 && PerlIO_error(IoIFP(io)))
1722 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1723 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1726 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1727 *SvEND(read_target) = '\0';
1728 (void)SvPOK_only(read_target);
1729 if (fp_utf8 && !IN_BYTES) {
1730 /* Look at utf8 we got back and count the characters */
1731 const char *bend = buffer + count;
1732 while (buffer < bend) {
1734 skip = UTF8SKIP(buffer);
1737 if (buffer - charskip + skip > bend) {
1738 /* partial character - try for rest of it */
1739 length = skip - (bend-buffer);
1740 offset = bend - SvPVX_const(bufsv);
1752 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1753 provided amount read (count) was what was requested (length)
1755 if (got < wanted && count == length) {
1756 length = wanted - got;
1757 offset = bend - SvPVX_const(bufsv);
1760 /* return value is character count */
1764 else if (buffer_utf8) {
1765 /* Let svcatsv upgrade the bytes we read in to utf8.
1766 The buffer is a mortal so will be freed soon. */
1767 sv_catsv_nomg(bufsv, read_target);
1770 /* This should not be marked tainted if the fp is marked clean */
1771 if (!(IoFLAGS(io) & IOf_UNTAINT))
1772 SvTAINTED_on(bufsv);
1784 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1790 STRLEN orig_blen_bytes;
1791 const int op_type = PL_op->op_type;
1795 GV *const gv = (GV*)*++MARK;
1796 if (PL_op->op_type == OP_SYSWRITE
1797 && gv && (io = GvIO(gv))) {
1798 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1802 if (MARK == SP - 1) {
1804 sv = sv_2mortal(newSViv(sv_len(*SP)));
1810 *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg);
1812 call_method("WRITE", G_SCALAR);
1828 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1830 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1831 if (io && IoIFP(io))
1832 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1834 report_evil_fh(gv, io, PL_op->op_type);
1836 SETERRNO(EBADF,RMS_IFI);
1840 /* Do this first to trigger any overloading. */
1841 buffer = SvPV_const(bufsv, blen);
1842 orig_blen_bytes = blen;
1843 doing_utf8 = DO_UTF8(bufsv);
1845 if (PerlIO_isutf8(IoIFP(io))) {
1846 if (!SvUTF8(bufsv)) {
1847 /* We don't modify the original scalar. */
1848 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1849 buffer = (char *) tmpbuf;
1853 else if (doing_utf8) {
1854 STRLEN tmplen = blen;
1855 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1858 buffer = (char *) tmpbuf;
1862 assert((char *)result == buffer);
1863 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1867 if (op_type == OP_SYSWRITE) {
1868 Size_t length = 0; /* This length is in characters. */
1874 /* The SV is bytes, and we've had to upgrade it. */
1875 blen_chars = orig_blen_bytes;
1877 /* The SV really is UTF-8. */
1878 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1879 /* Don't call sv_len_utf8 again because it will call magic
1880 or overloading a second time, and we might get back a
1881 different result. */
1882 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1884 /* It's safe, and it may well be cached. */
1885 blen_chars = sv_len_utf8(bufsv);
1893 length = blen_chars;
1895 #if Size_t_size > IVSIZE
1896 length = (Size_t)SvNVx(*++MARK);
1898 length = (Size_t)SvIVx(*++MARK);
1900 if ((SSize_t)length < 0) {
1902 DIE(aTHX_ "Negative length");
1907 offset = SvIVx(*++MARK);
1909 if (-offset > (IV)blen_chars) {
1911 DIE(aTHX_ "Offset outside string");
1913 offset += blen_chars;
1914 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1916 DIE(aTHX_ "Offset outside string");
1920 if (length > blen_chars - offset)
1921 length = blen_chars - offset;
1923 /* Here we convert length from characters to bytes. */
1924 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1925 /* Either we had to convert the SV, or the SV is magical, or
1926 the SV has overloading, in which case we can't or mustn't
1927 or mustn't call it again. */
1929 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1930 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1932 /* It's a real UTF-8 SV, and it's not going to change under
1933 us. Take advantage of any cache. */
1935 I32 len_I32 = length;
1937 /* Convert the start and end character positions to bytes.
1938 Remember that the second argument to sv_pos_u2b is relative
1940 sv_pos_u2b(bufsv, &start, &len_I32);
1947 buffer = buffer+offset;
1949 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1950 if (IoTYPE(io) == IoTYPE_SOCKET) {
1951 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1957 /* See the note at doio.c:do_print about filesize limits. --jhi */
1958 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1964 const int flags = SvIVx(*++MARK);
1967 char * const sockbuf = SvPVx(*++MARK, mlen);
1968 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1969 flags, (struct sockaddr *)sockbuf, mlen);
1973 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1978 DIE(aTHX_ PL_no_sock_func, "send");
1985 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
1988 #if Size_t_size > IVSIZE
2007 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
2009 gv = PL_last_in_gv = GvEGV(PL_argvgv);
2011 if (io && !IoIFP(io)) {
2012 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2014 IoFLAGS(io) &= ~IOf_START;
2015 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2017 sv_setpvn(GvSV(gv), "-", 1);
2020 GvSV(gv) = newSVpvn("-", 1);
2022 SvSETMAGIC(GvSV(gv));
2024 else if (!nextargv(gv))
2029 gv = PL_last_in_gv; /* eof */
2032 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
2035 IO * const io = GvIO(gv);
2037 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
2039 XPUSHs(SvTIED_obj((SV*)io, mg));
2042 call_method("EOF", G_SCALAR);
2049 PUSHs(boolSV(!gv || do_eof(gv)));
2060 PL_last_in_gv = (GV*)POPs;
2063 if (gv && (io = GvIO(gv))) {
2064 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2067 XPUSHs(SvTIED_obj((SV*)io, mg));
2070 call_method("TELL", G_SCALAR);
2077 #if LSEEKSIZE > IVSIZE
2078 PUSHn( do_tell(gv) );
2080 PUSHi( do_tell(gv) );
2088 const int whence = POPi;
2089 #if LSEEKSIZE > IVSIZE
2090 const Off_t offset = (Off_t)SvNVx(POPs);
2092 const Off_t offset = (Off_t)SvIVx(POPs);
2095 GV * const gv = PL_last_in_gv = (GV*)POPs;
2098 if (gv && (io = GvIO(gv))) {
2099 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2102 XPUSHs(SvTIED_obj((SV*)io, mg));
2103 #if LSEEKSIZE > IVSIZE
2104 mXPUSHn((NV) offset);
2111 call_method("SEEK", G_SCALAR);
2118 if (PL_op->op_type == OP_SEEK)
2119 PUSHs(boolSV(do_seek(gv, offset, whence)));
2121 const Off_t sought = do_sysseek(gv, offset, whence);
2123 PUSHs(&PL_sv_undef);
2125 SV* const sv = sought ?
2126 #if LSEEKSIZE > IVSIZE
2131 : newSVpvn(zero_but_true, ZBTLEN);
2142 /* There seems to be no consensus on the length type of truncate()
2143 * and ftruncate(), both off_t and size_t have supporters. In
2144 * general one would think that when using large files, off_t is
2145 * at least as wide as size_t, so using an off_t should be okay. */
2146 /* XXX Configure probe for the length type of *truncate() needed XXX */
2149 #if Off_t_size > IVSIZE
2154 /* Checking for length < 0 is problematic as the type might or
2155 * might not be signed: if it is not, clever compilers will moan. */
2156 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2163 if (PL_op->op_flags & OPf_SPECIAL) {
2164 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2173 TAINT_PROPER("truncate");
2174 if (!(fp = IoIFP(io))) {
2180 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2182 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2189 SV * const sv = POPs;
2192 if (SvTYPE(sv) == SVt_PVGV) {
2193 tmpgv = (GV*)sv; /* *main::FRED for example */
2194 goto do_ftruncate_gv;
2196 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2197 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
2198 goto do_ftruncate_gv;
2200 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2201 io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
2202 goto do_ftruncate_io;
2205 name = SvPV_nolen_const(sv);
2206 TAINT_PROPER("truncate");
2208 if (truncate(name, len) < 0)
2212 const int tmpfd = PerlLIO_open(name, O_RDWR);
2217 if (my_chsize(tmpfd, len) < 0)
2219 PerlLIO_close(tmpfd);
2228 SETERRNO(EBADF,RMS_IFI);
2236 SV * const argsv = POPs;
2237 const unsigned int func = POPu;
2238 const int optype = PL_op->op_type;
2239 GV * const gv = (GV*)POPs;
2240 IO * const io = gv ? GvIOn(gv) : NULL;
2244 if (!io || !argsv || !IoIFP(io)) {
2245 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2246 report_evil_fh(gv, io, PL_op->op_type);
2247 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2251 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2254 s = SvPV_force(argsv, len);
2255 need = IOCPARM_LEN(func);
2257 s = Sv_Grow(argsv, need + 1);
2258 SvCUR_set(argsv, need);
2261 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2264 retval = SvIV(argsv);
2265 s = INT2PTR(char*,retval); /* ouch */
2268 TAINT_PROPER(PL_op_desc[optype]);
2270 if (optype == OP_IOCTL)
2272 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2274 DIE(aTHX_ "ioctl is not implemented");
2278 DIE(aTHX_ "fcntl is not implemented");
2280 #if defined(OS2) && defined(__EMX__)
2281 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2283 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2287 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2289 if (s[SvCUR(argsv)] != 17)
2290 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2292 s[SvCUR(argsv)] = 0; /* put our null back */
2293 SvSETMAGIC(argsv); /* Assume it has changed */
2302 PUSHp(zero_but_true, ZBTLEN);
2315 const int argtype = POPi;
2316 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
2318 if (gv && (io = GvIO(gv)))
2324 /* XXX Looks to me like io is always NULL at this point */
2326 (void)PerlIO_flush(fp);
2327 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2330 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2331 report_evil_fh(gv, io, PL_op->op_type);
2333 SETERRNO(EBADF,RMS_IFI);
2338 DIE(aTHX_ PL_no_func, "flock()");
2348 const int protocol = POPi;
2349 const int type = POPi;
2350 const int domain = POPi;
2351 GV * const gv = (GV*)POPs;
2352 register IO * const io = gv ? GvIOn(gv) : NULL;
2356 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2357 report_evil_fh(gv, io, PL_op->op_type);
2358 if (io && IoIFP(io))
2359 do_close(gv, FALSE);
2360 SETERRNO(EBADF,LIB_INVARG);
2365 do_close(gv, FALSE);
2367 TAINT_PROPER("socket");
2368 fd = PerlSock_socket(domain, type, protocol);
2371 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2372 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2373 IoTYPE(io) = IoTYPE_SOCKET;
2374 if (!IoIFP(io) || !IoOFP(io)) {
2375 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2376 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2377 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2380 #if defined(HAS_FCNTL) && defined(F_SETFD)
2381 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2385 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2390 DIE(aTHX_ PL_no_sock_func, "socket");
2396 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2398 const int protocol = POPi;
2399 const int type = POPi;
2400 const int domain = POPi;
2401 GV * const gv2 = (GV*)POPs;
2402 GV * const gv1 = (GV*)POPs;
2403 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2404 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2407 if (!gv1 || !gv2 || !io1 || !io2) {
2408 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2410 report_evil_fh(gv1, io1, PL_op->op_type);
2412 report_evil_fh(gv1, io2, PL_op->op_type);
2414 if (io1 && IoIFP(io1))
2415 do_close(gv1, FALSE);
2416 if (io2 && IoIFP(io2))
2417 do_close(gv2, FALSE);
2422 do_close(gv1, FALSE);
2424 do_close(gv2, FALSE);
2426 TAINT_PROPER("socketpair");
2427 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2429 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2430 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2431 IoTYPE(io1) = IoTYPE_SOCKET;
2432 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2433 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2434 IoTYPE(io2) = IoTYPE_SOCKET;
2435 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2436 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2437 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2438 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2439 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2440 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2441 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2444 #if defined(HAS_FCNTL) && defined(F_SETFD)
2445 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2446 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2451 DIE(aTHX_ PL_no_sock_func, "socketpair");
2459 SV * const addrsv = POPs;
2460 /* OK, so on what platform does bind modify addr? */
2462 GV * const gv = (GV*)POPs;
2463 register IO * const io = GvIOn(gv);
2466 if (!io || !IoIFP(io))
2469 addr = SvPV_const(addrsv, len);
2470 TAINT_PROPER("bind");
2471 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2477 if (ckWARN(WARN_CLOSED))
2478 report_evil_fh(gv, io, PL_op->op_type);
2479 SETERRNO(EBADF,SS_IVCHAN);
2482 DIE(aTHX_ PL_no_sock_func, "bind");
2490 SV * const addrsv = POPs;
2491 GV * const gv = (GV*)POPs;
2492 register IO * const io = GvIOn(gv);
2496 if (!io || !IoIFP(io))
2499 addr = SvPV_const(addrsv, len);
2500 TAINT_PROPER("connect");
2501 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2507 if (ckWARN(WARN_CLOSED))
2508 report_evil_fh(gv, io, PL_op->op_type);
2509 SETERRNO(EBADF,SS_IVCHAN);
2512 DIE(aTHX_ PL_no_sock_func, "connect");
2520 const int backlog = POPi;
2521 GV * const gv = (GV*)POPs;
2522 register IO * const io = gv ? GvIOn(gv) : NULL;
2524 if (!gv || !io || !IoIFP(io))
2527 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2533 if (ckWARN(WARN_CLOSED))
2534 report_evil_fh(gv, io, PL_op->op_type);
2535 SETERRNO(EBADF,SS_IVCHAN);
2538 DIE(aTHX_ PL_no_sock_func, "listen");
2548 char namebuf[MAXPATHLEN];
2549 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2550 Sock_size_t len = sizeof (struct sockaddr_in);
2552 Sock_size_t len = sizeof namebuf;
2554 GV * const ggv = (GV*)POPs;
2555 GV * const ngv = (GV*)POPs;
2564 if (!gstio || !IoIFP(gstio))
2568 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2571 /* Some platforms indicate zero length when an AF_UNIX client is
2572 * not bound. Simulate a non-zero-length sockaddr structure in
2574 namebuf[0] = 0; /* sun_len */
2575 namebuf[1] = AF_UNIX; /* sun_family */
2583 do_close(ngv, FALSE);
2584 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2585 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2586 IoTYPE(nstio) = IoTYPE_SOCKET;
2587 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2588 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2589 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2590 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2593 #if defined(HAS_FCNTL) && defined(F_SETFD)
2594 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2598 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2599 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2601 #ifdef __SCO_VERSION__
2602 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2605 PUSHp(namebuf, len);
2609 if (ckWARN(WARN_CLOSED))
2610 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2611 SETERRNO(EBADF,SS_IVCHAN);
2617 DIE(aTHX_ PL_no_sock_func, "accept");
2625 const int how = POPi;
2626 GV * const gv = (GV*)POPs;
2627 register IO * const io = GvIOn(gv);
2629 if (!io || !IoIFP(io))
2632 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2636 if (ckWARN(WARN_CLOSED))
2637 report_evil_fh(gv, io, PL_op->op_type);
2638 SETERRNO(EBADF,SS_IVCHAN);
2641 DIE(aTHX_ PL_no_sock_func, "shutdown");
2649 const int optype = PL_op->op_type;
2650 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2651 const unsigned int optname = (unsigned int) POPi;
2652 const unsigned int lvl = (unsigned int) POPi;
2653 GV * const gv = (GV*)POPs;
2654 register IO * const io = GvIOn(gv);
2658 if (!io || !IoIFP(io))
2661 fd = PerlIO_fileno(IoIFP(io));
2665 (void)SvPOK_only(sv);
2669 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2676 #if defined(__SYMBIAN32__)
2677 # define SETSOCKOPT_OPTION_VALUE_T void *
2679 # define SETSOCKOPT_OPTION_VALUE_T const char *
2681 /* XXX TODO: We need to have a proper type (a Configure probe,
2682 * etc.) for what the C headers think of the third argument of
2683 * setsockopt(), the option_value read-only buffer: is it
2684 * a "char *", or a "void *", const or not. Some compilers
2685 * don't take kindly to e.g. assuming that "char *" implicitly
2686 * promotes to a "void *", or to explicitly promoting/demoting
2687 * consts to non/vice versa. The "const void *" is the SUS
2688 * definition, but that does not fly everywhere for the above
2690 SETSOCKOPT_OPTION_VALUE_T buf;
2694 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2698 aint = (int)SvIV(sv);
2699 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2702 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2711 if (ckWARN(WARN_CLOSED))
2712 report_evil_fh(gv, io, optype);
2713 SETERRNO(EBADF,SS_IVCHAN);
2718 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2726 const int optype = PL_op->op_type;
2727 GV * const gv = (GV*)POPs;
2728 register IO * const io = GvIOn(gv);
2733 if (!io || !IoIFP(io))
2736 sv = sv_2mortal(newSV(257));
2737 (void)SvPOK_only(sv);
2741 fd = PerlIO_fileno(IoIFP(io));
2743 case OP_GETSOCKNAME:
2744 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2747 case OP_GETPEERNAME:
2748 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2750 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2752 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";
2753 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2754 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2755 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2756 sizeof(u_short) + sizeof(struct in_addr))) {
2763 #ifdef BOGUS_GETNAME_RETURN
2764 /* Interactive Unix, getpeername() and getsockname()
2765 does not return valid namelen */
2766 if (len == BOGUS_GETNAME_RETURN)
2767 len = sizeof(struct sockaddr);
2775 if (ckWARN(WARN_CLOSED))
2776 report_evil_fh(gv, io, optype);
2777 SETERRNO(EBADF,SS_IVCHAN);
2782 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2797 if (PL_op->op_flags & OPf_REF) {
2799 if (PL_op->op_type == OP_LSTAT) {
2800 if (gv != PL_defgv) {
2801 do_fstat_warning_check:
2802 if (ckWARN(WARN_IO))
2803 Perl_warner(aTHX_ packWARN(WARN_IO),
2804 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2805 } else if (PL_laststype != OP_LSTAT)
2806 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2810 if (gv != PL_defgv) {
2811 PL_laststype = OP_STAT;
2813 sv_setpvn(PL_statname, "", 0);
2820 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2821 } else if (IoDIRP(io)) {
2823 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2825 PL_laststatval = -1;
2831 if (PL_laststatval < 0) {
2832 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2833 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2838 SV* const sv = POPs;
2839 if (SvTYPE(sv) == SVt_PVGV) {
2842 } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2844 if (PL_op->op_type == OP_LSTAT)
2845 goto do_fstat_warning_check;
2847 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2849 if (PL_op->op_type == OP_LSTAT)
2850 goto do_fstat_warning_check;
2851 goto do_fstat_have_io;
2854 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2856 PL_laststype = PL_op->op_type;
2857 if (PL_op->op_type == OP_LSTAT)
2858 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2860 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2861 if (PL_laststatval < 0) {
2862 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2863 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2869 if (gimme != G_ARRAY) {
2870 if (gimme != G_VOID)
2871 XPUSHs(boolSV(max));
2877 mPUSHi(PL_statcache.st_dev);
2878 mPUSHi(PL_statcache.st_ino);
2879 mPUSHu(PL_statcache.st_mode);
2880 mPUSHu(PL_statcache.st_nlink);
2881 #if Uid_t_size > IVSIZE
2882 mPUSHn(PL_statcache.st_uid);
2884 # if Uid_t_sign <= 0
2885 mPUSHi(PL_statcache.st_uid);
2887 mPUSHu(PL_statcache.st_uid);
2890 #if Gid_t_size > IVSIZE
2891 mPUSHn(PL_statcache.st_gid);
2893 # if Gid_t_sign <= 0
2894 mPUSHi(PL_statcache.st_gid);
2896 mPUSHu(PL_statcache.st_gid);
2899 #ifdef USE_STAT_RDEV
2900 mPUSHi(PL_statcache.st_rdev);
2902 PUSHs(newSVpvs_flags("", SVs_TEMP));
2904 #if Off_t_size > IVSIZE
2905 mPUSHn(PL_statcache.st_size);
2907 mPUSHi(PL_statcache.st_size);
2910 mPUSHn(PL_statcache.st_atime);
2911 mPUSHn(PL_statcache.st_mtime);
2912 mPUSHn(PL_statcache.st_ctime);
2914 mPUSHi(PL_statcache.st_atime);
2915 mPUSHi(PL_statcache.st_mtime);
2916 mPUSHi(PL_statcache.st_ctime);
2918 #ifdef USE_STAT_BLOCKS
2919 mPUSHu(PL_statcache.st_blksize);
2920 mPUSHu(PL_statcache.st_blocks);
2922 PUSHs(newSVpvs_flags("", SVs_TEMP));
2923 PUSHs(newSVpvs_flags("", SVs_TEMP));
2929 /* This macro is used by the stacked filetest operators :
2930 * if the previous filetest failed, short-circuit and pass its value.
2931 * Else, discard it from the stack and continue. --rgs
2933 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2934 if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
2935 else { (void)POPs; PUTBACK; } \
2942 /* Not const, because things tweak this below. Not bool, because there's
2943 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2944 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2945 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2946 /* Giving some sort of initial value silences compilers. */
2948 int access_mode = R_OK;
2950 int access_mode = 0;
2953 /* access_mode is never used, but leaving use_access in makes the
2954 conditional compiling below much clearer. */
2957 int stat_mode = S_IRUSR;
2959 bool effective = FALSE;
2962 STACKED_FTEST_CHECK;
2964 switch (PL_op->op_type) {
2966 #if !(defined(HAS_ACCESS) && defined(R_OK))
2972 #if defined(HAS_ACCESS) && defined(W_OK)
2977 stat_mode = S_IWUSR;
2981 #if defined(HAS_ACCESS) && defined(X_OK)
2986 stat_mode = S_IXUSR;
2990 #ifdef PERL_EFF_ACCESS
2993 stat_mode = S_IWUSR;
2997 #ifndef PERL_EFF_ACCESS
3004 #ifdef PERL_EFF_ACCESS
3009 stat_mode = S_IXUSR;
3015 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3016 const char *name = POPpx;
3018 # ifdef PERL_EFF_ACCESS
3019 result = PERL_EFF_ACCESS(name, access_mode);
3021 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3027 result = access(name, access_mode);
3029 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3044 if (cando(stat_mode, effective, &PL_statcache))
3053 const int op_type = PL_op->op_type;
3055 STACKED_FTEST_CHECK;
3060 if (op_type == OP_FTIS)
3063 /* You can't dTARGET inside OP_FTIS, because you'll get
3064 "panic: pad_sv po" - the op is not flagged to have a target. */
3068 #if Off_t_size > IVSIZE
3069 PUSHn(PL_statcache.st_size);
3071 PUSHi(PL_statcache.st_size);
3075 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3078 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3081 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3094 /* I believe that all these three are likely to be defined on most every
3095 system these days. */
3097 if(PL_op->op_type == OP_FTSUID)
3101 if(PL_op->op_type == OP_FTSGID)
3105 if(PL_op->op_type == OP_FTSVTX)
3109 STACKED_FTEST_CHECK;
3114 switch (PL_op->op_type) {
3116 if (PL_statcache.st_uid == PL_uid)
3120 if (PL_statcache.st_uid == PL_euid)
3124 if (PL_statcache.st_size == 0)
3128 if (S_ISSOCK(PL_statcache.st_mode))
3132 if (S_ISCHR(PL_statcache.st_mode))
3136 if (S_ISBLK(PL_statcache.st_mode))
3140 if (S_ISREG(PL_statcache.st_mode))
3144 if (S_ISDIR(PL_statcache.st_mode))
3148 if (S_ISFIFO(PL_statcache.st_mode))
3153 if (PL_statcache.st_mode & S_ISUID)
3159 if (PL_statcache.st_mode & S_ISGID)
3165 if (PL_statcache.st_mode & S_ISVTX)
3176 I32 result = my_lstat();
3180 if (S_ISLNK(PL_statcache.st_mode))
3193 STACKED_FTEST_CHECK;
3195 if (PL_op->op_flags & OPf_REF)
3197 else if (isGV(TOPs))
3199 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3200 gv = (GV*)SvRV(POPs);
3202 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3204 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3205 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3206 else if (tmpsv && SvOK(tmpsv)) {
3207 const char *tmps = SvPV_nolen_const(tmpsv);
3215 if (PerlLIO_isatty(fd))
3220 #if defined(atarist) /* this will work with atariST. Configure will
3221 make guesses for other systems. */
3222 # define FILE_base(f) ((f)->_base)
3223 # define FILE_ptr(f) ((f)->_ptr)
3224 # define FILE_cnt(f) ((f)->_cnt)
3225 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3236 register STDCHAR *s;
3242 STACKED_FTEST_CHECK;
3244 if (PL_op->op_flags & OPf_REF)
3246 else if (isGV(TOPs))
3248 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3249 gv = (GV*)SvRV(POPs);
3255 if (gv == PL_defgv) {
3257 io = GvIO(PL_statgv);
3260 goto really_filename;
3265 PL_laststatval = -1;
3266 sv_setpvn(PL_statname, "", 0);
3267 io = GvIO(PL_statgv);
3269 if (io && IoIFP(io)) {
3270 if (! PerlIO_has_base(IoIFP(io)))
3271 DIE(aTHX_ "-T and -B not implemented on filehandles");
3272 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3273 if (PL_laststatval < 0)
3275 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3276 if (PL_op->op_type == OP_FTTEXT)
3281 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3282 i = PerlIO_getc(IoIFP(io));
3284 (void)PerlIO_ungetc(IoIFP(io),i);
3286 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3288 len = PerlIO_get_bufsiz(IoIFP(io));
3289 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3290 /* sfio can have large buffers - limit to 512 */
3295 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3297 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3299 SETERRNO(EBADF,RMS_IFI);
3307 PL_laststype = OP_STAT;
3308 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3309 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3310 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3312 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3315 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3316 if (PL_laststatval < 0) {
3317 (void)PerlIO_close(fp);
3320 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3321 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3322 (void)PerlIO_close(fp);
3324 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3325 RETPUSHNO; /* special case NFS directories */
3326 RETPUSHYES; /* null file is anything */
3331 /* now scan s to look for textiness */
3332 /* XXX ASCII dependent code */
3334 #if defined(DOSISH) || defined(USEMYBINMODE)
3335 /* ignore trailing ^Z on short files */
3336 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3340 for (i = 0; i < len; i++, s++) {
3341 if (!*s) { /* null never allowed in text */
3346 else if (!(isPRINT(*s) || isSPACE(*s)))
3349 else if (*s & 128) {
3351 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3354 /* utf8 characters don't count as odd */
3355 if (UTF8_IS_START(*s)) {
3356 int ulen = UTF8SKIP(s);
3357 if (ulen < len - i) {
3359 for (j = 1; j < ulen; j++) {
3360 if (!UTF8_IS_CONTINUATION(s[j]))
3363 --ulen; /* loop does extra increment */
3373 *s != '\n' && *s != '\r' && *s != '\b' &&
3374 *s != '\t' && *s != '\f' && *s != 27)
3379 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3390 const char *tmps = NULL;
3394 SV * const sv = POPs;
3395 if (PL_op->op_flags & OPf_SPECIAL) {
3396 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3398 else if (SvTYPE(sv) == SVt_PVGV) {
3401 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
3405 tmps = SvPV_nolen_const(sv);
3409 if( !gv && (!tmps || !*tmps) ) {
3410 HV * const table = GvHVn(PL_envgv);
3413 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3414 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3416 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3421 deprecate("chdir('') or chdir(undef) as chdir()");
3422 tmps = SvPV_nolen_const(*svp);
3426 TAINT_PROPER("chdir");
3431 TAINT_PROPER("chdir");
3434 IO* const io = GvIO(gv);
3437 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3438 } else if (IoIFP(io)) {
3439 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3442 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3443 report_evil_fh(gv, io, PL_op->op_type);
3444 SETERRNO(EBADF, RMS_IFI);
3449 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3450 report_evil_fh(gv, io, PL_op->op_type);
3451 SETERRNO(EBADF,RMS_IFI);
3455 DIE(aTHX_ PL_no_func, "fchdir");
3459 PUSHi( PerlDir_chdir(tmps) >= 0 );
3461 /* Clear the DEFAULT element of ENV so we'll get the new value
3463 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3470 dVAR; dSP; dMARK; dTARGET;
3471 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3482 char * const tmps = POPpx;
3483 TAINT_PROPER("chroot");
3484 PUSHi( chroot(tmps) >= 0 );
3487 DIE(aTHX_ PL_no_func, "chroot");
3495 const char * const tmps2 = POPpconstx;
3496 const char * const tmps = SvPV_nolen_const(TOPs);
3497 TAINT_PROPER("rename");
3499 anum = PerlLIO_rename(tmps, tmps2);
3501 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3502 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3505 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3506 (void)UNLINK(tmps2);
3507 if (!(anum = link(tmps, tmps2)))
3508 anum = UNLINK(tmps);
3516 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3520 const int op_type = PL_op->op_type;
3524 if (op_type == OP_LINK)
3525 DIE(aTHX_ PL_no_func, "link");
3527 # ifndef HAS_SYMLINK
3528 if (op_type == OP_SYMLINK)
3529 DIE(aTHX_ PL_no_func, "symlink");
3533 const char * const tmps2 = POPpconstx;
3534 const char * const tmps = SvPV_nolen_const(TOPs);
3535 TAINT_PROPER(PL_op_desc[op_type]);
3537 # if defined(HAS_LINK)
3538 # if defined(HAS_SYMLINK)
3539 /* Both present - need to choose which. */
3540 (op_type == OP_LINK) ?
3541 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3543 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3544 PerlLIO_link(tmps, tmps2);
3547 # if defined(HAS_SYMLINK)
3548 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3549 symlink(tmps, tmps2);
3554 SETi( result >= 0 );
3561 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3572 char buf[MAXPATHLEN];
3575 #ifndef INCOMPLETE_TAINTS
3579 len = readlink(tmps, buf, sizeof(buf) - 1);
3587 RETSETUNDEF; /* just pretend it's a normal file */
3591 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3593 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3595 char * const save_filename = filename;
3600 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3602 PERL_ARGS_ASSERT_DOONELINER;
3604 Newx(cmdline, size, char);
3605 my_strlcpy(cmdline, cmd, size);
3606 my_strlcat(cmdline, " ", size);
3607 for (s = cmdline + strlen(cmdline); *filename; ) {
3611 if (s - cmdline < size)
3612 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3613 myfp = PerlProc_popen(cmdline, "r");
3617 SV * const tmpsv = sv_newmortal();
3618 /* Need to save/restore 'PL_rs' ?? */
3619 s = sv_gets(tmpsv, myfp, 0);
3620 (void)PerlProc_pclose(myfp);
3624 #ifdef HAS_SYS_ERRLIST
3629 /* you don't see this */
3630 const char * const errmsg =
3631 #ifdef HAS_SYS_ERRLIST
3639 if (instr(s, errmsg)) {
3646 #define EACCES EPERM
3648 if (instr(s, "cannot make"))
3649 SETERRNO(EEXIST,RMS_FEX);
3650 else if (instr(s, "existing file"))
3651 SETERRNO(EEXIST,RMS_FEX);
3652 else if (instr(s, "ile exists"))
3653 SETERRNO(EEXIST,RMS_FEX);
3654 else if (instr(s, "non-exist"))
3655 SETERRNO(ENOENT,RMS_FNF);
3656 else if (instr(s, "does not exist"))
3657 SETERRNO(ENOENT,RMS_FNF);
3658 else if (instr(s, "not empty"))
3659 SETERRNO(EBUSY,SS_DEVOFFLINE);
3660 else if (instr(s, "cannot access"))
3661 SETERRNO(EACCES,RMS_PRV);
3663 SETERRNO(EPERM,RMS_PRV);
3666 else { /* some mkdirs return no failure indication */
3667 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3668 if (PL_op->op_type == OP_RMDIR)
3673 SETERRNO(EACCES,RMS_PRV); /* a guess */
3682 /* This macro removes trailing slashes from a directory name.
3683 * Different operating and file systems take differently to
3684 * trailing slashes. According to POSIX 1003.1 1996 Edition
3685 * any number of trailing slashes should be allowed.
3686 * Thusly we snip them away so that even non-conforming
3687 * systems are happy.
3688 * We should probably do this "filtering" for all
3689 * the functions that expect (potentially) directory names:
3690 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3691 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3693 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3694 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3697 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3698 (tmps) = savepvn((tmps), (len)); \
3708 const int mode = (MAXARG > 1) ? POPi : 0777;
3710 TRIMSLASHES(tmps,len,copy);
3712 TAINT_PROPER("mkdir");
3714 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3718 SETi( dooneliner("mkdir", tmps) );
3719 oldumask = PerlLIO_umask(0);
3720 PerlLIO_umask(oldumask);
3721 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3736 TRIMSLASHES(tmps,len,copy);
3737 TAINT_PROPER("rmdir");
3739 SETi( PerlDir_rmdir(tmps) >= 0 );
3741 SETi( dooneliner("rmdir", tmps) );
3748 /* Directory calls. */
3752 #if defined(Direntry_t) && defined(HAS_READDIR)
3754 const char * const dirname = POPpconstx;
3755 GV * const gv = (GV*)POPs;
3756 register IO * const io = GvIOn(gv);
3761 if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED))
3762 Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3763 "Opening filehandle %s also as a directory", GvENAME(gv));
3765 PerlDir_close(IoDIRP(io));
3766 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3772 SETERRNO(EBADF,RMS_DIR);
3775 DIE(aTHX_ PL_no_dir_func, "opendir");
3781 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3782 DIE(aTHX_ PL_no_dir_func, "readdir");
3784 #if !defined(I_DIRENT) && !defined(VMS)
3785 Direntry_t *readdir (DIR *);
3791 const I32 gimme = GIMME;
3792 GV * const gv = (GV *)POPs;
3793 register const Direntry_t *dp;
3794 register IO * const io = GvIOn(gv);
3796 if (!io || !IoDIRP(io)) {
3797 if(ckWARN(WARN_IO)) {
3798 Perl_warner(aTHX_ packWARN(WARN_IO),
3799 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3805 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3809 sv = newSVpvn(dp->d_name, dp->d_namlen);
3811 sv = newSVpv(dp->d_name, 0);
3813 #ifndef INCOMPLETE_TAINTS
3814 if (!(IoFLAGS(io) & IOf_UNTAINT))
3818 } while (gimme == G_ARRAY);
3820 if (!dp && gimme != G_ARRAY)
3827 SETERRNO(EBADF,RMS_ISI);
3828 if (GIMME == G_ARRAY)
3837 #if defined(HAS_TELLDIR) || defined(telldir)
3839 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3840 /* XXX netbsd still seemed to.
3841 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3842 --JHI 1999-Feb-02 */
3843 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3844 long telldir (DIR *);
3846 GV * const gv = (GV*)POPs;
3847 register IO * const io = GvIOn(gv);
3849 if (!io || !IoDIRP(io)) {
3850 if(ckWARN(WARN_IO)) {
3851 Perl_warner(aTHX_ packWARN(WARN_IO),
3852 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3857 PUSHi( PerlDir_tell(IoDIRP(io)) );
3861 SETERRNO(EBADF,RMS_ISI);
3864 DIE(aTHX_ PL_no_dir_func, "telldir");
3870 #if defined(HAS_SEEKDIR) || defined(seekdir)
3872 const long along = POPl;
3873 GV * const gv = (GV*)POPs;
3874 register IO * const io = GvIOn(gv);
3876 if (!io || !IoDIRP(io)) {
3877 if(ckWARN(WARN_IO)) {
3878 Perl_warner(aTHX_ packWARN(WARN_IO),
3879 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3883 (void)PerlDir_seek(IoDIRP(io), along);
3888 SETERRNO(EBADF,RMS_ISI);
3891 DIE(aTHX_ PL_no_dir_func, "seekdir");
3897 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3899 GV * const gv = (GV*)POPs;
3900 register IO * const io = GvIOn(gv);
3902 if (!io || !IoDIRP(io)) {
3903 if(ckWARN(WARN_IO)) {
3904 Perl_warner(aTHX_ packWARN(WARN_IO),
3905 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3909 (void)PerlDir_rewind(IoDIRP(io));
3913 SETERRNO(EBADF,RMS_ISI);
3916 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3922 #if defined(Direntry_t) && defined(HAS_READDIR)
3924 GV * const gv = (GV*)POPs;
3925 register IO * const io = GvIOn(gv);
3927 if (!io || !IoDIRP(io)) {
3928 if(ckWARN(WARN_IO)) {
3929 Perl_warner(aTHX_ packWARN(WARN_IO),
3930 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3934 #ifdef VOID_CLOSEDIR
3935 PerlDir_close(IoDIRP(io));
3937 if (PerlDir_close(IoDIRP(io)) < 0) {
3938 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3947 SETERRNO(EBADF,RMS_IFI);
3950 DIE(aTHX_ PL_no_dir_func, "closedir");
3954 /* Process control. */
3963 PERL_FLUSHALL_FOR_CHILD;
3964 childpid = PerlProc_fork();
3968 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3970 SvREADONLY_off(GvSV(tmpgv));
3971 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3972 SvREADONLY_on(GvSV(tmpgv));
3974 #ifdef THREADS_HAVE_PIDS
3975 PL_ppid = (IV)getppid();
3977 #ifdef PERL_USES_PL_PIDSTATUS
3978 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3984 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3989 PERL_FLUSHALL_FOR_CHILD;
3990 childpid = PerlProc_fork();
3996 DIE(aTHX_ PL_no_func, "fork");
4003 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4008 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4009 childpid = wait4pid(-1, &argflags, 0);
4011 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4016 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4017 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4018 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4020 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4025 DIE(aTHX_ PL_no_func, "wait");
4031 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4033 const int optype = POPi;
4034 const Pid_t pid = TOPi;
4038 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4039 result = wait4pid(pid, &argflags, optype);
4041 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4046 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4047 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4048 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4050 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4055 DIE(aTHX_ PL_no_func, "waitpid");
4061 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4062 #if defined(__LIBCATAMOUNT__)
4063 PL_statusvalue = -1;
4072 while (++MARK <= SP) {
4073 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4078 TAINT_PROPER("system");
4080 PERL_FLUSHALL_FOR_CHILD;
4081 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4087 if (PerlProc_pipe(pp) >= 0)
4089 while ((childpid = PerlProc_fork()) == -1) {
4090 if (errno != EAGAIN) {
4095 PerlLIO_close(pp[0]);
4096 PerlLIO_close(pp[1]);
4103 Sigsave_t ihand,qhand; /* place to save signals during system() */
4107 PerlLIO_close(pp[1]);
4109 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4110 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4113 result = wait4pid(childpid, &status, 0);
4114 } while (result == -1 && errno == EINTR);
4116 (void)rsignal_restore(SIGINT, &ihand);
4117 (void)rsignal_restore(SIGQUIT, &qhand);
4119 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4120 do_execfree(); /* free any memory child malloced on fork */
4127 while (n < sizeof(int)) {
4128 n1 = PerlLIO_read(pp[0],
4129 (void*)(((char*)&errkid)+n),
4135 PerlLIO_close(pp[0]);
4136 if (n) { /* Error */
4137 if (n != sizeof(int))
4138 DIE(aTHX_ "panic: kid popen errno read");
4139 errno = errkid; /* Propagate errno from kid */
4140 STATUS_NATIVE_CHILD_SET(-1);
4143 XPUSHi(STATUS_CURRENT);
4147 PerlLIO_close(pp[0]);
4148 #if defined(HAS_FCNTL) && defined(F_SETFD)
4149 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4152 if (PL_op->op_flags & OPf_STACKED) {
4153 SV * const really = *++MARK;
4154 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4156 else if (SP - MARK != 1)
4157 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4159 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4163 #else /* ! FORK or VMS or OS/2 */
4166 if (PL_op->op_flags & OPf_STACKED) {
4167 SV * const really = *++MARK;
4168 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4169 value = (I32)do_aspawn(really, MARK, SP);
4171 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4174 else if (SP - MARK != 1) {
4175 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4176 value = (I32)do_aspawn(NULL, MARK, SP);
4178 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4182 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4184 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4186 STATUS_NATIVE_CHILD_SET(value);
4189 XPUSHi(result ? value : STATUS_CURRENT);
4190 #endif /* !FORK or VMS or OS/2 */
4197 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4202 while (++MARK <= SP) {
4203 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4208 TAINT_PROPER("exec");
4210 PERL_FLUSHALL_FOR_CHILD;
4211 if (PL_op->op_flags & OPf_STACKED) {
4212 SV * const really = *++MARK;
4213 value = (I32)do_aexec(really, MARK, SP);
4215 else if (SP - MARK != 1)
4217 value = (I32)vms_do_aexec(NULL, MARK, SP);
4221 (void ) do_aspawn(NULL, MARK, SP);
4225 value = (I32)do_aexec(NULL, MARK, SP);
4230 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4233 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4236 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4250 # ifdef THREADS_HAVE_PIDS
4251 if (PL_ppid != 1 && getppid() == 1)
4252 /* maybe the parent process has died. Refresh ppid cache */
4256 XPUSHi( getppid() );
4260 DIE(aTHX_ PL_no_func, "getppid");
4269 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4272 pgrp = (I32)BSD_GETPGRP(pid);
4274 if (pid != 0 && pid != PerlProc_getpid())
4275 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4281 DIE(aTHX_ PL_no_func, "getpgrp()");
4300 TAINT_PROPER("setpgrp");
4302 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4304 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4305 || (pid != 0 && pid != PerlProc_getpid()))
4307 DIE(aTHX_ "setpgrp can't take arguments");
4309 SETi( setpgrp() >= 0 );
4310 #endif /* USE_BSDPGRP */
4313 DIE(aTHX_ PL_no_func, "setpgrp()");
4319 #ifdef HAS_GETPRIORITY
4321 const int who = POPi;
4322 const int which = TOPi;
4323 SETi( getpriority(which, who) );
4326 DIE(aTHX_ PL_no_func, "getpriority()");
4332 #ifdef HAS_SETPRIORITY
4334 const int niceval = POPi;
4335 const int who = POPi;
4336 const int which = TOPi;
4337 TAINT_PROPER("setpriority");
4338 SETi( setpriority(which, who, niceval) >= 0 );
4341 DIE(aTHX_ PL_no_func, "setpriority()");
4351 XPUSHn( time(NULL) );
4353 XPUSHi( time(NULL) );
4365 (void)PerlProc_times(&PL_timesbuf);
4367 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4368 /* struct tms, though same data */
4372 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4373 if (GIMME == G_ARRAY) {
4374 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4375 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4376 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4384 if (GIMME == G_ARRAY) {
4391 DIE(aTHX_ "times not implemented");
4393 #endif /* HAS_TIMES */
4396 #ifdef LOCALTIME_EDGECASE_BROKEN
4397 static struct tm *S_my_localtime (pTHX_ Time_t *tp)
4402 /* No workarounds in the valid range */
4403 if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4404 return (localtime (tp));
4406 /* This edge case is to workaround the undefined behaviour, where the
4407 * TIMEZONE makes the time go beyond the defined range.
4408 * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4409 * If there is a negative offset in TZ, like MET-1METDST, some broken
4410 * implementations of localtime () (like AIX 5.2) barf with bogus
4412 * 0x7fffffff gmtime 2038-01-19 03:14:07
4413 * 0x7fffffff localtime 1901-12-13 21:45:51
4414 * 0x7fffffff mylocaltime 2038-01-19 04:14:07
4415 * 0x3c19137f gmtime 2001-12-13 20:45:51
4416 * 0x3c19137f localtime 2001-12-13 21:45:51
4417 * 0x3c19137f mylocaltime 2001-12-13 21:45:51
4418 * Given that legal timezones are typically between GMT-12 and GMT+12
4419 * we turn back the clock 23 hours before calling the localtime
4420 * function, and add those to the return value. This will never cause
4421 * day wrapping problems, since the edge case is Tue Jan *19*
4423 T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4426 if (P->tm_hour >= 24) {
4428 P->tm_mday++; /* 18 -> 19 */
4429 P->tm_wday++; /* Mon -> Tue */
4430 P->tm_yday++; /* 18 -> 19 */
4433 } /* S_my_localtime */
4441 const struct tm *tmbuf;
4442 static const char * const dayname[] =
4443 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4444 static const char * const monname[] =
4445 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4446 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4452 when = (Time_t)SvNVx(POPs);
4454 when = (Time_t)SvIVx(POPs);
4457 if (PL_op->op_type == OP_LOCALTIME)
4458 #ifdef LOCALTIME_EDGECASE_BROKEN
4459 tmbuf = S_my_localtime(aTHX_ &when);
4461 tmbuf = localtime(&when);
4464 tmbuf = gmtime(&when);
4466 if (GIMME != G_ARRAY) {
4472 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4473 dayname[tmbuf->tm_wday],
4474 monname[tmbuf->tm_mon],
4479 tmbuf->tm_year + 1900);
4485 mPUSHi(tmbuf->tm_sec);
4486 mPUSHi(tmbuf->tm_min);
4487 mPUSHi(tmbuf->tm_hour);
4488 mPUSHi(tmbuf->tm_mday);
4489 mPUSHi(tmbuf->tm_mon);
4490 mPUSHi(tmbuf->tm_year);
4491 mPUSHi(tmbuf->tm_wday);
4492 mPUSHi(tmbuf->tm_yday);
4493 mPUSHi(tmbuf->tm_isdst);
4504 anum = alarm((unsigned int)anum);
4511 DIE(aTHX_ PL_no_func, "alarm");
4522 (void)time(&lasttime);
4527 PerlProc_sleep((unsigned int)duration);
4530 XPUSHi(when - lasttime);
4534 /* Shared memory. */
4535 /* Merged with some message passing. */
4539 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4540 dVAR; dSP; dMARK; dTARGET;
4541 const int op_type = PL_op->op_type;
4546 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4549 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4552 value = (I32)(do_semop(MARK, SP) >= 0);
4555 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4571 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4572 dVAR; dSP; dMARK; dTARGET;
4573 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4580 DIE(aTHX_ "System V IPC is not implemented on this machine");
4586 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4587 dVAR; dSP; dMARK; dTARGET;
4588 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4596 PUSHp(zero_but_true, ZBTLEN);
4604 /* I can't const this further without getting warnings about the types of
4605 various arrays passed in from structures. */
4607 S_space_join_names_mortal(pTHX_ char *const *array)
4611 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4613 if (array && *array) {
4614 target = newSVpvs_flags("", SVs_TEMP);
4616 sv_catpv(target, *array);
4619 sv_catpvs(target, " ");
4622 target = sv_mortalcopy(&PL_sv_no);
4627 /* Get system info. */
4631 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4633 I32 which = PL_op->op_type;
4634 register char **elem;
4636 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4637 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4638 struct hostent *gethostbyname(Netdb_name_t);
4639 struct hostent *gethostent(void);
4641 struct hostent *hent;
4645 if (which == OP_GHBYNAME) {
4646 #ifdef HAS_GETHOSTBYNAME
4647 const char* const name = POPpbytex;
4648 hent = PerlSock_gethostbyname(name);
4650 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4653 else if (which == OP_GHBYADDR) {
4654 #ifdef HAS_GETHOSTBYADDR
4655 const int addrtype = POPi;
4656 SV * const addrsv = POPs;
4658 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4660 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4662 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4666 #ifdef HAS_GETHOSTENT
4667 hent = PerlSock_gethostent();
4669 DIE(aTHX_ PL_no_sock_func, "gethostent");
4672 #ifdef HOST_NOT_FOUND
4674 #ifdef USE_REENTRANT_API
4675 # ifdef USE_GETHOSTENT_ERRNO
4676 h_errno = PL_reentrant_buffer->_gethostent_errno;
4679 STATUS_UNIX_SET(h_errno);
4683 if (GIMME != G_ARRAY) {
4684 PUSHs(sv = sv_newmortal());
4686 if (which == OP_GHBYNAME) {
4688 sv_setpvn(sv, hent->h_addr, hent->h_length);
4691 sv_setpv(sv, (char*)hent->h_name);
4697 mPUSHs(newSVpv((char*)hent->h_name, 0));
4698 PUSHs(space_join_names_mortal(hent->h_aliases));
4699 mPUSHi(hent->h_addrtype);
4700 len = hent->h_length;
4703 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4704 mXPUSHp(*elem, len);
4708 mPUSHp(hent->h_addr, len);
4710 PUSHs(sv_mortalcopy(&PL_sv_no));
4715 DIE(aTHX_ PL_no_sock_func, "gethostent");
4721 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4723 I32 which = PL_op->op_type;
4725 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4726 struct netent *getnetbyaddr(Netdb_net_t, int);
4727 struct netent *getnetbyname(Netdb_name_t);
4728 struct netent *getnetent(void);
4730 struct netent *nent;
4732 if (which == OP_GNBYNAME){
4733 #ifdef HAS_GETNETBYNAME
4734 const char * const name = POPpbytex;
4735 nent = PerlSock_getnetbyname(name);
4737 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4740 else if (which == OP_GNBYADDR) {
4741 #ifdef HAS_GETNETBYADDR
4742 const int addrtype = POPi;
4743 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4744 nent = PerlSock_getnetbyaddr(addr, addrtype);
4746 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4750 #ifdef HAS_GETNETENT
4751 nent = PerlSock_getnetent();
4753 DIE(aTHX_ PL_no_sock_func, "getnetent");
4756 #ifdef HOST_NOT_FOUND
4758 #ifdef USE_REENTRANT_API
4759 # ifdef USE_GETNETENT_ERRNO
4760 h_errno = PL_reentrant_buffer->_getnetent_errno;
4763 STATUS_UNIX_SET(h_errno);
4768 if (GIMME != G_ARRAY) {
4769 PUSHs(sv = sv_newmortal());
4771 if (which == OP_GNBYNAME)
4772 sv_setiv(sv, (IV)nent->n_net);
4774 sv_setpv(sv, nent->n_name);
4780 mPUSHs(newSVpv(nent->n_name, 0));
4781 PUSHs(space_join_names_mortal(nent->n_aliases));
4782 mPUSHi(nent->n_addrtype);
4783 mPUSHi(nent->n_net);
4788 DIE(aTHX_ PL_no_sock_func, "getnetent");
4794 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4796 I32 which = PL_op->op_type;
4798 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4799 struct protoent *getprotobyname(Netdb_name_t);
4800 struct protoent *getprotobynumber(int);
4801 struct protoent *getprotoent(void);
4803 struct protoent *pent;
4805 if (which == OP_GPBYNAME) {
4806 #ifdef HAS_GETPROTOBYNAME
4807 const char* const name = POPpbytex;
4808 pent = PerlSock_getprotobyname(name);
4810 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4813 else if (which == OP_GPBYNUMBER) {
4814 #ifdef HAS_GETPROTOBYNUMBER
4815 const int number = POPi;
4816 pent = PerlSock_getprotobynumber(number);
4818 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4822 #ifdef HAS_GETPROTOENT
4823 pent = PerlSock_getprotoent();
4825 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4829 if (GIMME != G_ARRAY) {
4830 PUSHs(sv = sv_newmortal());
4832 if (which == OP_GPBYNAME)
4833 sv_setiv(sv, (IV)pent->p_proto);
4835 sv_setpv(sv, pent->p_name);
4841 mPUSHs(newSVpv(pent->p_name, 0));
4842 PUSHs(space_join_names_mortal(pent->p_aliases));
4843 mPUSHi(pent->p_proto);
4848 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4854 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4856 I32 which = PL_op->op_type;
4858 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4859 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4860 struct servent *getservbyport(int, Netdb_name_t);
4861 struct servent *getservent(void);
4863 struct servent *sent;
4865 if (which == OP_GSBYNAME) {
4866 #ifdef HAS_GETSERVBYNAME
4867 const char * const proto = POPpbytex;
4868 const char * const name = POPpbytex;
4869 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4871 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4874 else if (which == OP_GSBYPORT) {
4875 #ifdef HAS_GETSERVBYPORT
4876 const char * const proto = POPpbytex;
4877 unsigned short port = (unsigned short)POPu;
4879 port = PerlSock_htons(port);
4881 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4883 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4887 #ifdef HAS_GETSERVENT
4888 sent = PerlSock_getservent();
4890 DIE(aTHX_ PL_no_sock_func, "getservent");
4894 if (GIMME != G_ARRAY) {
4895 PUSHs(sv = sv_newmortal());
4897 if (which == OP_GSBYNAME) {
4899 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4901 sv_setiv(sv, (IV)(sent->s_port));
4905 sv_setpv(sv, sent->s_name);
4911 mPUSHs(newSVpv(sent->s_name, 0));
4912 PUSHs(space_join_names_mortal(sent->s_aliases));
4914 mPUSHi(PerlSock_ntohs(sent->s_port));
4916 mPUSHi(sent->s_port);
4918 mPUSHs(newSVpv(sent->s_proto, 0));
4923 DIE(aTHX_ PL_no_sock_func, "getservent");
4929 #ifdef HAS_SETHOSTENT
4931 PerlSock_sethostent(TOPi);
4934 DIE(aTHX_ PL_no_sock_func, "sethostent");
4940 #ifdef HAS_SETNETENT
4942 PerlSock_setnetent(TOPi);
4945 DIE(aTHX_ PL_no_sock_func, "setnetent");
4951 #ifdef HAS_SETPROTOENT
4953 PerlSock_setprotoent(TOPi);
4956 DIE(aTHX_ PL_no_sock_func, "setprotoent");
4962 #ifdef HAS_SETSERVENT
4964 PerlSock_setservent(TOPi);
4967 DIE(aTHX_ PL_no_sock_func, "setservent");
4973 #ifdef HAS_ENDHOSTENT
4975 PerlSock_endhostent();
4979 DIE(aTHX_ PL_no_sock_func, "endhostent");
4985 #ifdef HAS_ENDNETENT
4987 PerlSock_endnetent();
4991 DIE(aTHX_ PL_no_sock_func, "endnetent");
4997 #ifdef HAS_ENDPROTOENT
4999 PerlSock_endprotoent();
5003 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5009 #ifdef HAS_ENDSERVENT
5011 PerlSock_endservent();
5015 DIE(aTHX_ PL_no_sock_func, "endservent");
5023 I32 which = PL_op->op_type;
5025 struct passwd *pwent = NULL;
5027 * We currently support only the SysV getsp* shadow password interface.
5028 * The interface is declared in <shadow.h> and often one needs to link
5029 * with -lsecurity or some such.
5030 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5033 * AIX getpwnam() is clever enough to return the encrypted password
5034 * only if the caller (euid?) is root.
5036 * There are at least three other shadow password APIs. Many platforms
5037 * seem to contain more than one interface for accessing the shadow
5038 * password databases, possibly for compatibility reasons.
5039 * The getsp*() is by far he simplest one, the other two interfaces
5040 * are much more complicated, but also very similar to each other.
5045 * struct pr_passwd *getprpw*();
5046 * The password is in
5047 * char getprpw*(...).ufld.fd_encrypt[]
5048 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5053 * struct es_passwd *getespw*();
5054 * The password is in
5055 * char *(getespw*(...).ufld.fd_encrypt)
5056 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5059 * struct userpw *getuserpw();
5060 * The password is in
5061 * char *(getuserpw(...)).spw_upw_passwd
5062 * (but the de facto standard getpwnam() should work okay)
5064 * Mention I_PROT here so that Configure probes for it.
5066 * In HP-UX for getprpw*() the manual page claims that one should include
5067 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5068 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5069 * and pp_sys.c already includes <shadow.h> if there is such.
5071 * Note that <sys/security.h> is already probed for, but currently
5072 * it is only included in special cases.
5074 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5075 * be preferred interface, even though also the getprpw*() interface
5076 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5077 * One also needs to call set_auth_parameters() in main() before
5078 * doing anything else, whether one is using getespw*() or getprpw*().
5080 * Note that accessing the shadow databases can be magnitudes
5081 * slower than accessing the standard databases.
5086 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5087 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5088 * the pw_comment is left uninitialized. */
5089 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5095 const char* const name = POPpbytex;
5096 pwent = getpwnam(name);
5102 pwent = getpwuid(uid);
5106 # ifdef HAS_GETPWENT
5108 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5109 if (pwent) pwent = getpwnam(pwent->pw_name);
5112 DIE(aTHX_ PL_no_func, "getpwent");
5118 if (GIMME != G_ARRAY) {
5119 PUSHs(sv = sv_newmortal());
5121 if (which == OP_GPWNAM)
5122 # if Uid_t_sign <= 0
5123 sv_setiv(sv, (IV)pwent->pw_uid);
5125 sv_setuv(sv, (UV)pwent->pw_uid);
5128 sv_setpv(sv, pwent->pw_name);
5134 mPUSHs(newSVpv(pwent->pw_name, 0));
5138 /* If we have getspnam(), we try to dig up the shadow
5139 * password. If we are underprivileged, the shadow
5140 * interface will set the errno to EACCES or similar,
5141 * and return a null pointer. If this happens, we will
5142 * use the dummy password (usually "*" or "x") from the
5143 * standard password database.
5145 * In theory we could skip the shadow call completely
5146 * if euid != 0 but in practice we cannot know which
5147 * security measures are guarding the shadow databases
5148 * on a random platform.
5150 * Resist the urge to use additional shadow interfaces.
5151 * Divert the urge to writing an extension instead.
5154 /* Some AIX setups falsely(?) detect some getspnam(), which
5155 * has a different API than the Solaris/IRIX one. */
5156 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5158 const int saverrno = errno;
5159 const struct spwd * const spwent = getspnam(pwent->pw_name);
5160 /* Save and restore errno so that
5161 * underprivileged attempts seem
5162 * to have never made the unsccessful
5163 * attempt to retrieve the shadow password. */
5165 if (spwent && spwent->sp_pwdp)
5166 sv_setpv(sv, spwent->sp_pwdp);
5170 if (!SvPOK(sv)) /* Use the standard password, then. */
5171 sv_setpv(sv, pwent->pw_passwd);
5174 # ifndef INCOMPLETE_TAINTS
5175 /* passwd is tainted because user himself can diddle with it.
5176 * admittedly not much and in a very limited way, but nevertheless. */
5180 # if Uid_t_sign <= 0
5181 mPUSHi(pwent->pw_uid);
5183 mPUSHu(pwent->pw_uid);
5186 # if Uid_t_sign <= 0
5187 mPUSHi(pwent->pw_gid);
5189 mPUSHu(pwent->pw_gid);
5191 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5192 * because of the poor interface of the Perl getpw*(),
5193 * not because there's some standard/convention saying so.
5194 * A better interface would have been to return a hash,
5195 * but we are accursed by our history, alas. --jhi. */
5197 mPUSHi(pwent->pw_change);
5200 mPUSHi(pwent->pw_quota);
5203 mPUSHs(newSVpv(pwent->pw_age, 0));
5205 /* I think that you can never get this compiled, but just in case. */
5206 PUSHs(sv_mortalcopy(&PL_sv_no));
5211 /* pw_class and pw_comment are mutually exclusive--.
5212 * see the above note for pw_change, pw_quota, and pw_age. */
5214 mPUSHs(newSVpv(pwent->pw_class, 0));
5217 mPUSHs(newSVpv(pwent->pw_comment, 0));
5219 /* I think that you can never get this compiled, but just in case. */
5220 PUSHs(sv_mortalcopy(&PL_sv_no));
5225 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5227 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5229 # ifndef INCOMPLETE_TAINTS
5230 /* pw_gecos is tainted because user himself can diddle with it. */
5234 mPUSHs(newSVpv(pwent->pw_dir, 0));
5236 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5237 # ifndef INCOMPLETE_TAINTS
5238 /* pw_shell is tainted because user himself can diddle with it. */
5243 mPUSHi(pwent->pw_expire);
5248 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5254 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5259 DIE(aTHX_ PL_no_func, "setpwent");
5265 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5270 DIE(aTHX_ PL_no_func, "endpwent");
5278 const I32 which = PL_op->op_type;
5279 const struct group *grent;
5281 if (which == OP_GGRNAM) {
5282 const char* const name = POPpbytex;
5283 grent = (const struct group *)getgrnam(name);
5285 else if (which == OP_GGRGID) {
5286 const Gid_t gid = POPi;
5287 grent = (const struct group *)getgrgid(gid);
5291 grent = (struct group *)getgrent();
5293 DIE(aTHX_ PL_no_func, "getgrent");
5297 if (GIMME != G_ARRAY) {
5298 SV * const sv = sv_newmortal();
5302 if (which == OP_GGRNAM)
5303 sv_setiv(sv, (IV)grent->gr_gid);
5305 sv_setpv(sv, grent->gr_name);
5311 mPUSHs(newSVpv(grent->gr_name, 0));
5314 mPUSHs(newSVpv(grent->gr_passwd, 0));
5316 PUSHs(sv_mortalcopy(&PL_sv_no));
5319 mPUSHi(grent->gr_gid);
5321 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5322 /* In UNICOS/mk (_CRAYMPP) the multithreading
5323 * versions (getgrnam_r, getgrgid_r)
5324 * seem to return an illegal pointer
5325 * as the group members list, gr_mem.
5326 * getgrent() doesn't even have a _r version
5327 * but the gr_mem is poisonous anyway.
5328 * So yes, you cannot get the list of group
5329 * members if building multithreaded in UNICOS/mk. */
5330 PUSHs(space_join_names_mortal(grent->gr_mem));
5336 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5342 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5347 DIE(aTHX_ PL_no_func, "setgrent");
5353 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5358 DIE(aTHX_ PL_no_func, "endgrent");
5368 if (!(tmps = PerlProc_getlogin()))
5370 PUSHp(tmps, strlen(tmps));
5373 DIE(aTHX_ PL_no_func, "getlogin");
5377 /* Miscellaneous. */
5382 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5383 register I32 items = SP - MARK;
5384 unsigned long a[20];
5389 while (++MARK <= SP) {
5390 if (SvTAINTED(*MARK)) {
5396 TAINT_PROPER("syscall");
5399 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5400 * or where sizeof(long) != sizeof(char*). But such machines will
5401 * not likely have syscall implemented either, so who cares?
5403 while (++MARK <= SP) {
5404 if (SvNIOK(*MARK) || !i)
5405 a[i++] = SvIV(*MARK);
5406 else if (*MARK == &PL_sv_undef)
5409 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5415 DIE(aTHX_ "Too many args to syscall");
5417 DIE(aTHX_ "Too few args to syscall");
5419 retval = syscall(a[0]);
5422 retval = syscall(a[0],a[1]);
5425 retval = syscall(a[0],a[1],a[2]);
5428 retval = syscall(a[0],a[1],a[2],a[3]);
5431 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5434 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5437 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5440 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5444 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5447 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5450 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5454 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5458 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5462 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5463 a[10],a[11],a[12],a[13]);
5465 #endif /* atarist */
5471 DIE(aTHX_ PL_no_func, "syscall");
5475 #ifdef FCNTL_EMULATE_FLOCK
5477 /* XXX Emulate flock() with fcntl().
5478 What's really needed is a good file locking module.
5482 fcntl_emulate_flock(int fd, int operation)
5486 switch (operation & ~LOCK_NB) {
5488 flock.l_type = F_RDLCK;
5491 flock.l_type = F_WRLCK;
5494 flock.l_type = F_UNLCK;
5500 flock.l_whence = SEEK_SET;
5501 flock.l_start = flock.l_len = (Off_t)0;
5503 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5506 #endif /* FCNTL_EMULATE_FLOCK */
5508 #ifdef LOCKF_EMULATE_FLOCK
5510 /* XXX Emulate flock() with lockf(). This is just to increase
5511 portability of scripts. The calls are not completely
5512 interchangeable. What's really needed is a good file
5516 /* The lockf() constants might have been defined in <unistd.h>.
5517 Unfortunately, <unistd.h> causes troubles on some mixed
5518 (BSD/POSIX) systems, such as SunOS 4.1.3.
5520 Further, the lockf() constants aren't POSIX, so they might not be
5521 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5522 just stick in the SVID values and be done with it. Sigh.
5526 # define F_ULOCK 0 /* Unlock a previously locked region */
5529 # define F_LOCK 1 /* Lock a region for exclusive use */
5532 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5535 # define F_TEST 3 /* Test a region for other processes locks */
5539 lockf_emulate_flock(int fd, int operation)
5542 const int save_errno = errno;
5545 /* flock locks entire file so for lockf we need to do the same */
5546 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5547 if (pos > 0) /* is seekable and needs to be repositioned */
5548 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5549 pos = -1; /* seek failed, so don't seek back afterwards */
5552 switch (operation) {
5554 /* LOCK_SH - get a shared lock */
5556 /* LOCK_EX - get an exclusive lock */
5558 i = lockf (fd, F_LOCK, 0);
5561 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5562 case LOCK_SH|LOCK_NB:
5563 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5564 case LOCK_EX|LOCK_NB:
5565 i = lockf (fd, F_TLOCK, 0);
5567 if ((errno == EAGAIN) || (errno == EACCES))
5568 errno = EWOULDBLOCK;
5571 /* LOCK_UN - unlock (non-blocking is a no-op) */
5573 case LOCK_UN|LOCK_NB:
5574 i = lockf (fd, F_ULOCK, 0);
5577 /* Default - can't decipher operation */
5584 if (pos > 0) /* need to restore position of the handle */
5585 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5590 #endif /* LOCKF_EMULATE_FLOCK */
5594 * c-indentation-style: bsd
5596 * indent-tabs-mode: t
5599 * ex: set ts=8 sts=4 sw=4 noet: