3 * Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 * 2004, 2005, 2006, 2007, 2008 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.
17 * [p.945 of _The Lord of the Rings_, VI/iii: "Mount Doom"]
20 /* This file contains system pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
26 * By 'system', we mean ops which interact with the OS, such as pp_open().
30 #define PERL_IN_PP_SYS_C
36 /* Shadow password support for solaris - pdo@cs.umd.edu
37 * Not just Solaris: at least HP-UX, IRIX, Linux.
38 * The API is from SysV.
40 * There are at least two more shadow interfaces,
41 * see the comments in pp_gpwent().
45 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
46 * and another MAXINT from "perl.h" <- <sys/param.h>. */
53 # include <sys/wait.h>
57 # include <sys/resource.h>
66 # include <sys/select.h>
70 /* XXX Configure test needed.
71 h_errno might not be a simple 'int', especially for multi-threaded
72 applications, see "extern int errno in perl.h". Creating such
73 a test requires taking into account the differences between
74 compiling multithreaded and singlethreaded ($ccflags et al).
75 HOST_NOT_FOUND is typically defined in <netdb.h>.
77 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
86 struct passwd *getpwnam (char *);
87 struct passwd *getpwuid (Uid_t);
92 struct passwd *getpwent (void);
93 #elif defined (VMS) && defined (my_getpwent)
94 struct passwd *Perl_my_getpwent (pTHX);
103 struct group *getgrnam (char *);
104 struct group *getgrgid (Gid_t);
108 struct group *getgrent (void);
114 # if defined(_MSC_VER) || defined(__MINGW32__)
115 # include <sys/utime.h>
122 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
125 # define my_chsize PerlLIO_chsize
128 # define my_chsize PerlLIO_chsize
130 I32 my_chsize(int fd, Off_t length);
136 #else /* no flock() */
138 /* fcntl.h might not have been included, even if it exists, because
139 the current Configure only sets I_FCNTL if it's needed to pick up
140 the *_OK constants. Make sure it has been included before testing
141 the fcntl() locking constants. */
142 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
146 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
147 # define FLOCK fcntl_emulate_flock
148 # define FCNTL_EMULATE_FLOCK
149 # else /* no flock() or fcntl(F_SETLK,...) */
151 # define FLOCK lockf_emulate_flock
152 # define LOCKF_EMULATE_FLOCK
154 # endif /* no flock() or fcntl(F_SETLK,...) */
157 static int FLOCK (int, int);
160 * These are the flock() constants. Since this sytems doesn't have
161 * flock(), the values of the constants are probably not available.
175 # endif /* emulating flock() */
177 #endif /* no flock() */
180 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
182 #if defined(I_SYS_ACCESS) && !defined(R_OK)
183 # include <sys/access.h>
186 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
187 # define FD_CLOEXEC 1 /* NeXT needs this */
193 /* Missing protos on LynxOS */
194 void sethostent(int);
195 void endhostent(void);
197 void endnetent(void);
198 void setprotoent(int);
199 void endprotoent(void);
200 void setservent(int);
201 void endservent(void);
204 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
206 /* F_OK unused: if stat() cannot find it... */
208 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
209 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
210 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
213 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
214 # ifdef I_SYS_SECURITY
215 # include <sys/security.h>
219 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
222 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
226 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
228 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
232 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
233 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
234 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
237 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
239 const Uid_t ruid = getuid();
240 const Uid_t euid = geteuid();
241 const Gid_t rgid = getgid();
242 const Gid_t egid = getegid();
245 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
246 Perl_croak(aTHX_ "switching effective uid is not implemented");
249 if (setreuid(euid, ruid))
252 if (setresuid(euid, ruid, (Uid_t)-1))
255 Perl_croak(aTHX_ "entering effective uid failed");
258 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
259 Perl_croak(aTHX_ "switching effective gid is not implemented");
262 if (setregid(egid, rgid))
265 if (setresgid(egid, rgid, (Gid_t)-1))
268 Perl_croak(aTHX_ "entering effective gid failed");
271 res = access(path, mode);
274 if (setreuid(ruid, euid))
277 if (setresuid(ruid, euid, (Uid_t)-1))
280 Perl_croak(aTHX_ "leaving effective uid failed");
283 if (setregid(rgid, egid))
286 if (setresgid(rgid, egid, (Gid_t)-1))
289 Perl_croak(aTHX_ "leaving effective gid failed");
293 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
300 const char * const tmps = POPpconstx;
301 const I32 gimme = GIMME_V;
302 const char *mode = "r";
305 if (PL_op->op_private & OPpOPEN_IN_RAW)
307 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
309 fp = PerlProc_popen(tmps, mode);
311 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
313 PerlIO_apply_layers(aTHX_ fp,mode,type);
315 if (gimme == G_VOID) {
317 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
320 else if (gimme == G_SCALAR) {
321 ENTER_with_name("backtick");
323 PL_rs = &PL_sv_undef;
324 sv_setpvs(TARG, ""); /* note that this preserves previous buffer */
325 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
327 LEAVE_with_name("backtick");
333 SV * const sv = newSV(79);
334 if (sv_gets(sv, fp, 0) == NULL) {
339 if (SvLEN(sv) - SvCUR(sv) > 20) {
340 SvPV_shrink_to_cur(sv);
345 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
346 TAINT; /* "I believe that this is not gratuitous!" */
349 STATUS_NATIVE_CHILD_SET(-1);
350 if (gimme == G_SCALAR)
362 /* make a copy of the pattern, to ensure that magic is called once
364 TOPm1s = sv_2mortal(newSVsv(TOPm1s));
366 tryAMAGICunTARGET(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL));
368 if (PL_op->op_flags & OPf_SPECIAL) {
369 /* call Perl-level glob function instead. Stack args are:
370 * MARK, wildcard, csh_glob context index
371 * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
375 /* stack args are: wildcard, gv(_GEN_n) */
378 /* Note that we only ever get here if File::Glob fails to load
379 * without at the same time croaking, for some reason, or if
380 * perl was built with PERL_EXTERNAL_GLOB */
382 ENTER_with_name("glob");
387 * The external globbing program may use things we can't control,
388 * so for security reasons we must assume the worst.
391 taint_proper(PL_no_security, "glob");
395 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
396 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
398 SAVESPTR(PL_rs); /* This is not permanent, either. */
399 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
402 *SvPVX(PL_rs) = '\n';
406 result = do_readline();
407 LEAVE_with_name("glob");
414 PL_last_in_gv = cGVOP_gv;
415 return do_readline();
426 do_join(TARG, &PL_sv_no, MARK, SP);
430 else if (SP == MARK) {
439 if (SvROK(exsv) || (pv = SvPV_const(exsv, len), len)) {
440 /* well-formed exception supplied */
442 else if (SvROK(ERRSV)) {
445 else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
446 exsv = sv_mortalcopy(ERRSV);
447 sv_catpvs(exsv, "\t...caught");
450 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
463 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
465 if (SP - MARK != 1) {
467 do_join(TARG, &PL_sv_no, MARK, SP);
475 if (SvROK(exsv) || (pv = SvPV_const(exsv, len), len)) {
476 /* well-formed exception supplied */
478 else if (SvROK(ERRSV)) {
480 if (sv_isobject(exsv)) {
481 HV * const stash = SvSTASH(SvRV(exsv));
482 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
484 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
485 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
492 call_sv(MUTABLE_SV(GvCV(gv)),
493 G_SCALAR|G_EVAL|G_KEEPERR);
494 exsv = sv_mortalcopy(*PL_stack_sp--);
498 else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
499 exsv = sv_mortalcopy(ERRSV);
500 sv_catpvs(exsv, "\t...propagated");
503 exsv = newSVpvs_flags("Died", SVs_TEMP);
521 GV * const gv = MUTABLE_GV(*++MARK);
523 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
524 DIE(aTHX_ PL_no_usym, "filehandle");
526 if ((io = GvIOp(gv))) {
528 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
531 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
532 "Opening dirhandle %s also as a file",
535 mg = SvTIED_mg((const 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(MUTABLE_SV(io), mg);
542 ENTER_with_name("call_OPEN");
543 call_method("OPEN", G_SCALAR);
544 LEAVE_with_name("call_OPEN");
556 tmps = SvPV_const(sv, len);
557 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
560 PUSHi( (I32)PL_forkprocess );
561 else if (PL_forkprocess == 0) /* we are a new child */
568 /* These are private to this function, which is private to this file.
569 Use 0x04 rather than the next available bit, to help the compiler if the
570 architecture can generate more efficient instructions. */
571 #define MORTALIZE_NOT_NEEDED 0x04
572 #define TIED_HANDLE_ARGC_SHIFT 3
575 S_tied_handle_method(pTHX_ const char *const methname, SV **sp,
576 IO *const io, MAGIC *const mg, const U32 flags, ...)
578 U32 argc = flags >> TIED_HANDLE_ARGC_SHIFT;
580 PERL_ARGS_ASSERT_TIED_HANDLE_METHOD;
582 /* Ensure that our flag bits do not overlap. */
583 assert((MORTALIZE_NOT_NEEDED & G_WANT) == 0);
584 assert((G_WANT >> TIED_HANDLE_ARGC_SHIFT) == 0);
587 PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
589 const U32 mortalize_not_needed = flags & MORTALIZE_NOT_NEEDED;
591 va_start(args, flags);
593 SV *const arg = va_arg(args, SV *);
594 if(mortalize_not_needed)
603 ENTER_with_name("call_tied_handle_method");
604 call_method(methname, flags & G_WANT);
605 LEAVE_with_name("call_tied_handle_method");
609 #define tied_handle_method(a,b,c,d) \
610 S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR)
611 #define tied_handle_method1(a,b,c,d,e) \
612 S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR | (1 << TIED_HANDLE_ARGC_SHIFT),e)
613 #define tied_handle_method2(a,b,c,d,e,f) \
614 S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR | (2 << TIED_HANDLE_ARGC_SHIFT), e,f)
619 GV * const gv = (MAXARG == 0) ? PL_defoutgv : MUTABLE_GV(POPs);
625 IO * const io = GvIO(gv);
627 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
629 return tied_handle_method("CLOSE", SP, io, mg);
633 PUSHs(boolSV(do_close(gv, TRUE)));
646 GV * const wgv = MUTABLE_GV(POPs);
647 GV * const rgv = MUTABLE_GV(POPs);
652 if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
653 DIE(aTHX_ PL_no_usym, "filehandle");
658 do_close(rgv, FALSE);
660 do_close(wgv, FALSE);
662 if (PerlProc_pipe(fd) < 0)
665 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
666 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
667 IoOFP(rstio) = IoIFP(rstio);
668 IoIFP(wstio) = IoOFP(wstio);
669 IoTYPE(rstio) = IoTYPE_RDONLY;
670 IoTYPE(wstio) = IoTYPE_WRONLY;
672 if (!IoIFP(rstio) || !IoOFP(wstio)) {
674 PerlIO_close(IoIFP(rstio));
676 PerlLIO_close(fd[0]);
678 PerlIO_close(IoOFP(wstio));
680 PerlLIO_close(fd[1]);
683 #if defined(HAS_FCNTL) && defined(F_SETFD)
684 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
685 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
692 DIE(aTHX_ PL_no_func, "pipe");
706 gv = MUTABLE_GV(POPs);
710 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
712 return tied_handle_method("FILENO", SP, io, mg);
715 if (!io || !(fp = IoIFP(io))) {
716 /* Can't do this because people seem to do things like
717 defined(fileno($foo)) to check whether $foo is a valid fh.
724 PUSHi(PerlIO_fileno(fp));
737 anum = PerlLIO_umask(022);
738 /* setting it to 022 between the two calls to umask avoids
739 * to have a window where the umask is set to 0 -- meaning
740 * that another thread could create world-writeable files. */
742 (void)PerlLIO_umask(anum);
745 anum = PerlLIO_umask(POPi);
746 TAINT_PROPER("umask");
749 /* Only DIE if trying to restrict permissions on "user" (self).
750 * Otherwise it's harmless and more useful to just return undef
751 * since 'group' and 'other' concepts probably don't exist here. */
752 if (MAXARG >= 1 && (POPi & 0700))
753 DIE(aTHX_ "umask not implemented");
754 XPUSHs(&PL_sv_undef);
773 gv = MUTABLE_GV(POPs);
777 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
779 /* This takes advantage of the implementation of the varargs
780 function, which I don't think that the optimiser will be able to
781 figure out. Although, as it's a static function, in theory it
783 return S_tied_handle_method(aTHX_ "BINMODE", SP, io, mg,
784 G_SCALAR|MORTALIZE_NOT_NEEDED
786 ? (1 << TIED_HANDLE_ARGC_SHIFT) : 0),
791 if (!io || !(fp = IoIFP(io))) {
793 SETERRNO(EBADF,RMS_IFI);
800 const char *d = NULL;
803 d = SvPV_const(discp, len);
804 mode = mode_from_discipline(d, len);
805 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
806 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
807 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
828 const I32 markoff = MARK - PL_stack_base;
829 const char *methname;
830 int how = PERL_MAGIC_tied;
834 switch(SvTYPE(varsv)) {
836 methname = "TIEHASH";
837 HvEITER_set(MUTABLE_HV(varsv), 0);
840 methname = "TIEARRAY";
844 if (isGV_with_GP(varsv)) {
845 if (SvFAKE(varsv) && !(GvFLAGS(varsv) & GVf_TIEWARNED)) {
846 deprecate("tie on a handle without *");
847 GvFLAGS(varsv) |= GVf_TIEWARNED;
849 methname = "TIEHANDLE";
850 how = PERL_MAGIC_tiedscalar;
851 /* For tied filehandles, we apply tiedscalar magic to the IO
852 slot of the GP rather than the GV itself. AMS 20010812 */
854 GvIOp(varsv) = newIO();
855 varsv = MUTABLE_SV(GvIOp(varsv));
860 methname = "TIESCALAR";
861 how = PERL_MAGIC_tiedscalar;
865 if (sv_isobject(*MARK)) { /* Calls GET magic. */
866 ENTER_with_name("call_TIE");
867 PUSHSTACKi(PERLSI_MAGIC);
869 EXTEND(SP,(I32)items);
873 call_method(methname, G_SCALAR);
876 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
877 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
878 * wrong error message, and worse case, supreme action at a distance.
879 * (Sorry obfuscation writers. You're not going to be given this one.)
882 const char *name = SvPV_nomg_const(*MARK, len);
883 stash = gv_stashpvn(name, len, 0);
884 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
885 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
886 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
888 ENTER_with_name("call_TIE");
889 PUSHSTACKi(PERLSI_MAGIC);
891 EXTEND(SP,(I32)items);
895 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
901 if (sv_isobject(sv)) {
902 sv_unmagic(varsv, how);
903 /* Croak if a self-tie on an aggregate is attempted. */
904 if (varsv == SvRV(sv) &&
905 (SvTYPE(varsv) == SVt_PVAV ||
906 SvTYPE(varsv) == SVt_PVHV))
908 "Self-ties of arrays and hashes are not supported");
909 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
911 LEAVE_with_name("call_TIE");
912 SP = PL_stack_base + markoff;
922 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
923 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
925 if (isGV_with_GP(sv)) {
926 if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
927 deprecate("untie on a handle without *");
928 GvFLAGS(sv) |= GVf_TIEWARNED;
930 if (!(sv = MUTABLE_SV(GvIOp(sv))))
934 if ((mg = SvTIED_mg(sv, how))) {
935 SV * const obj = SvRV(SvTIED_obj(sv, mg));
937 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
939 if (gv && isGV(gv) && (cv = GvCV(gv))) {
941 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
942 mXPUSHi(SvREFCNT(obj) - 1);
944 ENTER_with_name("call_UNTIE");
945 call_sv(MUTABLE_SV(cv), G_VOID);
946 LEAVE_with_name("call_UNTIE");
949 else if (mg && SvREFCNT(obj) > 1) {
950 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
951 "untie attempted while %"UVuf" inner references still exist",
952 (UV)SvREFCNT(obj) - 1 ) ;
956 sv_unmagic(sv, how) ;
966 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
967 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
969 if (isGV_with_GP(sv)) {
970 if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
971 deprecate("tied on a handle without *");
972 GvFLAGS(sv) |= GVf_TIEWARNED;
974 if (!(sv = MUTABLE_SV(GvIOp(sv))))
978 if ((mg = SvTIED_mg(sv, how))) {
979 SV *osv = SvTIED_obj(sv, mg);
980 if (osv == mg->mg_obj)
981 osv = sv_mortalcopy(osv);
995 HV * const hv = MUTABLE_HV(POPs);
996 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
997 stash = gv_stashsv(sv, 0);
998 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1000 require_pv("AnyDBM_File.pm");
1002 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1003 DIE(aTHX_ "No dbm on this machine");
1013 mPUSHu(O_RDWR|O_CREAT);
1018 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1021 if (!sv_isobject(TOPs)) {
1029 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1033 if (sv_isobject(TOPs)) {
1034 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1035 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1052 struct timeval timebuf;
1053 struct timeval *tbuf = &timebuf;
1056 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1061 # if BYTEORDER & 0xf0000
1062 # define ORDERBYTE (0x88888888 - BYTEORDER)
1064 # define ORDERBYTE (0x4444 - BYTEORDER)
1070 for (i = 1; i <= 3; i++) {
1071 SV * const sv = SP[i];
1074 if (SvREADONLY(sv)) {
1076 sv_force_normal_flags(sv, 0);
1077 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1078 Perl_croak_no_modify(aTHX);
1081 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1082 SvPV_force_nolen(sv); /* force string conversion */
1089 /* little endians can use vecs directly */
1090 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1097 masksize = NFDBITS / NBBY;
1099 masksize = sizeof(long); /* documented int, everyone seems to use long */
1101 Zero(&fd_sets[0], 4, char*);
1104 # if SELECT_MIN_BITS == 1
1105 growsize = sizeof(fd_set);
1107 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1108 # undef SELECT_MIN_BITS
1109 # define SELECT_MIN_BITS __FD_SETSIZE
1111 /* If SELECT_MIN_BITS is greater than one we most probably will want
1112 * to align the sizes with SELECT_MIN_BITS/8 because for example
1113 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1114 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1115 * on (sets/tests/clears bits) is 32 bits. */
1116 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1124 timebuf.tv_sec = (long)value;
1125 value -= (NV)timebuf.tv_sec;
1126 timebuf.tv_usec = (long)(value * 1000000.0);
1131 for (i = 1; i <= 3; i++) {
1133 if (!SvOK(sv) || SvCUR(sv) == 0) {
1140 Sv_Grow(sv, growsize);
1144 while (++j <= growsize) {
1148 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1150 Newx(fd_sets[i], growsize, char);
1151 for (offset = 0; offset < growsize; offset += masksize) {
1152 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1153 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1156 fd_sets[i] = SvPVX(sv);
1160 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1161 /* Can't make just the (void*) conditional because that would be
1162 * cpp #if within cpp macro, and not all compilers like that. */
1163 nfound = PerlSock_select(
1165 (Select_fd_set_t) fd_sets[1],
1166 (Select_fd_set_t) fd_sets[2],
1167 (Select_fd_set_t) fd_sets[3],
1168 (void*) tbuf); /* Workaround for compiler bug. */
1170 nfound = PerlSock_select(
1172 (Select_fd_set_t) fd_sets[1],
1173 (Select_fd_set_t) fd_sets[2],
1174 (Select_fd_set_t) fd_sets[3],
1177 for (i = 1; i <= 3; i++) {
1180 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1182 for (offset = 0; offset < growsize; offset += masksize) {
1183 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1184 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1186 Safefree(fd_sets[i]);
1193 if (GIMME == G_ARRAY && tbuf) {
1194 value = (NV)(timebuf.tv_sec) +
1195 (NV)(timebuf.tv_usec) / 1000000.0;
1200 DIE(aTHX_ "select not implemented");
1205 =for apidoc setdefout
1207 Sets PL_defoutgv, the default file handle for output, to the passed in
1208 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1209 count of the passed in typeglob is increased by one, and the reference count
1210 of the typeglob that PL_defoutgv points to is decreased by one.
1216 Perl_setdefout(pTHX_ GV *gv)
1219 SvREFCNT_inc_simple_void(gv);
1220 SvREFCNT_dec(PL_defoutgv);
1228 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1229 GV * egv = GvEGVx(PL_defoutgv);
1233 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1235 XPUSHs(&PL_sv_undef);
1237 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1238 if (gvp && *gvp == egv) {
1239 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1243 mXPUSHs(newRV(MUTABLE_SV(egv)));
1248 if (!GvIO(newdefout))
1249 gv_IOadd(newdefout);
1250 setdefout(newdefout);
1259 GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs);
1260 IO *const io = GvIO(gv);
1266 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1268 const U32 gimme = GIMME_V;
1269 S_tied_handle_method(aTHX_ "GETC", SP, io, mg, gimme);
1270 if (gimme == G_SCALAR) {
1272 SvSetMagicSV_nosteal(TARG, TOPs);
1277 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1278 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1280 SETERRNO(EBADF,RMS_IFI);
1284 sv_setpvs(TARG, " ");
1285 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1286 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1287 /* Find out how many bytes the char needs */
1288 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1291 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1292 SvCUR_set(TARG,1+len);
1301 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1304 register PERL_CONTEXT *cx;
1305 const I32 gimme = GIMME_V;
1307 PERL_ARGS_ASSERT_DOFORM;
1309 if (cv && CvCLONE(cv))
1310 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1315 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1316 PUSHFORMAT(cx, retop);
1318 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1320 setdefout(gv); /* locally select filehandle so $% et al work */
1339 gv = MUTABLE_GV(POPs);
1353 goto not_a_format_reference;
1358 tmpsv = sv_newmortal();
1359 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1360 name = SvPV_nolen_const(tmpsv);
1362 DIE(aTHX_ "Undefined format \"%s\" called", name);
1364 not_a_format_reference:
1365 DIE(aTHX_ "Not a format reference");
1367 IoFLAGS(io) &= ~IOf_DIDTOP;
1368 return doform(cv,gv,PL_op->op_next);
1374 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1375 register IO * const io = GvIOp(gv);
1380 register PERL_CONTEXT *cx;
1383 if (!io || !(ofp = IoOFP(io)))
1386 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1387 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1389 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1390 PL_formtarget != PL_toptarget)
1394 if (!IoTOP_GV(io)) {
1397 if (!IoTOP_NAME(io)) {
1399 if (!IoFMT_NAME(io))
1400 IoFMT_NAME(io) = savepv(GvNAME(gv));
1401 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1402 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1403 if ((topgv && GvFORM(topgv)) ||
1404 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1405 IoTOP_NAME(io) = savesvpv(topname);
1407 IoTOP_NAME(io) = savepvs("top");
1409 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1410 if (!topgv || !GvFORM(topgv)) {
1411 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1414 IoTOP_GV(io) = topgv;
1416 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1417 I32 lines = IoLINES_LEFT(io);
1418 const char *s = SvPVX_const(PL_formtarget);
1419 if (lines <= 0) /* Yow, header didn't even fit!!! */
1421 while (lines-- > 0) {
1422 s = strchr(s, '\n');
1428 const STRLEN save = SvCUR(PL_formtarget);
1429 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1430 do_print(PL_formtarget, ofp);
1431 SvCUR_set(PL_formtarget, save);
1432 sv_chop(PL_formtarget, s);
1433 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1436 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1437 do_print(PL_formfeed, ofp);
1438 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1440 PL_formtarget = PL_toptarget;
1441 IoFLAGS(io) |= IOf_DIDTOP;
1444 DIE(aTHX_ "bad top format reference");
1447 SV * const sv = sv_newmortal();
1449 gv_efullname4(sv, fgv, NULL, FALSE);
1450 name = SvPV_nolen_const(sv);
1452 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1454 DIE(aTHX_ "Undefined top format called");
1456 return doform(cv, gv, PL_op);
1460 POPBLOCK(cx,PL_curpm);
1462 retop = cx->blk_sub.retop;
1468 report_wrongway_fh(gv, '<');
1474 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1475 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1477 if (!do_print(PL_formtarget, fp))
1480 FmLINES(PL_formtarget) = 0;
1481 SvCUR_set(PL_formtarget, 0);
1482 *SvEND(PL_formtarget) = '\0';
1483 if (IoFLAGS(io) & IOf_FLUSH)
1484 (void)PerlIO_flush(fp);
1489 PL_formtarget = PL_bodytarget;
1491 PERL_UNUSED_VAR(newsp);
1492 PERL_UNUSED_VAR(gimme);
1498 dVAR; dSP; dMARK; dORIGMARK;
1503 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1504 IO *const io = GvIO(gv);
1507 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1509 if (MARK == ORIGMARK) {
1512 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1516 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1519 call_method("PRINTF", G_SCALAR);
1528 SETERRNO(EBADF,RMS_IFI);
1531 else if (!(fp = IoOFP(io))) {
1533 report_wrongway_fh(gv, '<');
1534 else if (ckWARN(WARN_CLOSED))
1536 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1540 if (SvTAINTED(MARK[1]))
1541 TAINT_PROPER("printf");
1542 do_sprintf(sv, SP - MARK, MARK + 1);
1543 if (!do_print(sv, fp))
1546 if (IoFLAGS(io) & IOf_FLUSH)
1547 if (PerlIO_flush(fp) == EOF)
1558 PUSHs(&PL_sv_undef);
1566 const int perm = (MAXARG > 3) ? POPi : 0666;
1567 const int mode = POPi;
1568 SV * const sv = POPs;
1569 GV * const gv = MUTABLE_GV(POPs);
1572 /* Need TIEHANDLE method ? */
1573 const char * const tmps = SvPV_const(sv, len);
1574 /* FIXME? do_open should do const */
1575 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1576 IoLINES(GvIOp(gv)) = 0;
1580 PUSHs(&PL_sv_undef);
1587 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1593 Sock_size_t bufsize;
1601 bool charstart = FALSE;
1602 STRLEN charskip = 0;
1605 GV * const gv = MUTABLE_GV(*++MARK);
1606 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1607 && gv && (io = GvIO(gv)) )
1609 const MAGIC * mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1612 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1614 call_method("READ", G_SCALAR);
1624 sv_setpvs(bufsv, "");
1625 length = SvIVx(*++MARK);
1628 offset = SvIVx(*++MARK);
1632 if (!io || !IoIFP(io)) {
1634 SETERRNO(EBADF,RMS_IFI);
1637 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1638 buffer = SvPVutf8_force(bufsv, blen);
1639 /* UTF-8 may not have been set if they are all low bytes */
1644 buffer = SvPV_force(bufsv, blen);
1645 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1648 DIE(aTHX_ "Negative length");
1656 if (PL_op->op_type == OP_RECV) {
1657 char namebuf[MAXPATHLEN];
1658 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1659 bufsize = sizeof (struct sockaddr_in);
1661 bufsize = sizeof namebuf;
1663 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1667 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1668 /* 'offset' means 'flags' here */
1669 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1670 (struct sockaddr *)namebuf, &bufsize);
1673 /* MSG_TRUNC can give oversized count; quietly lose it */
1677 /* Bogus return without padding */
1678 bufsize = sizeof (struct sockaddr_in);
1680 SvCUR_set(bufsv, count);
1681 *SvEND(bufsv) = '\0';
1682 (void)SvPOK_only(bufsv);
1686 /* This should not be marked tainted if the fp is marked clean */
1687 if (!(IoFLAGS(io) & IOf_UNTAINT))
1688 SvTAINTED_on(bufsv);
1690 sv_setpvn(TARG, namebuf, bufsize);
1695 if (PL_op->op_type == OP_RECV)
1696 DIE(aTHX_ PL_no_sock_func, "recv");
1698 if (DO_UTF8(bufsv)) {
1699 /* offset adjust in characters not bytes */
1700 blen = sv_len_utf8(bufsv);
1703 if (-offset > (int)blen)
1704 DIE(aTHX_ "Offset outside string");
1707 if (DO_UTF8(bufsv)) {
1708 /* convert offset-as-chars to offset-as-bytes */
1709 if (offset >= (int)blen)
1710 offset += SvCUR(bufsv) - blen;
1712 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1715 bufsize = SvCUR(bufsv);
1716 /* Allocating length + offset + 1 isn't perfect in the case of reading
1717 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1719 (should be 2 * length + offset + 1, or possibly something longer if
1720 PL_encoding is true) */
1721 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1722 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1723 Zero(buffer+bufsize, offset-bufsize, char);
1725 buffer = buffer + offset;
1727 read_target = bufsv;
1729 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1730 concatenate it to the current buffer. */
1732 /* Truncate the existing buffer to the start of where we will be
1734 SvCUR_set(bufsv, offset);
1736 read_target = sv_newmortal();
1737 SvUPGRADE(read_target, SVt_PV);
1738 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1741 if (PL_op->op_type == OP_SYSREAD) {
1742 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1743 if (IoTYPE(io) == IoTYPE_SOCKET) {
1744 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1750 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1755 #ifdef HAS_SOCKET__bad_code_maybe
1756 if (IoTYPE(io) == IoTYPE_SOCKET) {
1757 char namebuf[MAXPATHLEN];
1758 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1759 bufsize = sizeof (struct sockaddr_in);
1761 bufsize = sizeof namebuf;
1763 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1764 (struct sockaddr *)namebuf, &bufsize);
1769 count = PerlIO_read(IoIFP(io), buffer, length);
1770 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1771 if (count == 0 && PerlIO_error(IoIFP(io)))
1775 if (IoTYPE(io) == IoTYPE_WRONLY)
1776 report_wrongway_fh(gv, '>');
1779 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1780 *SvEND(read_target) = '\0';
1781 (void)SvPOK_only(read_target);
1782 if (fp_utf8 && !IN_BYTES) {
1783 /* Look at utf8 we got back and count the characters */
1784 const char *bend = buffer + count;
1785 while (buffer < bend) {
1787 skip = UTF8SKIP(buffer);
1790 if (buffer - charskip + skip > bend) {
1791 /* partial character - try for rest of it */
1792 length = skip - (bend-buffer);
1793 offset = bend - SvPVX_const(bufsv);
1805 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1806 provided amount read (count) was what was requested (length)
1808 if (got < wanted && count == length) {
1809 length = wanted - got;
1810 offset = bend - SvPVX_const(bufsv);
1813 /* return value is character count */
1817 else if (buffer_utf8) {
1818 /* Let svcatsv upgrade the bytes we read in to utf8.
1819 The buffer is a mortal so will be freed soon. */
1820 sv_catsv_nomg(bufsv, read_target);
1823 /* This should not be marked tainted if the fp is marked clean */
1824 if (!(IoFLAGS(io) & IOf_UNTAINT))
1825 SvTAINTED_on(bufsv);
1837 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1843 STRLEN orig_blen_bytes;
1844 const int op_type = PL_op->op_type;
1848 GV *const gv = MUTABLE_GV(*++MARK);
1849 if (PL_op->op_type == OP_SYSWRITE
1850 && gv && (io = GvIO(gv))) {
1851 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1853 if (MARK == SP - 1) {
1855 mXPUSHi(sv_len(sv));
1860 *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg);
1862 call_method("WRITE", G_SCALAR);
1874 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1876 if (io && IoIFP(io))
1877 report_wrongway_fh(gv, '<');
1880 SETERRNO(EBADF,RMS_IFI);
1884 /* Do this first to trigger any overloading. */
1885 buffer = SvPV_const(bufsv, blen);
1886 orig_blen_bytes = blen;
1887 doing_utf8 = DO_UTF8(bufsv);
1889 if (PerlIO_isutf8(IoIFP(io))) {
1890 if (!SvUTF8(bufsv)) {
1891 /* We don't modify the original scalar. */
1892 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1893 buffer = (char *) tmpbuf;
1897 else if (doing_utf8) {
1898 STRLEN tmplen = blen;
1899 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1902 buffer = (char *) tmpbuf;
1906 assert((char *)result == buffer);
1907 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1911 if (op_type == OP_SYSWRITE) {
1912 Size_t length = 0; /* This length is in characters. */
1918 /* The SV is bytes, and we've had to upgrade it. */
1919 blen_chars = orig_blen_bytes;
1921 /* The SV really is UTF-8. */
1922 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1923 /* Don't call sv_len_utf8 again because it will call magic
1924 or overloading a second time, and we might get back a
1925 different result. */
1926 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1928 /* It's safe, and it may well be cached. */
1929 blen_chars = sv_len_utf8(bufsv);
1937 length = blen_chars;
1939 #if Size_t_size > IVSIZE
1940 length = (Size_t)SvNVx(*++MARK);
1942 length = (Size_t)SvIVx(*++MARK);
1944 if ((SSize_t)length < 0) {
1946 DIE(aTHX_ "Negative length");
1951 offset = SvIVx(*++MARK);
1953 if (-offset > (IV)blen_chars) {
1955 DIE(aTHX_ "Offset outside string");
1957 offset += blen_chars;
1958 } else if (offset > (IV)blen_chars) {
1960 DIE(aTHX_ "Offset outside string");
1964 if (length > blen_chars - offset)
1965 length = blen_chars - offset;
1967 /* Here we convert length from characters to bytes. */
1968 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1969 /* Either we had to convert the SV, or the SV is magical, or
1970 the SV has overloading, in which case we can't or mustn't
1971 or mustn't call it again. */
1973 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1974 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1976 /* It's a real UTF-8 SV, and it's not going to change under
1977 us. Take advantage of any cache. */
1979 I32 len_I32 = length;
1981 /* Convert the start and end character positions to bytes.
1982 Remember that the second argument to sv_pos_u2b is relative
1984 sv_pos_u2b(bufsv, &start, &len_I32);
1991 buffer = buffer+offset;
1993 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1994 if (IoTYPE(io) == IoTYPE_SOCKET) {
1995 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
2001 /* See the note at doio.c:do_print about filesize limits. --jhi */
2002 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2008 const int flags = SvIVx(*++MARK);
2011 char * const sockbuf = SvPVx(*++MARK, mlen);
2012 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
2013 flags, (struct sockaddr *)sockbuf, mlen);
2017 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
2022 DIE(aTHX_ PL_no_sock_func, "send");
2029 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2032 #if Size_t_size > IVSIZE
2052 * in Perl 5.12 and later, the additional parameter is a bitmask:
2055 * 2 = eof() <- ARGV magic
2057 * I'll rely on the compiler's trace flow analysis to decide whether to
2058 * actually assign this out here, or punt it into the only block where it is
2059 * used. Doing it out here is DRY on the condition logic.
2064 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2070 if (PL_op->op_flags & OPf_SPECIAL) {
2071 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2075 gv = PL_last_in_gv; /* eof */
2083 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2084 return tied_handle_method1("EOF", SP, io, mg, newSVuv(which));
2087 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2088 if (io && !IoIFP(io)) {
2089 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2091 IoFLAGS(io) &= ~IOf_START;
2092 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2094 sv_setpvs(GvSV(gv), "-");
2096 GvSV(gv) = newSVpvs("-");
2097 SvSETMAGIC(GvSV(gv));
2099 else if (!nextargv(gv))
2104 PUSHs(boolSV(do_eof(gv)));
2115 PL_last_in_gv = MUTABLE_GV(POPs);
2122 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2124 return tied_handle_method("TELL", SP, io, mg);
2129 SETERRNO(EBADF,RMS_IFI);
2134 #if LSEEKSIZE > IVSIZE
2135 PUSHn( do_tell(gv) );
2137 PUSHi( do_tell(gv) );
2145 const int whence = POPi;
2146 #if LSEEKSIZE > IVSIZE
2147 const Off_t offset = (Off_t)SvNVx(POPs);
2149 const Off_t offset = (Off_t)SvIVx(POPs);
2152 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2153 IO *const io = GvIO(gv);
2156 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2158 #if LSEEKSIZE > IVSIZE
2159 SV *const offset_sv = newSVnv((NV) offset);
2161 SV *const offset_sv = newSViv(offset);
2164 return tied_handle_method2("SEEK", SP, io, mg, offset_sv,
2169 if (PL_op->op_type == OP_SEEK)
2170 PUSHs(boolSV(do_seek(gv, offset, whence)));
2172 const Off_t sought = do_sysseek(gv, offset, whence);
2174 PUSHs(&PL_sv_undef);
2176 SV* const sv = sought ?
2177 #if LSEEKSIZE > IVSIZE
2182 : newSVpvn(zero_but_true, ZBTLEN);
2193 /* There seems to be no consensus on the length type of truncate()
2194 * and ftruncate(), both off_t and size_t have supporters. In
2195 * general one would think that when using large files, off_t is
2196 * at least as wide as size_t, so using an off_t should be okay. */
2197 /* XXX Configure probe for the length type of *truncate() needed XXX */
2200 #if Off_t_size > IVSIZE
2205 /* Checking for length < 0 is problematic as the type might or
2206 * might not be signed: if it is not, clever compilers will moan. */
2207 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2214 if (PL_op->op_flags & OPf_SPECIAL) {
2215 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2224 TAINT_PROPER("truncate");
2225 if (!(fp = IoIFP(io))) {
2231 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2233 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2240 SV * const sv = POPs;
2243 if (isGV_with_GP(sv)) {
2244 tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */
2245 goto do_ftruncate_gv;
2247 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2248 tmpgv = MUTABLE_GV(SvRV(sv)); /* \*main::FRED for example */
2249 goto do_ftruncate_gv;
2251 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2252 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2253 goto do_ftruncate_io;
2256 name = SvPV_nolen_const(sv);
2257 TAINT_PROPER("truncate");
2259 if (truncate(name, len) < 0)
2263 const int tmpfd = PerlLIO_open(name, O_RDWR);
2268 if (my_chsize(tmpfd, len) < 0)
2270 PerlLIO_close(tmpfd);
2279 SETERRNO(EBADF,RMS_IFI);
2287 SV * const argsv = POPs;
2288 const unsigned int func = POPu;
2289 const int optype = PL_op->op_type;
2290 GV * const gv = MUTABLE_GV(POPs);
2291 IO * const io = gv ? GvIOn(gv) : NULL;
2295 if (!io || !argsv || !IoIFP(io)) {
2297 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2301 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2304 s = SvPV_force(argsv, len);
2305 need = IOCPARM_LEN(func);
2307 s = Sv_Grow(argsv, need + 1);
2308 SvCUR_set(argsv, need);
2311 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2314 retval = SvIV(argsv);
2315 s = INT2PTR(char*,retval); /* ouch */
2318 TAINT_PROPER(PL_op_desc[optype]);
2320 if (optype == OP_IOCTL)
2322 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2324 DIE(aTHX_ "ioctl is not implemented");
2328 DIE(aTHX_ "fcntl is not implemented");
2330 #if defined(OS2) && defined(__EMX__)
2331 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2333 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2337 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2339 if (s[SvCUR(argsv)] != 17)
2340 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2342 s[SvCUR(argsv)] = 0; /* put our null back */
2343 SvSETMAGIC(argsv); /* Assume it has changed */
2352 PUSHp(zero_but_true, ZBTLEN);
2363 const int argtype = POPi;
2364 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
2365 IO *const io = GvIO(gv);
2366 PerlIO *const fp = io ? IoIFP(io) : NULL;
2368 /* XXX Looks to me like io is always NULL at this point */
2370 (void)PerlIO_flush(fp);
2371 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2376 SETERRNO(EBADF,RMS_IFI);
2381 DIE(aTHX_ PL_no_func, "flock()");
2391 const int protocol = POPi;
2392 const int type = POPi;
2393 const int domain = POPi;
2394 GV * const gv = MUTABLE_GV(POPs);
2395 register IO * const io = gv ? GvIOn(gv) : NULL;
2400 if (io && IoIFP(io))
2401 do_close(gv, FALSE);
2402 SETERRNO(EBADF,LIB_INVARG);
2407 do_close(gv, FALSE);
2409 TAINT_PROPER("socket");
2410 fd = PerlSock_socket(domain, type, protocol);
2413 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2414 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2415 IoTYPE(io) = IoTYPE_SOCKET;
2416 if (!IoIFP(io) || !IoOFP(io)) {
2417 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2418 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2419 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2422 #if defined(HAS_FCNTL) && defined(F_SETFD)
2423 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2427 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2432 DIE(aTHX_ PL_no_sock_func, "socket");
2438 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2440 const int protocol = POPi;
2441 const int type = POPi;
2442 const int domain = POPi;
2443 GV * const gv2 = MUTABLE_GV(POPs);
2444 GV * const gv1 = MUTABLE_GV(POPs);
2445 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2446 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2450 report_evil_fh(gv1);
2452 report_evil_fh(gv2);
2454 if (io1 && IoIFP(io1))
2455 do_close(gv1, FALSE);
2456 if (io2 && IoIFP(io2))
2457 do_close(gv2, FALSE);
2462 TAINT_PROPER("socketpair");
2463 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2465 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2466 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2467 IoTYPE(io1) = IoTYPE_SOCKET;
2468 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2469 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2470 IoTYPE(io2) = IoTYPE_SOCKET;
2471 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2472 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2473 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2474 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2475 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2476 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2477 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2480 #if defined(HAS_FCNTL) && defined(F_SETFD)
2481 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2482 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2487 DIE(aTHX_ PL_no_sock_func, "socketpair");
2495 SV * const addrsv = POPs;
2496 /* OK, so on what platform does bind modify addr? */
2498 GV * const gv = MUTABLE_GV(POPs);
2499 register IO * const io = GvIOn(gv);
2501 const int op_type = PL_op->op_type;
2503 if (!io || !IoIFP(io))
2506 addr = SvPV_const(addrsv, len);
2507 TAINT_PROPER(PL_op_desc[op_type]);
2508 if ((op_type == OP_BIND
2509 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2510 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2518 SETERRNO(EBADF,SS_IVCHAN);
2521 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2529 const int backlog = POPi;
2530 GV * const gv = MUTABLE_GV(POPs);
2531 register IO * const io = gv ? GvIOn(gv) : NULL;
2533 if (!io || !IoIFP(io))
2536 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2543 SETERRNO(EBADF,SS_IVCHAN);
2546 DIE(aTHX_ PL_no_sock_func, "listen");
2556 char namebuf[MAXPATHLEN];
2557 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2558 Sock_size_t len = sizeof (struct sockaddr_in);
2560 Sock_size_t len = sizeof namebuf;
2562 GV * const ggv = MUTABLE_GV(POPs);
2563 GV * const ngv = MUTABLE_GV(POPs);
2572 if (!gstio || !IoIFP(gstio))
2576 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2579 /* Some platforms indicate zero length when an AF_UNIX client is
2580 * not bound. Simulate a non-zero-length sockaddr structure in
2582 namebuf[0] = 0; /* sun_len */
2583 namebuf[1] = AF_UNIX; /* sun_family */
2591 do_close(ngv, FALSE);
2592 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2593 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2594 IoTYPE(nstio) = IoTYPE_SOCKET;
2595 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2596 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2597 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2598 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2601 #if defined(HAS_FCNTL) && defined(F_SETFD)
2602 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2606 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2607 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2609 #ifdef __SCO_VERSION__
2610 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2613 PUSHp(namebuf, len);
2617 report_evil_fh(ggv);
2618 SETERRNO(EBADF,SS_IVCHAN);
2624 DIE(aTHX_ PL_no_sock_func, "accept");
2632 const int how = POPi;
2633 GV * const gv = MUTABLE_GV(POPs);
2634 register IO * const io = GvIOn(gv);
2636 if (!io || !IoIFP(io))
2639 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2644 SETERRNO(EBADF,SS_IVCHAN);
2647 DIE(aTHX_ PL_no_sock_func, "shutdown");
2655 const int optype = PL_op->op_type;
2656 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2657 const unsigned int optname = (unsigned int) POPi;
2658 const unsigned int lvl = (unsigned int) POPi;
2659 GV * const gv = MUTABLE_GV(POPs);
2660 register IO * const io = GvIOn(gv);
2664 if (!io || !IoIFP(io))
2667 fd = PerlIO_fileno(IoIFP(io));
2671 (void)SvPOK_only(sv);
2675 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2682 #if defined(__SYMBIAN32__)
2683 # define SETSOCKOPT_OPTION_VALUE_T void *
2685 # define SETSOCKOPT_OPTION_VALUE_T const char *
2687 /* XXX TODO: We need to have a proper type (a Configure probe,
2688 * etc.) for what the C headers think of the third argument of
2689 * setsockopt(), the option_value read-only buffer: is it
2690 * a "char *", or a "void *", const or not. Some compilers
2691 * don't take kindly to e.g. assuming that "char *" implicitly
2692 * promotes to a "void *", or to explicitly promoting/demoting
2693 * consts to non/vice versa. The "const void *" is the SUS
2694 * definition, but that does not fly everywhere for the above
2696 SETSOCKOPT_OPTION_VALUE_T buf;
2700 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2704 aint = (int)SvIV(sv);
2705 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2708 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2718 SETERRNO(EBADF,SS_IVCHAN);
2723 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2731 const int optype = PL_op->op_type;
2732 GV * const gv = MUTABLE_GV(POPs);
2733 register IO * const io = GvIOn(gv);
2738 if (!io || !IoIFP(io))
2741 sv = sv_2mortal(newSV(257));
2742 (void)SvPOK_only(sv);
2746 fd = PerlIO_fileno(IoIFP(io));
2748 case OP_GETSOCKNAME:
2749 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2752 case OP_GETPEERNAME:
2753 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2755 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2757 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";
2758 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2759 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2760 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2761 sizeof(u_short) + sizeof(struct in_addr))) {
2768 #ifdef BOGUS_GETNAME_RETURN
2769 /* Interactive Unix, getpeername() and getsockname()
2770 does not return valid namelen */
2771 if (len == BOGUS_GETNAME_RETURN)
2772 len = sizeof(struct sockaddr);
2781 SETERRNO(EBADF,SS_IVCHAN);
2786 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2801 if (PL_op->op_flags & OPf_REF) {
2803 if (PL_op->op_type == OP_LSTAT) {
2804 if (gv != PL_defgv) {
2805 do_fstat_warning_check:
2806 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2807 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2808 } else if (PL_laststype != OP_LSTAT)
2809 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2813 if (gv != PL_defgv) {
2814 PL_laststype = OP_STAT;
2816 sv_setpvs(PL_statname, "");
2823 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2824 } else if (IoDIRP(io)) {
2826 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2828 PL_laststatval = -1;
2834 if (PL_laststatval < 0) {
2840 SV* const sv = POPs;
2841 if (isGV_with_GP(sv)) {
2842 gv = MUTABLE_GV(sv);
2844 } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2845 gv = MUTABLE_GV(SvRV(sv));
2846 if (PL_op->op_type == OP_LSTAT)
2847 goto do_fstat_warning_check;
2849 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2850 io = MUTABLE_IO(SvRV(sv));
2851 if (PL_op->op_type == OP_LSTAT)
2852 goto do_fstat_warning_check;
2853 goto do_fstat_have_io;
2856 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2858 PL_laststype = PL_op->op_type;
2859 if (PL_op->op_type == OP_LSTAT)
2860 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2862 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2863 if (PL_laststatval < 0) {
2864 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2865 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2871 if (gimme != G_ARRAY) {
2872 if (gimme != G_VOID)
2873 XPUSHs(boolSV(max));
2879 mPUSHi(PL_statcache.st_dev);
2880 mPUSHi(PL_statcache.st_ino);
2881 mPUSHu(PL_statcache.st_mode);
2882 mPUSHu(PL_statcache.st_nlink);
2883 #if Uid_t_size > IVSIZE
2884 mPUSHn(PL_statcache.st_uid);
2886 # if Uid_t_sign <= 0
2887 mPUSHi(PL_statcache.st_uid);
2889 mPUSHu(PL_statcache.st_uid);
2892 #if Gid_t_size > IVSIZE
2893 mPUSHn(PL_statcache.st_gid);
2895 # if Gid_t_sign <= 0
2896 mPUSHi(PL_statcache.st_gid);
2898 mPUSHu(PL_statcache.st_gid);
2901 #ifdef USE_STAT_RDEV
2902 mPUSHi(PL_statcache.st_rdev);
2904 PUSHs(newSVpvs_flags("", SVs_TEMP));
2906 #if Off_t_size > IVSIZE
2907 mPUSHn(PL_statcache.st_size);
2909 mPUSHi(PL_statcache.st_size);
2912 mPUSHn(PL_statcache.st_atime);
2913 mPUSHn(PL_statcache.st_mtime);
2914 mPUSHn(PL_statcache.st_ctime);
2916 mPUSHi(PL_statcache.st_atime);
2917 mPUSHi(PL_statcache.st_mtime);
2918 mPUSHi(PL_statcache.st_ctime);
2920 #ifdef USE_STAT_BLOCKS
2921 mPUSHu(PL_statcache.st_blksize);
2922 mPUSHu(PL_statcache.st_blocks);
2924 PUSHs(newSVpvs_flags("", SVs_TEMP));
2925 PUSHs(newSVpvs_flags("", SVs_TEMP));
2931 #define tryAMAGICftest_MG(chr) STMT_START { \
2932 if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
2933 && S_try_amagic_ftest(aTHX_ chr)) \
2938 S_try_amagic_ftest(pTHX_ char chr) {
2941 SV* const arg = TOPs;
2946 if ((PL_op->op_flags & OPf_KIDS)
2949 const char tmpchr = chr;
2951 SV * const tmpsv = amagic_call(arg,
2952 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2953 ftest_amg, AMGf_unary);
2960 next = PL_op->op_next;
2961 if (next->op_type >= OP_FTRREAD &&
2962 next->op_type <= OP_FTBINARY &&
2963 next->op_private & OPpFT_STACKED
2966 /* leave the object alone */
2978 /* This macro is used by the stacked filetest operators :
2979 * if the previous filetest failed, short-circuit and pass its value.
2980 * Else, discard it from the stack and continue. --rgs
2982 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2983 if (!SvTRUE(TOPs)) { RETURN; } \
2984 else { (void)POPs; PUTBACK; } \
2991 /* Not const, because things tweak this below. Not bool, because there's
2992 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2993 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2994 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2995 /* Giving some sort of initial value silences compilers. */
2997 int access_mode = R_OK;
2999 int access_mode = 0;
3002 /* access_mode is never used, but leaving use_access in makes the
3003 conditional compiling below much clearer. */
3006 Mode_t stat_mode = S_IRUSR;
3008 bool effective = FALSE;
3012 switch (PL_op->op_type) {
3013 case OP_FTRREAD: opchar = 'R'; break;
3014 case OP_FTRWRITE: opchar = 'W'; break;
3015 case OP_FTREXEC: opchar = 'X'; break;
3016 case OP_FTEREAD: opchar = 'r'; break;
3017 case OP_FTEWRITE: opchar = 'w'; break;
3018 case OP_FTEEXEC: opchar = 'x'; break;
3020 tryAMAGICftest_MG(opchar);
3022 STACKED_FTEST_CHECK;
3024 switch (PL_op->op_type) {
3026 #if !(defined(HAS_ACCESS) && defined(R_OK))
3032 #if defined(HAS_ACCESS) && defined(W_OK)
3037 stat_mode = S_IWUSR;
3041 #if defined(HAS_ACCESS) && defined(X_OK)
3046 stat_mode = S_IXUSR;
3050 #ifdef PERL_EFF_ACCESS
3053 stat_mode = S_IWUSR;
3057 #ifndef PERL_EFF_ACCESS
3064 #ifdef PERL_EFF_ACCESS
3069 stat_mode = S_IXUSR;
3075 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3076 const char *name = POPpx;
3078 # ifdef PERL_EFF_ACCESS
3079 result = PERL_EFF_ACCESS(name, access_mode);
3081 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3087 result = access(name, access_mode);
3089 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3100 result = my_stat_flags(0);
3104 if (cando(stat_mode, effective, &PL_statcache))
3113 const int op_type = PL_op->op_type;
3118 case OP_FTIS: opchar = 'e'; break;
3119 case OP_FTSIZE: opchar = 's'; break;
3120 case OP_FTMTIME: opchar = 'M'; break;
3121 case OP_FTCTIME: opchar = 'C'; break;
3122 case OP_FTATIME: opchar = 'A'; break;
3124 tryAMAGICftest_MG(opchar);
3126 STACKED_FTEST_CHECK;
3128 result = my_stat_flags(0);
3132 if (op_type == OP_FTIS)
3135 /* You can't dTARGET inside OP_FTIS, because you'll get
3136 "panic: pad_sv po" - the op is not flagged to have a target. */
3140 #if Off_t_size > IVSIZE
3141 PUSHn(PL_statcache.st_size);
3143 PUSHi(PL_statcache.st_size);
3147 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3150 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3153 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3167 switch (PL_op->op_type) {
3168 case OP_FTROWNED: opchar = 'O'; break;
3169 case OP_FTEOWNED: opchar = 'o'; break;
3170 case OP_FTZERO: opchar = 'z'; break;
3171 case OP_FTSOCK: opchar = 'S'; break;
3172 case OP_FTCHR: opchar = 'c'; break;
3173 case OP_FTBLK: opchar = 'b'; break;
3174 case OP_FTFILE: opchar = 'f'; break;
3175 case OP_FTDIR: opchar = 'd'; break;
3176 case OP_FTPIPE: opchar = 'p'; break;
3177 case OP_FTSUID: opchar = 'u'; break;
3178 case OP_FTSGID: opchar = 'g'; break;
3179 case OP_FTSVTX: opchar = 'k'; break;
3181 tryAMAGICftest_MG(opchar);
3183 STACKED_FTEST_CHECK;
3185 /* I believe that all these three are likely to be defined on most every
3186 system these days. */
3188 if(PL_op->op_type == OP_FTSUID) {
3189 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3195 if(PL_op->op_type == OP_FTSGID) {
3196 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3202 if(PL_op->op_type == OP_FTSVTX) {
3203 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3209 result = my_stat_flags(0);
3213 switch (PL_op->op_type) {
3215 if (PL_statcache.st_uid == PL_uid)
3219 if (PL_statcache.st_uid == PL_euid)
3223 if (PL_statcache.st_size == 0)
3227 if (S_ISSOCK(PL_statcache.st_mode))
3231 if (S_ISCHR(PL_statcache.st_mode))
3235 if (S_ISBLK(PL_statcache.st_mode))
3239 if (S_ISREG(PL_statcache.st_mode))
3243 if (S_ISDIR(PL_statcache.st_mode))
3247 if (S_ISFIFO(PL_statcache.st_mode))
3252 if (PL_statcache.st_mode & S_ISUID)
3258 if (PL_statcache.st_mode & S_ISGID)
3264 if (PL_statcache.st_mode & S_ISVTX)
3278 tryAMAGICftest_MG('l');
3279 result = my_lstat_flags(0);
3284 if (S_ISLNK(PL_statcache.st_mode))
3299 tryAMAGICftest_MG('t');
3301 STACKED_FTEST_CHECK;
3303 if (PL_op->op_flags & OPf_REF)
3305 else if (isGV_with_GP(TOPs))
3306 gv = MUTABLE_GV(POPs);
3307 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3308 gv = MUTABLE_GV(SvRV(POPs));
3311 name = SvPV_nomg(tmpsv, namelen);
3312 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3315 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3316 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3317 else if (tmpsv && SvOK(tmpsv)) {
3325 if (PerlLIO_isatty(fd))
3330 #if defined(atarist) /* this will work with atariST. Configure will
3331 make guesses for other systems. */
3332 # define FILE_base(f) ((f)->_base)
3333 # define FILE_ptr(f) ((f)->_ptr)
3334 # define FILE_cnt(f) ((f)->_cnt)
3335 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3346 register STDCHAR *s;
3352 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3354 STACKED_FTEST_CHECK;
3356 if (PL_op->op_flags & OPf_REF)
3358 else if (isGV_with_GP(TOPs))
3359 gv = MUTABLE_GV(POPs);
3360 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3361 gv = MUTABLE_GV(SvRV(POPs));
3367 if (gv == PL_defgv) {
3369 io = GvIO(PL_statgv);
3372 goto really_filename;
3377 PL_laststatval = -1;
3378 sv_setpvs(PL_statname, "");
3379 io = GvIO(PL_statgv);
3381 if (io && IoIFP(io)) {
3382 if (! PerlIO_has_base(IoIFP(io)))
3383 DIE(aTHX_ "-T and -B not implemented on filehandles");
3384 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3385 if (PL_laststatval < 0)
3387 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3388 if (PL_op->op_type == OP_FTTEXT)
3393 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3394 i = PerlIO_getc(IoIFP(io));
3396 (void)PerlIO_ungetc(IoIFP(io),i);
3398 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3400 len = PerlIO_get_bufsiz(IoIFP(io));
3401 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3402 /* sfio can have large buffers - limit to 512 */
3407 report_evil_fh(cGVOP_gv);
3408 SETERRNO(EBADF,RMS_IFI);
3416 PL_laststype = OP_STAT;
3417 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3418 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3419 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3421 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3424 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3425 if (PL_laststatval < 0) {
3426 (void)PerlIO_close(fp);
3429 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3430 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3431 (void)PerlIO_close(fp);
3433 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3434 RETPUSHNO; /* special case NFS directories */
3435 RETPUSHYES; /* null file is anything */
3440 /* now scan s to look for textiness */
3441 /* XXX ASCII dependent code */
3443 #if defined(DOSISH) || defined(USEMYBINMODE)
3444 /* ignore trailing ^Z on short files */
3445 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3449 for (i = 0; i < len; i++, s++) {
3450 if (!*s) { /* null never allowed in text */
3455 else if (!(isPRINT(*s) || isSPACE(*s)))
3458 else if (*s & 128) {
3460 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3463 /* utf8 characters don't count as odd */
3464 if (UTF8_IS_START(*s)) {
3465 int ulen = UTF8SKIP(s);
3466 if (ulen < len - i) {
3468 for (j = 1; j < ulen; j++) {
3469 if (!UTF8_IS_CONTINUATION(s[j]))
3472 --ulen; /* loop does extra increment */
3482 *s != '\n' && *s != '\r' && *s != '\b' &&
3483 *s != '\t' && *s != '\f' && *s != 27)
3488 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3499 const char *tmps = NULL;
3503 SV * const sv = POPs;
3504 if (PL_op->op_flags & OPf_SPECIAL) {
3505 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3507 else if (isGV_with_GP(sv)) {
3508 gv = MUTABLE_GV(sv);
3510 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
3511 gv = MUTABLE_GV(SvRV(sv));
3514 tmps = SvPV_nolen_const(sv);
3518 if( !gv && (!tmps || !*tmps) ) {
3519 HV * const table = GvHVn(PL_envgv);
3522 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3523 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3525 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3530 deprecate("chdir('') or chdir(undef) as chdir()");
3531 tmps = SvPV_nolen_const(*svp);
3535 TAINT_PROPER("chdir");
3540 TAINT_PROPER("chdir");
3543 IO* const io = GvIO(gv);
3546 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3547 } else if (IoIFP(io)) {
3548 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3552 SETERRNO(EBADF, RMS_IFI);
3558 SETERRNO(EBADF,RMS_IFI);
3562 DIE(aTHX_ PL_no_func, "fchdir");
3566 PUSHi( PerlDir_chdir(tmps) >= 0 );
3568 /* Clear the DEFAULT element of ENV so we'll get the new value
3570 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3577 dVAR; dSP; dMARK; dTARGET;
3578 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3589 char * const tmps = POPpx;
3590 TAINT_PROPER("chroot");
3591 PUSHi( chroot(tmps) >= 0 );
3594 DIE(aTHX_ PL_no_func, "chroot");
3602 const char * const tmps2 = POPpconstx;
3603 const char * const tmps = SvPV_nolen_const(TOPs);
3604 TAINT_PROPER("rename");
3606 anum = PerlLIO_rename(tmps, tmps2);
3608 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3609 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3612 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3613 (void)UNLINK(tmps2);
3614 if (!(anum = link(tmps, tmps2)))
3615 anum = UNLINK(tmps);
3623 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3627 const int op_type = PL_op->op_type;
3631 if (op_type == OP_LINK)
3632 DIE(aTHX_ PL_no_func, "link");
3634 # ifndef HAS_SYMLINK
3635 if (op_type == OP_SYMLINK)
3636 DIE(aTHX_ PL_no_func, "symlink");
3640 const char * const tmps2 = POPpconstx;
3641 const char * const tmps = SvPV_nolen_const(TOPs);
3642 TAINT_PROPER(PL_op_desc[op_type]);
3644 # if defined(HAS_LINK)
3645 # if defined(HAS_SYMLINK)
3646 /* Both present - need to choose which. */
3647 (op_type == OP_LINK) ?
3648 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3650 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3651 PerlLIO_link(tmps, tmps2);
3654 # if defined(HAS_SYMLINK)
3655 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3656 symlink(tmps, tmps2);
3661 SETi( result >= 0 );
3668 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3679 char buf[MAXPATHLEN];
3682 #ifndef INCOMPLETE_TAINTS
3686 len = readlink(tmps, buf, sizeof(buf) - 1);
3693 RETSETUNDEF; /* just pretend it's a normal file */
3697 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3699 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3701 char * const save_filename = filename;
3706 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3708 PERL_ARGS_ASSERT_DOONELINER;
3710 Newx(cmdline, size, char);
3711 my_strlcpy(cmdline, cmd, size);
3712 my_strlcat(cmdline, " ", size);
3713 for (s = cmdline + strlen(cmdline); *filename; ) {
3717 if (s - cmdline < size)
3718 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3719 myfp = PerlProc_popen(cmdline, "r");
3723 SV * const tmpsv = sv_newmortal();
3724 /* Need to save/restore 'PL_rs' ?? */
3725 s = sv_gets(tmpsv, myfp, 0);
3726 (void)PerlProc_pclose(myfp);
3730 #ifdef HAS_SYS_ERRLIST
3735 /* you don't see this */
3736 const char * const errmsg =
3737 #ifdef HAS_SYS_ERRLIST
3745 if (instr(s, errmsg)) {
3752 #define EACCES EPERM
3754 if (instr(s, "cannot make"))
3755 SETERRNO(EEXIST,RMS_FEX);
3756 else if (instr(s, "existing file"))
3757 SETERRNO(EEXIST,RMS_FEX);
3758 else if (instr(s, "ile exists"))
3759 SETERRNO(EEXIST,RMS_FEX);
3760 else if (instr(s, "non-exist"))
3761 SETERRNO(ENOENT,RMS_FNF);
3762 else if (instr(s, "does not exist"))
3763 SETERRNO(ENOENT,RMS_FNF);
3764 else if (instr(s, "not empty"))
3765 SETERRNO(EBUSY,SS_DEVOFFLINE);
3766 else if (instr(s, "cannot access"))
3767 SETERRNO(EACCES,RMS_PRV);
3769 SETERRNO(EPERM,RMS_PRV);
3772 else { /* some mkdirs return no failure indication */
3773 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3774 if (PL_op->op_type == OP_RMDIR)
3779 SETERRNO(EACCES,RMS_PRV); /* a guess */
3788 /* This macro removes trailing slashes from a directory name.
3789 * Different operating and file systems take differently to
3790 * trailing slashes. According to POSIX 1003.1 1996 Edition
3791 * any number of trailing slashes should be allowed.
3792 * Thusly we snip them away so that even non-conforming
3793 * systems are happy.
3794 * We should probably do this "filtering" for all
3795 * the functions that expect (potentially) directory names:
3796 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3797 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3799 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3800 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3803 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3804 (tmps) = savepvn((tmps), (len)); \
3814 const int mode = (MAXARG > 1) ? POPi : 0777;
3816 TRIMSLASHES(tmps,len,copy);
3818 TAINT_PROPER("mkdir");
3820 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3824 SETi( dooneliner("mkdir", tmps) );
3825 oldumask = PerlLIO_umask(0);
3826 PerlLIO_umask(oldumask);
3827 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3842 TRIMSLASHES(tmps,len,copy);
3843 TAINT_PROPER("rmdir");
3845 SETi( PerlDir_rmdir(tmps) >= 0 );
3847 SETi( dooneliner("rmdir", tmps) );
3854 /* Directory calls. */
3858 #if defined(Direntry_t) && defined(HAS_READDIR)
3860 const char * const dirname = POPpconstx;
3861 GV * const gv = MUTABLE_GV(POPs);
3862 register IO * const io = GvIOn(gv);
3867 if ((IoIFP(io) || IoOFP(io)))
3868 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3869 "Opening filehandle %s also as a directory",
3872 PerlDir_close(IoDIRP(io));
3873 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3879 SETERRNO(EBADF,RMS_DIR);
3882 DIE(aTHX_ PL_no_dir_func, "opendir");
3888 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3889 DIE(aTHX_ PL_no_dir_func, "readdir");
3891 #if !defined(I_DIRENT) && !defined(VMS)
3892 Direntry_t *readdir (DIR *);
3898 const I32 gimme = GIMME;
3899 GV * const gv = MUTABLE_GV(POPs);
3900 register const Direntry_t *dp;
3901 register IO * const io = GvIOn(gv);
3903 if (!io || !IoDIRP(io)) {
3904 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3905 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3910 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3914 sv = newSVpvn(dp->d_name, dp->d_namlen);
3916 sv = newSVpv(dp->d_name, 0);
3918 #ifndef INCOMPLETE_TAINTS
3919 if (!(IoFLAGS(io) & IOf_UNTAINT))
3923 } while (gimme == G_ARRAY);
3925 if (!dp && gimme != G_ARRAY)
3932 SETERRNO(EBADF,RMS_ISI);
3933 if (GIMME == G_ARRAY)
3942 #if defined(HAS_TELLDIR) || defined(telldir)
3944 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3945 /* XXX netbsd still seemed to.
3946 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3947 --JHI 1999-Feb-02 */
3948 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3949 long telldir (DIR *);
3951 GV * const gv = MUTABLE_GV(POPs);
3952 register IO * const io = GvIOn(gv);
3954 if (!io || !IoDIRP(io)) {
3955 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3956 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3960 PUSHi( PerlDir_tell(IoDIRP(io)) );
3964 SETERRNO(EBADF,RMS_ISI);
3967 DIE(aTHX_ PL_no_dir_func, "telldir");
3973 #if defined(HAS_SEEKDIR) || defined(seekdir)
3975 const long along = POPl;
3976 GV * const gv = MUTABLE_GV(POPs);
3977 register IO * const io = GvIOn(gv);
3979 if (!io || !IoDIRP(io)) {
3980 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3981 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3984 (void)PerlDir_seek(IoDIRP(io), along);
3989 SETERRNO(EBADF,RMS_ISI);
3992 DIE(aTHX_ PL_no_dir_func, "seekdir");
3998 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4000 GV * const gv = MUTABLE_GV(POPs);
4001 register IO * const io = GvIOn(gv);
4003 if (!io || !IoDIRP(io)) {
4004 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4005 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
4008 (void)PerlDir_rewind(IoDIRP(io));
4012 SETERRNO(EBADF,RMS_ISI);
4015 DIE(aTHX_ PL_no_dir_func, "rewinddir");
4021 #if defined(Direntry_t) && defined(HAS_READDIR)
4023 GV * const gv = MUTABLE_GV(POPs);
4024 register IO * const io = GvIOn(gv);
4026 if (!io || !IoDIRP(io)) {
4027 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4028 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
4031 #ifdef VOID_CLOSEDIR
4032 PerlDir_close(IoDIRP(io));
4034 if (PerlDir_close(IoDIRP(io)) < 0) {
4035 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4044 SETERRNO(EBADF,RMS_IFI);
4047 DIE(aTHX_ PL_no_dir_func, "closedir");
4051 /* Process control. */
4060 PERL_FLUSHALL_FOR_CHILD;
4061 childpid = PerlProc_fork();
4065 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
4067 SvREADONLY_off(GvSV(tmpgv));
4068 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4069 SvREADONLY_on(GvSV(tmpgv));
4071 #ifdef THREADS_HAVE_PIDS
4072 PL_ppid = (IV)getppid();
4074 #ifdef PERL_USES_PL_PIDSTATUS
4075 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4081 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4086 PERL_FLUSHALL_FOR_CHILD;
4087 childpid = PerlProc_fork();
4093 DIE(aTHX_ PL_no_func, "fork");
4100 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4105 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4106 childpid = wait4pid(-1, &argflags, 0);
4108 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4113 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4114 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4115 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4117 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4122 DIE(aTHX_ PL_no_func, "wait");
4128 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4130 const int optype = POPi;
4131 const Pid_t pid = TOPi;
4135 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4136 result = wait4pid(pid, &argflags, optype);
4138 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4143 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4144 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4145 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4147 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4152 DIE(aTHX_ PL_no_func, "waitpid");
4158 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4159 #if defined(__LIBCATAMOUNT__)
4160 PL_statusvalue = -1;
4169 while (++MARK <= SP) {
4170 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4175 TAINT_PROPER("system");
4177 PERL_FLUSHALL_FOR_CHILD;
4178 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4184 if (PerlProc_pipe(pp) >= 0)
4186 while ((childpid = PerlProc_fork()) == -1) {
4187 if (errno != EAGAIN) {
4192 PerlLIO_close(pp[0]);
4193 PerlLIO_close(pp[1]);
4200 Sigsave_t ihand,qhand; /* place to save signals during system() */
4204 PerlLIO_close(pp[1]);
4206 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4207 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4210 result = wait4pid(childpid, &status, 0);
4211 } while (result == -1 && errno == EINTR);
4213 (void)rsignal_restore(SIGINT, &ihand);
4214 (void)rsignal_restore(SIGQUIT, &qhand);
4216 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4217 do_execfree(); /* free any memory child malloced on fork */
4224 while (n < sizeof(int)) {
4225 n1 = PerlLIO_read(pp[0],
4226 (void*)(((char*)&errkid)+n),
4232 PerlLIO_close(pp[0]);
4233 if (n) { /* Error */
4234 if (n != sizeof(int))
4235 DIE(aTHX_ "panic: kid popen errno read");
4236 errno = errkid; /* Propagate errno from kid */
4237 STATUS_NATIVE_CHILD_SET(-1);
4240 XPUSHi(STATUS_CURRENT);
4244 PerlLIO_close(pp[0]);
4245 #if defined(HAS_FCNTL) && defined(F_SETFD)
4246 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4249 if (PL_op->op_flags & OPf_STACKED) {
4250 SV * const really = *++MARK;
4251 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4253 else if (SP - MARK != 1)
4254 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4256 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4260 #else /* ! FORK or VMS or OS/2 */
4263 if (PL_op->op_flags & OPf_STACKED) {
4264 SV * const really = *++MARK;
4265 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4266 value = (I32)do_aspawn(really, MARK, SP);
4268 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4271 else if (SP - MARK != 1) {
4272 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4273 value = (I32)do_aspawn(NULL, MARK, SP);
4275 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4279 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4281 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4283 STATUS_NATIVE_CHILD_SET(value);
4286 XPUSHi(result ? value : STATUS_CURRENT);
4287 #endif /* !FORK or VMS or OS/2 */
4294 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4299 while (++MARK <= SP) {
4300 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4305 TAINT_PROPER("exec");
4307 PERL_FLUSHALL_FOR_CHILD;
4308 if (PL_op->op_flags & OPf_STACKED) {
4309 SV * const really = *++MARK;
4310 value = (I32)do_aexec(really, MARK, SP);
4312 else if (SP - MARK != 1)
4314 value = (I32)vms_do_aexec(NULL, MARK, SP);
4318 (void ) do_aspawn(NULL, MARK, SP);
4322 value = (I32)do_aexec(NULL, MARK, SP);
4327 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4330 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4333 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4347 # ifdef THREADS_HAVE_PIDS
4348 if (PL_ppid != 1 && getppid() == 1)
4349 /* maybe the parent process has died. Refresh ppid cache */
4353 XPUSHi( getppid() );
4357 DIE(aTHX_ PL_no_func, "getppid");
4366 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4369 pgrp = (I32)BSD_GETPGRP(pid);
4371 if (pid != 0 && pid != PerlProc_getpid())
4372 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4378 DIE(aTHX_ PL_no_func, "getpgrp()");
4398 TAINT_PROPER("setpgrp");
4400 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4402 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4403 || (pid != 0 && pid != PerlProc_getpid()))
4405 DIE(aTHX_ "setpgrp can't take arguments");
4407 SETi( setpgrp() >= 0 );
4408 #endif /* USE_BSDPGRP */
4411 DIE(aTHX_ PL_no_func, "setpgrp()");
4415 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4416 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4418 # define PRIORITY_WHICH_T(which) which
4423 #ifdef HAS_GETPRIORITY
4425 const int who = POPi;
4426 const int which = TOPi;
4427 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4430 DIE(aTHX_ PL_no_func, "getpriority()");
4436 #ifdef HAS_SETPRIORITY
4438 const int niceval = POPi;
4439 const int who = POPi;
4440 const int which = TOPi;
4441 TAINT_PROPER("setpriority");
4442 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4445 DIE(aTHX_ PL_no_func, "setpriority()");
4449 #undef PRIORITY_WHICH_T
4457 XPUSHn( time(NULL) );
4459 XPUSHi( time(NULL) );
4471 (void)PerlProc_times(&PL_timesbuf);
4473 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4474 /* struct tms, though same data */
4478 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4479 if (GIMME == G_ARRAY) {
4480 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4481 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4482 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4490 if (GIMME == G_ARRAY) {
4497 DIE(aTHX_ "times not implemented");
4499 #endif /* HAS_TIMES */
4502 /* The 32 bit int year limits the times we can represent to these
4503 boundaries with a few days wiggle room to account for time zone
4506 /* Sat Jan 3 00:00:00 -2147481748 */
4507 #define TIME_LOWER_BOUND -67768100567755200.0
4508 /* Sun Dec 29 12:00:00 2147483647 */
4509 #define TIME_UPPER_BOUND 67767976233316800.0
4518 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4519 static const char * const dayname[] =
4520 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4521 static const char * const monname[] =
4522 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4523 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4528 when = (Time64_T)now;
4531 NV input = Perl_floor(POPn);
4532 when = (Time64_T)input;
4533 if (when != input) {
4534 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4535 "%s(%.0" NVff ") too large", opname, input);
4539 if ( TIME_LOWER_BOUND > when ) {
4540 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4541 "%s(%.0" NVff ") too small", opname, when);
4544 else if( when > TIME_UPPER_BOUND ) {
4545 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4546 "%s(%.0" NVff ") too large", opname, when);
4550 if (PL_op->op_type == OP_LOCALTIME)
4551 err = S_localtime64_r(&when, &tmbuf);
4553 err = S_gmtime64_r(&when, &tmbuf);
4557 /* XXX %lld broken for quads */
4558 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4559 "%s(%.0" NVff ") failed", opname, when);
4562 if (GIMME != G_ARRAY) { /* scalar context */
4564 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4565 double year = (double)tmbuf.tm_year + 1900;
4572 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4573 dayname[tmbuf.tm_wday],
4574 monname[tmbuf.tm_mon],
4582 else { /* list context */
4588 mPUSHi(tmbuf.tm_sec);
4589 mPUSHi(tmbuf.tm_min);
4590 mPUSHi(tmbuf.tm_hour);
4591 mPUSHi(tmbuf.tm_mday);
4592 mPUSHi(tmbuf.tm_mon);
4593 mPUSHn(tmbuf.tm_year);
4594 mPUSHi(tmbuf.tm_wday);
4595 mPUSHi(tmbuf.tm_yday);
4596 mPUSHi(tmbuf.tm_isdst);
4607 anum = alarm((unsigned int)anum);
4613 DIE(aTHX_ PL_no_func, "alarm");
4624 (void)time(&lasttime);
4629 PerlProc_sleep((unsigned int)duration);
4632 XPUSHi(when - lasttime);
4636 /* Shared memory. */
4637 /* Merged with some message passing. */
4641 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4642 dVAR; dSP; dMARK; dTARGET;
4643 const int op_type = PL_op->op_type;
4648 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4651 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4654 value = (I32)(do_semop(MARK, SP) >= 0);
4657 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4673 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4674 dVAR; dSP; dMARK; dTARGET;
4675 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4682 DIE(aTHX_ "System V IPC is not implemented on this machine");
4688 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4689 dVAR; dSP; dMARK; dTARGET;
4690 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4698 PUSHp(zero_but_true, ZBTLEN);
4706 /* I can't const this further without getting warnings about the types of
4707 various arrays passed in from structures. */
4709 S_space_join_names_mortal(pTHX_ char *const *array)
4713 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4715 if (array && *array) {
4716 target = newSVpvs_flags("", SVs_TEMP);
4718 sv_catpv(target, *array);
4721 sv_catpvs(target, " ");
4724 target = sv_mortalcopy(&PL_sv_no);
4729 /* Get system info. */
4733 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4735 I32 which = PL_op->op_type;
4736 register char **elem;
4738 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4739 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4740 struct hostent *gethostbyname(Netdb_name_t);
4741 struct hostent *gethostent(void);
4743 struct hostent *hent = NULL;
4747 if (which == OP_GHBYNAME) {
4748 #ifdef HAS_GETHOSTBYNAME
4749 const char* const name = POPpbytex;
4750 hent = PerlSock_gethostbyname(name);
4752 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4755 else if (which == OP_GHBYADDR) {
4756 #ifdef HAS_GETHOSTBYADDR
4757 const int addrtype = POPi;
4758 SV * const addrsv = POPs;
4760 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4762 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4764 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4768 #ifdef HAS_GETHOSTENT
4769 hent = PerlSock_gethostent();
4771 DIE(aTHX_ PL_no_sock_func, "gethostent");
4774 #ifdef HOST_NOT_FOUND
4776 #ifdef USE_REENTRANT_API
4777 # ifdef USE_GETHOSTENT_ERRNO
4778 h_errno = PL_reentrant_buffer->_gethostent_errno;
4781 STATUS_UNIX_SET(h_errno);
4785 if (GIMME != G_ARRAY) {
4786 PUSHs(sv = sv_newmortal());
4788 if (which == OP_GHBYNAME) {
4790 sv_setpvn(sv, hent->h_addr, hent->h_length);
4793 sv_setpv(sv, (char*)hent->h_name);
4799 mPUSHs(newSVpv((char*)hent->h_name, 0));
4800 PUSHs(space_join_names_mortal(hent->h_aliases));
4801 mPUSHi(hent->h_addrtype);
4802 len = hent->h_length;
4805 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4806 mXPUSHp(*elem, len);
4810 mPUSHp(hent->h_addr, len);
4812 PUSHs(sv_mortalcopy(&PL_sv_no));
4817 DIE(aTHX_ PL_no_sock_func, "gethostent");
4823 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4825 I32 which = PL_op->op_type;
4827 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4828 struct netent *getnetbyaddr(Netdb_net_t, int);
4829 struct netent *getnetbyname(Netdb_name_t);
4830 struct netent *getnetent(void);
4832 struct netent *nent;
4834 if (which == OP_GNBYNAME){
4835 #ifdef HAS_GETNETBYNAME
4836 const char * const name = POPpbytex;
4837 nent = PerlSock_getnetbyname(name);
4839 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4842 else if (which == OP_GNBYADDR) {
4843 #ifdef HAS_GETNETBYADDR
4844 const int addrtype = POPi;
4845 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4846 nent = PerlSock_getnetbyaddr(addr, addrtype);
4848 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4852 #ifdef HAS_GETNETENT
4853 nent = PerlSock_getnetent();
4855 DIE(aTHX_ PL_no_sock_func, "getnetent");
4858 #ifdef HOST_NOT_FOUND
4860 #ifdef USE_REENTRANT_API
4861 # ifdef USE_GETNETENT_ERRNO
4862 h_errno = PL_reentrant_buffer->_getnetent_errno;
4865 STATUS_UNIX_SET(h_errno);
4870 if (GIMME != G_ARRAY) {
4871 PUSHs(sv = sv_newmortal());
4873 if (which == OP_GNBYNAME)
4874 sv_setiv(sv, (IV)nent->n_net);
4876 sv_setpv(sv, nent->n_name);
4882 mPUSHs(newSVpv(nent->n_name, 0));
4883 PUSHs(space_join_names_mortal(nent->n_aliases));
4884 mPUSHi(nent->n_addrtype);
4885 mPUSHi(nent->n_net);
4890 DIE(aTHX_ PL_no_sock_func, "getnetent");
4896 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4898 I32 which = PL_op->op_type;
4900 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4901 struct protoent *getprotobyname(Netdb_name_t);
4902 struct protoent *getprotobynumber(int);
4903 struct protoent *getprotoent(void);
4905 struct protoent *pent;
4907 if (which == OP_GPBYNAME) {
4908 #ifdef HAS_GETPROTOBYNAME
4909 const char* const name = POPpbytex;
4910 pent = PerlSock_getprotobyname(name);
4912 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4915 else if (which == OP_GPBYNUMBER) {
4916 #ifdef HAS_GETPROTOBYNUMBER
4917 const int number = POPi;
4918 pent = PerlSock_getprotobynumber(number);
4920 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4924 #ifdef HAS_GETPROTOENT
4925 pent = PerlSock_getprotoent();
4927 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4931 if (GIMME != G_ARRAY) {
4932 PUSHs(sv = sv_newmortal());
4934 if (which == OP_GPBYNAME)
4935 sv_setiv(sv, (IV)pent->p_proto);
4937 sv_setpv(sv, pent->p_name);
4943 mPUSHs(newSVpv(pent->p_name, 0));
4944 PUSHs(space_join_names_mortal(pent->p_aliases));
4945 mPUSHi(pent->p_proto);
4950 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4956 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4958 I32 which = PL_op->op_type;
4960 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4961 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4962 struct servent *getservbyport(int, Netdb_name_t);
4963 struct servent *getservent(void);
4965 struct servent *sent;
4967 if (which == OP_GSBYNAME) {
4968 #ifdef HAS_GETSERVBYNAME
4969 const char * const proto = POPpbytex;
4970 const char * const name = POPpbytex;
4971 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4973 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4976 else if (which == OP_GSBYPORT) {
4977 #ifdef HAS_GETSERVBYPORT
4978 const char * const proto = POPpbytex;
4979 unsigned short port = (unsigned short)POPu;
4981 port = PerlSock_htons(port);
4983 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4985 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4989 #ifdef HAS_GETSERVENT
4990 sent = PerlSock_getservent();
4992 DIE(aTHX_ PL_no_sock_func, "getservent");
4996 if (GIMME != G_ARRAY) {
4997 PUSHs(sv = sv_newmortal());
4999 if (which == OP_GSBYNAME) {
5001 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5003 sv_setiv(sv, (IV)(sent->s_port));
5007 sv_setpv(sv, sent->s_name);
5013 mPUSHs(newSVpv(sent->s_name, 0));
5014 PUSHs(space_join_names_mortal(sent->s_aliases));
5016 mPUSHi(PerlSock_ntohs(sent->s_port));
5018 mPUSHi(sent->s_port);
5020 mPUSHs(newSVpv(sent->s_proto, 0));
5025 DIE(aTHX_ PL_no_sock_func, "getservent");
5031 #ifdef HAS_SETHOSTENT
5033 PerlSock_sethostent(TOPi);
5036 DIE(aTHX_ PL_no_sock_func, "sethostent");
5042 #ifdef HAS_SETNETENT
5044 (void)PerlSock_setnetent(TOPi);
5047 DIE(aTHX_ PL_no_sock_func, "setnetent");
5053 #ifdef HAS_SETPROTOENT
5055 (void)PerlSock_setprotoent(TOPi);
5058 DIE(aTHX_ PL_no_sock_func, "setprotoent");
5064 #ifdef HAS_SETSERVENT
5066 (void)PerlSock_setservent(TOPi);
5069 DIE(aTHX_ PL_no_sock_func, "setservent");
5075 #ifdef HAS_ENDHOSTENT
5077 PerlSock_endhostent();