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();
425 do_join(TARG, &PL_sv_no, MARK, SP);
429 else if (SP == MARK) {
438 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
439 /* well-formed exception supplied */
441 else if (SvROK(ERRSV)) {
444 else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
445 exsv = sv_mortalcopy(ERRSV);
446 sv_catpvs(exsv, "\t...caught");
449 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
451 if (SvROK(exsv) && !PL_warnhook)
452 Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
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) || (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);
511 Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv,
512 const MAGIC *const mg, const U32 flags, U32 argc, ...)
514 PERL_ARGS_ASSERT_TIED_METHOD;
516 /* Ensure that our flag bits do not overlap. */
517 assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
518 assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
519 assert((TIED_METHOD_SAY & G_WANT) == 0);
522 PUSHs(SvTIED_obj(sv, mg));
523 if (flags & TIED_METHOD_ARGUMENTS_ON_STACK)
526 const U32 mortalize_not_needed
527 = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
529 va_start(args, argc);
531 SV *const arg = va_arg(args, SV *);
532 if(mortalize_not_needed)
541 ENTER_with_name("call_tied_method");
542 if (flags & TIED_METHOD_SAY) {
543 /* local $\ = "\n" */
544 SAVEGENERICSV(PL_ors_sv);
545 PL_ors_sv = newSVpvs("\n");
547 call_method(methname, flags & G_WANT);
548 LEAVE_with_name("call_tied_method");
552 #define tied_method0(a,b,c,d) \
553 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
554 #define tied_method1(a,b,c,d,e) \
555 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
556 #define tied_method2(a,b,c,d,e,f) \
557 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
570 GV * const gv = MUTABLE_GV(*++MARK);
572 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
573 DIE(aTHX_ PL_no_usym, "filehandle");
575 if ((io = GvIOp(gv))) {
577 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
580 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
581 "Opening dirhandle %s also as a file",
584 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
586 /* Method's args are same as ours ... */
587 /* ... except handle is replaced by the object */
588 return Perl_tied_method(aTHX_ "OPEN", mark - 1, MUTABLE_SV(io), mg,
589 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
601 tmps = SvPV_const(sv, len);
602 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
605 PUSHi( (I32)PL_forkprocess );
606 else if (PL_forkprocess == 0) /* we are a new child */
616 GV * const gv = (MAXARG == 0) ? PL_defoutgv : MUTABLE_GV(POPs);
622 IO * const io = GvIO(gv);
624 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
626 return tied_method0("CLOSE", SP, MUTABLE_SV(io), mg);
630 PUSHs(boolSV(do_close(gv, TRUE)));
643 GV * const wgv = MUTABLE_GV(POPs);
644 GV * const rgv = MUTABLE_GV(POPs);
649 if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
650 DIE(aTHX_ PL_no_usym, "filehandle");
655 do_close(rgv, FALSE);
657 do_close(wgv, FALSE);
659 if (PerlProc_pipe(fd) < 0)
662 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
663 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
664 IoOFP(rstio) = IoIFP(rstio);
665 IoIFP(wstio) = IoOFP(wstio);
666 IoTYPE(rstio) = IoTYPE_RDONLY;
667 IoTYPE(wstio) = IoTYPE_WRONLY;
669 if (!IoIFP(rstio) || !IoOFP(wstio)) {
671 PerlIO_close(IoIFP(rstio));
673 PerlLIO_close(fd[0]);
675 PerlIO_close(IoOFP(wstio));
677 PerlLIO_close(fd[1]);
680 #if defined(HAS_FCNTL) && defined(F_SETFD)
681 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
682 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
689 DIE(aTHX_ PL_no_func, "pipe");
703 gv = MUTABLE_GV(POPs);
707 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
709 return tied_method0("FILENO", SP, MUTABLE_SV(io), mg);
712 if (!io || !(fp = IoIFP(io))) {
713 /* Can't do this because people seem to do things like
714 defined(fileno($foo)) to check whether $foo is a valid fh.
721 PUSHi(PerlIO_fileno(fp));
734 anum = PerlLIO_umask(022);
735 /* setting it to 022 between the two calls to umask avoids
736 * to have a window where the umask is set to 0 -- meaning
737 * that another thread could create world-writeable files. */
739 (void)PerlLIO_umask(anum);
742 anum = PerlLIO_umask(POPi);
743 TAINT_PROPER("umask");
746 /* Only DIE if trying to restrict permissions on "user" (self).
747 * Otherwise it's harmless and more useful to just return undef
748 * since 'group' and 'other' concepts probably don't exist here. */
749 if (MAXARG >= 1 && (POPi & 0700))
750 DIE(aTHX_ "umask not implemented");
751 XPUSHs(&PL_sv_undef);
770 gv = MUTABLE_GV(POPs);
774 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
776 /* This takes advantage of the implementation of the varargs
777 function, which I don't think that the optimiser will be able to
778 figure out. Although, as it's a static function, in theory it
780 return Perl_tied_method(aTHX_ "BINMODE", SP, MUTABLE_SV(io), mg,
781 G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
782 discp ? 1 : 0, discp);
786 if (!io || !(fp = IoIFP(io))) {
788 SETERRNO(EBADF,RMS_IFI);
795 const char *d = NULL;
798 d = SvPV_const(discp, len);
799 mode = mode_from_discipline(d, len);
800 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
801 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
802 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
823 const I32 markoff = MARK - PL_stack_base;
824 const char *methname;
825 int how = PERL_MAGIC_tied;
829 switch(SvTYPE(varsv)) {
831 methname = "TIEHASH";
832 HvEITER_set(MUTABLE_HV(varsv), 0);
835 methname = "TIEARRAY";
839 if (isGV_with_GP(varsv)) {
840 if (SvFAKE(varsv) && !(GvFLAGS(varsv) & GVf_TIEWARNED)) {
841 deprecate("tie on a handle without *");
842 GvFLAGS(varsv) |= GVf_TIEWARNED;
844 methname = "TIEHANDLE";
845 how = PERL_MAGIC_tiedscalar;
846 /* For tied filehandles, we apply tiedscalar magic to the IO
847 slot of the GP rather than the GV itself. AMS 20010812 */
849 GvIOp(varsv) = newIO();
850 varsv = MUTABLE_SV(GvIOp(varsv));
855 methname = "TIESCALAR";
856 how = PERL_MAGIC_tiedscalar;
860 if (sv_isobject(*MARK)) { /* Calls GET magic. */
861 ENTER_with_name("call_TIE");
862 PUSHSTACKi(PERLSI_MAGIC);
864 EXTEND(SP,(I32)items);
868 call_method(methname, G_SCALAR);
871 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
872 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
873 * wrong error message, and worse case, supreme action at a distance.
874 * (Sorry obfuscation writers. You're not going to be given this one.)
877 const char *name = SvPV_nomg_const(*MARK, len);
878 stash = gv_stashpvn(name, len, 0);
879 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
880 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
881 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
883 ENTER_with_name("call_TIE");
884 PUSHSTACKi(PERLSI_MAGIC);
886 EXTEND(SP,(I32)items);
890 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
896 if (sv_isobject(sv)) {
897 sv_unmagic(varsv, how);
898 /* Croak if a self-tie on an aggregate is attempted. */
899 if (varsv == SvRV(sv) &&
900 (SvTYPE(varsv) == SVt_PVAV ||
901 SvTYPE(varsv) == SVt_PVHV))
903 "Self-ties of arrays and hashes are not supported");
904 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
906 LEAVE_with_name("call_TIE");
907 SP = PL_stack_base + markoff;
917 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
918 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
920 if (isGV_with_GP(sv)) {
921 if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
922 deprecate("untie on a handle without *");
923 GvFLAGS(sv) |= GVf_TIEWARNED;
925 if (!(sv = MUTABLE_SV(GvIOp(sv))))
929 if ((mg = SvTIED_mg(sv, how))) {
930 SV * const obj = SvRV(SvTIED_obj(sv, mg));
932 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
934 if (gv && isGV(gv) && (cv = GvCV(gv))) {
936 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
937 mXPUSHi(SvREFCNT(obj) - 1);
939 ENTER_with_name("call_UNTIE");
940 call_sv(MUTABLE_SV(cv), G_VOID);
941 LEAVE_with_name("call_UNTIE");
944 else if (mg && SvREFCNT(obj) > 1) {
945 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
946 "untie attempted while %"UVuf" inner references still exist",
947 (UV)SvREFCNT(obj) - 1 ) ;
951 sv_unmagic(sv, how) ;
961 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
962 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
964 if (isGV_with_GP(sv)) {
965 if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
966 deprecate("tied on a handle without *");
967 GvFLAGS(sv) |= GVf_TIEWARNED;
969 if (!(sv = MUTABLE_SV(GvIOp(sv))))
973 if ((mg = SvTIED_mg(sv, how))) {
974 SV *osv = SvTIED_obj(sv, mg);
975 if (osv == mg->mg_obj)
976 osv = sv_mortalcopy(osv);
990 HV * const hv = MUTABLE_HV(POPs);
991 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
992 stash = gv_stashsv(sv, 0);
993 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
995 require_pv("AnyDBM_File.pm");
997 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
998 DIE(aTHX_ "No dbm on this machine");
1008 mPUSHu(O_RDWR|O_CREAT);
1013 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1016 if (!sv_isobject(TOPs)) {
1024 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1028 if (sv_isobject(TOPs)) {
1029 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1030 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1047 struct timeval timebuf;
1048 struct timeval *tbuf = &timebuf;
1051 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1056 # if BYTEORDER & 0xf0000
1057 # define ORDERBYTE (0x88888888 - BYTEORDER)
1059 # define ORDERBYTE (0x4444 - BYTEORDER)
1065 for (i = 1; i <= 3; i++) {
1066 SV * const sv = SP[i];
1069 if (SvREADONLY(sv)) {
1071 sv_force_normal_flags(sv, 0);
1072 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1073 Perl_croak_no_modify(aTHX);
1076 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1077 SvPV_force_nolen(sv); /* force string conversion */
1084 /* little endians can use vecs directly */
1085 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1092 masksize = NFDBITS / NBBY;
1094 masksize = sizeof(long); /* documented int, everyone seems to use long */
1096 Zero(&fd_sets[0], 4, char*);
1099 # if SELECT_MIN_BITS == 1
1100 growsize = sizeof(fd_set);
1102 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1103 # undef SELECT_MIN_BITS
1104 # define SELECT_MIN_BITS __FD_SETSIZE
1106 /* If SELECT_MIN_BITS is greater than one we most probably will want
1107 * to align the sizes with SELECT_MIN_BITS/8 because for example
1108 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1109 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1110 * on (sets/tests/clears bits) is 32 bits. */
1111 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1119 timebuf.tv_sec = (long)value;
1120 value -= (NV)timebuf.tv_sec;
1121 timebuf.tv_usec = (long)(value * 1000000.0);
1126 for (i = 1; i <= 3; i++) {
1128 if (!SvOK(sv) || SvCUR(sv) == 0) {
1135 Sv_Grow(sv, growsize);
1139 while (++j <= growsize) {
1143 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1145 Newx(fd_sets[i], growsize, char);
1146 for (offset = 0; offset < growsize; offset += masksize) {
1147 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1148 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1151 fd_sets[i] = SvPVX(sv);
1155 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1156 /* Can't make just the (void*) conditional because that would be
1157 * cpp #if within cpp macro, and not all compilers like that. */
1158 nfound = PerlSock_select(
1160 (Select_fd_set_t) fd_sets[1],
1161 (Select_fd_set_t) fd_sets[2],
1162 (Select_fd_set_t) fd_sets[3],
1163 (void*) tbuf); /* Workaround for compiler bug. */
1165 nfound = PerlSock_select(
1167 (Select_fd_set_t) fd_sets[1],
1168 (Select_fd_set_t) fd_sets[2],
1169 (Select_fd_set_t) fd_sets[3],
1172 for (i = 1; i <= 3; i++) {
1175 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1177 for (offset = 0; offset < growsize; offset += masksize) {
1178 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1179 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1181 Safefree(fd_sets[i]);
1188 if (GIMME == G_ARRAY && tbuf) {
1189 value = (NV)(timebuf.tv_sec) +
1190 (NV)(timebuf.tv_usec) / 1000000.0;
1195 DIE(aTHX_ "select not implemented");
1200 =for apidoc setdefout
1202 Sets PL_defoutgv, the default file handle for output, to the passed in
1203 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1204 count of the passed in typeglob is increased by one, and the reference count
1205 of the typeglob that PL_defoutgv points to is decreased by one.
1211 Perl_setdefout(pTHX_ GV *gv)
1214 SvREFCNT_inc_simple_void(gv);
1215 SvREFCNT_dec(PL_defoutgv);
1223 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1224 GV * egv = GvEGVx(PL_defoutgv);
1228 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1230 XPUSHs(&PL_sv_undef);
1232 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1233 if (gvp && *gvp == egv) {
1234 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1238 mXPUSHs(newRV(MUTABLE_SV(egv)));
1243 if (!GvIO(newdefout))
1244 gv_IOadd(newdefout);
1245 setdefout(newdefout);
1254 GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs);
1255 IO *const io = GvIO(gv);
1261 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1263 const U32 gimme = GIMME_V;
1264 Perl_tied_method(aTHX_ "GETC", SP, MUTABLE_SV(io), mg, gimme, 0);
1265 if (gimme == G_SCALAR) {
1267 SvSetMagicSV_nosteal(TARG, TOPs);
1272 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1273 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1275 SETERRNO(EBADF,RMS_IFI);
1279 sv_setpvs(TARG, " ");
1280 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1281 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1282 /* Find out how many bytes the char needs */
1283 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1286 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1287 SvCUR_set(TARG,1+len);
1296 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1299 register PERL_CONTEXT *cx;
1300 const I32 gimme = GIMME_V;
1302 PERL_ARGS_ASSERT_DOFORM;
1304 if (cv && CvCLONE(cv))
1305 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1310 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1311 PUSHFORMAT(cx, retop);
1313 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1315 setdefout(gv); /* locally select filehandle so $% et al work */
1334 gv = MUTABLE_GV(POPs);
1348 goto not_a_format_reference;
1353 tmpsv = sv_newmortal();
1354 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1355 name = SvPV_nolen_const(tmpsv);
1357 DIE(aTHX_ "Undefined format \"%s\" called", name);
1359 not_a_format_reference:
1360 DIE(aTHX_ "Not a format reference");
1362 IoFLAGS(io) &= ~IOf_DIDTOP;
1363 return doform(cv,gv,PL_op->op_next);
1369 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1370 register IO * const io = GvIOp(gv);
1375 register PERL_CONTEXT *cx;
1378 if (!io || !(ofp = IoOFP(io)))
1381 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1382 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1384 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1385 PL_formtarget != PL_toptarget)
1389 if (!IoTOP_GV(io)) {
1392 if (!IoTOP_NAME(io)) {
1394 if (!IoFMT_NAME(io))
1395 IoFMT_NAME(io) = savepv(GvNAME(gv));
1396 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1397 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1398 if ((topgv && GvFORM(topgv)) ||
1399 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1400 IoTOP_NAME(io) = savesvpv(topname);
1402 IoTOP_NAME(io) = savepvs("top");
1404 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1405 if (!topgv || !GvFORM(topgv)) {
1406 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1409 IoTOP_GV(io) = topgv;
1411 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1412 I32 lines = IoLINES_LEFT(io);
1413 const char *s = SvPVX_const(PL_formtarget);
1414 if (lines <= 0) /* Yow, header didn't even fit!!! */
1416 while (lines-- > 0) {
1417 s = strchr(s, '\n');
1423 const STRLEN save = SvCUR(PL_formtarget);
1424 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1425 do_print(PL_formtarget, ofp);
1426 SvCUR_set(PL_formtarget, save);
1427 sv_chop(PL_formtarget, s);
1428 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1431 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1432 do_print(PL_formfeed, ofp);
1433 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1435 PL_formtarget = PL_toptarget;
1436 IoFLAGS(io) |= IOf_DIDTOP;
1439 DIE(aTHX_ "bad top format reference");
1442 SV * const sv = sv_newmortal();
1444 gv_efullname4(sv, fgv, NULL, FALSE);
1445 name = SvPV_nolen_const(sv);
1447 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1449 DIE(aTHX_ "Undefined top format called");
1451 return doform(cv, gv, PL_op);
1455 POPBLOCK(cx,PL_curpm);
1457 retop = cx->blk_sub.retop;
1463 report_wrongway_fh(gv, '<');
1469 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1470 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1472 if (!do_print(PL_formtarget, fp))
1475 FmLINES(PL_formtarget) = 0;
1476 SvCUR_set(PL_formtarget, 0);
1477 *SvEND(PL_formtarget) = '\0';
1478 if (IoFLAGS(io) & IOf_FLUSH)
1479 (void)PerlIO_flush(fp);
1484 PL_formtarget = PL_bodytarget;
1486 PERL_UNUSED_VAR(newsp);
1487 PERL_UNUSED_VAR(gimme);
1493 dVAR; dSP; dMARK; dORIGMARK;
1498 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1499 IO *const io = GvIO(gv);
1502 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1504 if (MARK == ORIGMARK) {
1507 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1510 return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io),
1512 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1520 SETERRNO(EBADF,RMS_IFI);
1523 else if (!(fp = IoOFP(io))) {
1525 report_wrongway_fh(gv, '<');
1526 else if (ckWARN(WARN_CLOSED))
1528 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1532 do_sprintf(sv, SP - MARK, MARK + 1);
1533 if (!do_print(sv, fp))
1536 if (IoFLAGS(io) & IOf_FLUSH)
1537 if (PerlIO_flush(fp) == EOF)
1548 PUSHs(&PL_sv_undef);
1556 const int perm = (MAXARG > 3) ? POPi : 0666;
1557 const int mode = POPi;
1558 SV * const sv = POPs;
1559 GV * const gv = MUTABLE_GV(POPs);
1562 /* Need TIEHANDLE method ? */
1563 const char * const tmps = SvPV_const(sv, len);
1564 /* FIXME? do_open should do const */
1565 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1566 IoLINES(GvIOp(gv)) = 0;
1570 PUSHs(&PL_sv_undef);
1577 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1583 Sock_size_t bufsize;
1591 bool charstart = FALSE;
1592 STRLEN charskip = 0;
1595 GV * const gv = MUTABLE_GV(*++MARK);
1596 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1597 && gv && (io = GvIO(gv)) )
1599 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1601 return Perl_tied_method(aTHX_ "READ", mark - 1, MUTABLE_SV(io), mg,
1602 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1611 sv_setpvs(bufsv, "");
1612 length = SvIVx(*++MARK);
1615 offset = SvIVx(*++MARK);
1619 if (!io || !IoIFP(io)) {
1621 SETERRNO(EBADF,RMS_IFI);
1624 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1625 buffer = SvPVutf8_force(bufsv, blen);
1626 /* UTF-8 may not have been set if they are all low bytes */
1631 buffer = SvPV_force(bufsv, blen);
1632 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1635 DIE(aTHX_ "Negative length");
1643 if (PL_op->op_type == OP_RECV) {
1644 char namebuf[MAXPATHLEN];
1645 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1646 bufsize = sizeof (struct sockaddr_in);
1648 bufsize = sizeof namebuf;
1650 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1654 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1655 /* 'offset' means 'flags' here */
1656 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1657 (struct sockaddr *)namebuf, &bufsize);
1660 /* MSG_TRUNC can give oversized count; quietly lose it */
1664 /* Bogus return without padding */
1665 bufsize = sizeof (struct sockaddr_in);
1667 SvCUR_set(bufsv, count);
1668 *SvEND(bufsv) = '\0';
1669 (void)SvPOK_only(bufsv);
1673 /* This should not be marked tainted if the fp is marked clean */
1674 if (!(IoFLAGS(io) & IOf_UNTAINT))
1675 SvTAINTED_on(bufsv);
1677 sv_setpvn(TARG, namebuf, bufsize);
1682 if (DO_UTF8(bufsv)) {
1683 /* offset adjust in characters not bytes */
1684 blen = sv_len_utf8(bufsv);
1687 if (-offset > (int)blen)
1688 DIE(aTHX_ "Offset outside string");
1691 if (DO_UTF8(bufsv)) {
1692 /* convert offset-as-chars to offset-as-bytes */
1693 if (offset >= (int)blen)
1694 offset += SvCUR(bufsv) - blen;
1696 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1699 bufsize = SvCUR(bufsv);
1700 /* Allocating length + offset + 1 isn't perfect in the case of reading
1701 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1703 (should be 2 * length + offset + 1, or possibly something longer if
1704 PL_encoding is true) */
1705 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1706 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1707 Zero(buffer+bufsize, offset-bufsize, char);
1709 buffer = buffer + offset;
1711 read_target = bufsv;
1713 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1714 concatenate it to the current buffer. */
1716 /* Truncate the existing buffer to the start of where we will be
1718 SvCUR_set(bufsv, offset);
1720 read_target = sv_newmortal();
1721 SvUPGRADE(read_target, SVt_PV);
1722 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1725 if (PL_op->op_type == OP_SYSREAD) {
1726 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1727 if (IoTYPE(io) == IoTYPE_SOCKET) {
1728 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1734 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1739 #ifdef HAS_SOCKET__bad_code_maybe
1740 if (IoTYPE(io) == IoTYPE_SOCKET) {
1741 char namebuf[MAXPATHLEN];
1742 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1743 bufsize = sizeof (struct sockaddr_in);
1745 bufsize = sizeof namebuf;
1747 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1748 (struct sockaddr *)namebuf, &bufsize);
1753 count = PerlIO_read(IoIFP(io), buffer, length);
1754 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1755 if (count == 0 && PerlIO_error(IoIFP(io)))
1759 if (IoTYPE(io) == IoTYPE_WRONLY)
1760 report_wrongway_fh(gv, '>');
1763 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1764 *SvEND(read_target) = '\0';
1765 (void)SvPOK_only(read_target);
1766 if (fp_utf8 && !IN_BYTES) {
1767 /* Look at utf8 we got back and count the characters */
1768 const char *bend = buffer + count;
1769 while (buffer < bend) {
1771 skip = UTF8SKIP(buffer);
1774 if (buffer - charskip + skip > bend) {
1775 /* partial character - try for rest of it */
1776 length = skip - (bend-buffer);
1777 offset = bend - SvPVX_const(bufsv);
1789 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1790 provided amount read (count) was what was requested (length)
1792 if (got < wanted && count == length) {
1793 length = wanted - got;
1794 offset = bend - SvPVX_const(bufsv);
1797 /* return value is character count */
1801 else if (buffer_utf8) {
1802 /* Let svcatsv upgrade the bytes we read in to utf8.
1803 The buffer is a mortal so will be freed soon. */
1804 sv_catsv_nomg(bufsv, read_target);
1807 /* This should not be marked tainted if the fp is marked clean */
1808 if (!(IoFLAGS(io) & IOf_UNTAINT))
1809 SvTAINTED_on(bufsv);
1821 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1826 STRLEN orig_blen_bytes;
1827 const int op_type = PL_op->op_type;
1830 GV *const gv = MUTABLE_GV(*++MARK);
1831 IO *const io = GvIO(gv);
1833 if (op_type == OP_SYSWRITE && io) {
1834 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1836 if (MARK == SP - 1) {
1838 mXPUSHi(sv_len(sv));
1842 return Perl_tied_method(aTHX_ "WRITE", mark - 1, MUTABLE_SV(io), mg,
1843 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1853 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1855 if (io && IoIFP(io))
1856 report_wrongway_fh(gv, '<');
1859 SETERRNO(EBADF,RMS_IFI);
1863 /* Do this first to trigger any overloading. */
1864 buffer = SvPV_const(bufsv, blen);
1865 orig_blen_bytes = blen;
1866 doing_utf8 = DO_UTF8(bufsv);
1868 if (PerlIO_isutf8(IoIFP(io))) {
1869 if (!SvUTF8(bufsv)) {
1870 /* We don't modify the original scalar. */
1871 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1872 buffer = (char *) tmpbuf;
1876 else if (doing_utf8) {
1877 STRLEN tmplen = blen;
1878 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1881 buffer = (char *) tmpbuf;
1885 assert((char *)result == buffer);
1886 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1891 if (op_type == OP_SEND) {
1892 const int flags = SvIVx(*++MARK);
1895 char * const sockbuf = SvPVx(*++MARK, mlen);
1896 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1897 flags, (struct sockaddr *)sockbuf, mlen);
1901 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1907 Size_t length = 0; /* This length is in characters. */
1913 /* The SV is bytes, and we've had to upgrade it. */
1914 blen_chars = orig_blen_bytes;
1916 /* The SV really is UTF-8. */
1917 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1918 /* Don't call sv_len_utf8 again because it will call magic
1919 or overloading a second time, and we might get back a
1920 different result. */
1921 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1923 /* It's safe, and it may well be cached. */
1924 blen_chars = sv_len_utf8(bufsv);
1932 length = blen_chars;
1934 #if Size_t_size > IVSIZE
1935 length = (Size_t)SvNVx(*++MARK);
1937 length = (Size_t)SvIVx(*++MARK);
1939 if ((SSize_t)length < 0) {
1941 DIE(aTHX_ "Negative length");
1946 offset = SvIVx(*++MARK);
1948 if (-offset > (IV)blen_chars) {
1950 DIE(aTHX_ "Offset outside string");
1952 offset += blen_chars;
1953 } else if (offset > (IV)blen_chars) {
1955 DIE(aTHX_ "Offset outside string");
1959 if (length > blen_chars - offset)
1960 length = blen_chars - offset;
1962 /* Here we convert length from characters to bytes. */
1963 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1964 /* Either we had to convert the SV, or the SV is magical, or
1965 the SV has overloading, in which case we can't or mustn't
1966 or mustn't call it again. */
1968 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1969 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1971 /* It's a real UTF-8 SV, and it's not going to change under
1972 us. Take advantage of any cache. */
1974 I32 len_I32 = length;
1976 /* Convert the start and end character positions to bytes.
1977 Remember that the second argument to sv_pos_u2b is relative
1979 sv_pos_u2b(bufsv, &start, &len_I32);
1986 buffer = buffer+offset;
1988 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1989 if (IoTYPE(io) == IoTYPE_SOCKET) {
1990 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1996 /* See the note at doio.c:do_print about filesize limits. --jhi */
1997 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2006 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2009 #if Size_t_size > IVSIZE
2029 * in Perl 5.12 and later, the additional parameter is a bitmask:
2032 * 2 = eof() <- ARGV magic
2034 * I'll rely on the compiler's trace flow analysis to decide whether to
2035 * actually assign this out here, or punt it into the only block where it is
2036 * used. Doing it out here is DRY on the condition logic.
2041 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2047 if (PL_op->op_flags & OPf_SPECIAL) {
2048 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2052 gv = PL_last_in_gv; /* eof */
2060 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2061 return tied_method1("EOF", SP, MUTABLE_SV(io), mg, newSVuv(which));
2064 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2065 if (io && !IoIFP(io)) {
2066 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2068 IoFLAGS(io) &= ~IOf_START;
2069 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2071 sv_setpvs(GvSV(gv), "-");
2073 GvSV(gv) = newSVpvs("-");
2074 SvSETMAGIC(GvSV(gv));
2076 else if (!nextargv(gv))
2081 PUSHs(boolSV(do_eof(gv)));
2092 PL_last_in_gv = MUTABLE_GV(POPs);
2099 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2101 return tied_method0("TELL", SP, MUTABLE_SV(io), mg);
2106 SETERRNO(EBADF,RMS_IFI);
2111 #if LSEEKSIZE > IVSIZE
2112 PUSHn( do_tell(gv) );
2114 PUSHi( do_tell(gv) );
2122 const int whence = POPi;
2123 #if LSEEKSIZE > IVSIZE
2124 const Off_t offset = (Off_t)SvNVx(POPs);
2126 const Off_t offset = (Off_t)SvIVx(POPs);
2129 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2130 IO *const io = GvIO(gv);
2133 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2135 #if LSEEKSIZE > IVSIZE
2136 SV *const offset_sv = newSVnv((NV) offset);
2138 SV *const offset_sv = newSViv(offset);
2141 return tied_method2("SEEK", SP, MUTABLE_SV(io), mg, offset_sv,
2146 if (PL_op->op_type == OP_SEEK)
2147 PUSHs(boolSV(do_seek(gv, offset, whence)));
2149 const Off_t sought = do_sysseek(gv, offset, whence);
2151 PUSHs(&PL_sv_undef);
2153 SV* const sv = sought ?
2154 #if LSEEKSIZE > IVSIZE
2159 : newSVpvn(zero_but_true, ZBTLEN);
2170 /* There seems to be no consensus on the length type of truncate()
2171 * and ftruncate(), both off_t and size_t have supporters. In
2172 * general one would think that when using large files, off_t is
2173 * at least as wide as size_t, so using an off_t should be okay. */
2174 /* XXX Configure probe for the length type of *truncate() needed XXX */
2177 #if Off_t_size > IVSIZE
2182 /* Checking for length < 0 is problematic as the type might or
2183 * might not be signed: if it is not, clever compilers will moan. */
2184 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2191 if (PL_op->op_flags & OPf_SPECIAL) {
2192 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2201 TAINT_PROPER("truncate");
2202 if (!(fp = IoIFP(io))) {
2208 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2210 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2217 SV * const sv = POPs;
2220 if (isGV_with_GP(sv)) {
2221 tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */
2222 goto do_ftruncate_gv;
2224 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2225 tmpgv = MUTABLE_GV(SvRV(sv)); /* \*main::FRED for example */
2226 goto do_ftruncate_gv;
2228 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2229 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2230 goto do_ftruncate_io;
2233 name = SvPV_nolen_const(sv);
2234 TAINT_PROPER("truncate");
2236 if (truncate(name, len) < 0)
2240 const int tmpfd = PerlLIO_open(name, O_RDWR);
2245 if (my_chsize(tmpfd, len) < 0)
2247 PerlLIO_close(tmpfd);
2256 SETERRNO(EBADF,RMS_IFI);
2264 SV * const argsv = POPs;
2265 const unsigned int func = POPu;
2266 const int optype = PL_op->op_type;
2267 GV * const gv = MUTABLE_GV(POPs);
2268 IO * const io = gv ? GvIOn(gv) : NULL;
2272 if (!io || !argsv || !IoIFP(io)) {
2274 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2278 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2281 s = SvPV_force(argsv, len);
2282 need = IOCPARM_LEN(func);
2284 s = Sv_Grow(argsv, need + 1);
2285 SvCUR_set(argsv, need);
2288 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2291 retval = SvIV(argsv);
2292 s = INT2PTR(char*,retval); /* ouch */
2295 TAINT_PROPER(PL_op_desc[optype]);
2297 if (optype == OP_IOCTL)
2299 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2301 DIE(aTHX_ "ioctl is not implemented");
2305 DIE(aTHX_ "fcntl is not implemented");
2307 #if defined(OS2) && defined(__EMX__)
2308 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2310 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2314 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2316 if (s[SvCUR(argsv)] != 17)
2317 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2319 s[SvCUR(argsv)] = 0; /* put our null back */
2320 SvSETMAGIC(argsv); /* Assume it has changed */
2329 PUSHp(zero_but_true, ZBTLEN);
2340 const int argtype = POPi;
2341 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
2342 IO *const io = GvIO(gv);
2343 PerlIO *const fp = io ? IoIFP(io) : NULL;
2345 /* XXX Looks to me like io is always NULL at this point */
2347 (void)PerlIO_flush(fp);
2348 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2353 SETERRNO(EBADF,RMS_IFI);
2358 DIE(aTHX_ PL_no_func, "flock()");
2369 const int protocol = POPi;
2370 const int type = POPi;
2371 const int domain = POPi;
2372 GV * const gv = MUTABLE_GV(POPs);
2373 register IO * const io = gv ? GvIOn(gv) : NULL;
2378 if (io && IoIFP(io))
2379 do_close(gv, FALSE);
2380 SETERRNO(EBADF,LIB_INVARG);
2385 do_close(gv, FALSE);
2387 TAINT_PROPER("socket");
2388 fd = PerlSock_socket(domain, type, protocol);
2391 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2392 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2393 IoTYPE(io) = IoTYPE_SOCKET;
2394 if (!IoIFP(io) || !IoOFP(io)) {
2395 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2396 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2397 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2400 #if defined(HAS_FCNTL) && defined(F_SETFD)
2401 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2405 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2414 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2416 const int protocol = POPi;
2417 const int type = POPi;
2418 const int domain = POPi;
2419 GV * const gv2 = MUTABLE_GV(POPs);
2420 GV * const gv1 = MUTABLE_GV(POPs);
2421 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2422 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2426 report_evil_fh(gv1);
2428 report_evil_fh(gv2);
2430 if (io1 && IoIFP(io1))
2431 do_close(gv1, FALSE);
2432 if (io2 && IoIFP(io2))
2433 do_close(gv2, FALSE);
2438 TAINT_PROPER("socketpair");
2439 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2441 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2442 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2443 IoTYPE(io1) = IoTYPE_SOCKET;
2444 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2445 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2446 IoTYPE(io2) = IoTYPE_SOCKET;
2447 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2448 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2449 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2450 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2451 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2452 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2453 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2456 #if defined(HAS_FCNTL) && defined(F_SETFD)
2457 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2458 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2463 DIE(aTHX_ PL_no_sock_func, "socketpair");
2472 SV * const addrsv = POPs;
2473 /* OK, so on what platform does bind modify addr? */
2475 GV * const gv = MUTABLE_GV(POPs);
2476 register IO * const io = GvIOn(gv);
2478 const int op_type = PL_op->op_type;
2480 if (!io || !IoIFP(io))
2483 addr = SvPV_const(addrsv, len);
2484 TAINT_PROPER(PL_op_desc[op_type]);
2485 if ((op_type == OP_BIND
2486 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2487 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2495 SETERRNO(EBADF,SS_IVCHAN);
2502 const int backlog = POPi;
2503 GV * const gv = MUTABLE_GV(POPs);
2504 register IO * const io = gv ? GvIOn(gv) : NULL;
2506 if (!io || !IoIFP(io))
2509 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2516 SETERRNO(EBADF,SS_IVCHAN);
2525 char namebuf[MAXPATHLEN];
2526 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2527 Sock_size_t len = sizeof (struct sockaddr_in);
2529 Sock_size_t len = sizeof namebuf;
2531 GV * const ggv = MUTABLE_GV(POPs);
2532 GV * const ngv = MUTABLE_GV(POPs);
2541 if (!gstio || !IoIFP(gstio))
2545 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2548 /* Some platforms indicate zero length when an AF_UNIX client is
2549 * not bound. Simulate a non-zero-length sockaddr structure in
2551 namebuf[0] = 0; /* sun_len */
2552 namebuf[1] = AF_UNIX; /* sun_family */
2560 do_close(ngv, FALSE);
2561 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2562 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2563 IoTYPE(nstio) = IoTYPE_SOCKET;
2564 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2565 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2566 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2567 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2570 #if defined(HAS_FCNTL) && defined(F_SETFD)
2571 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2575 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2576 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2578 #ifdef __SCO_VERSION__
2579 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2582 PUSHp(namebuf, len);
2586 report_evil_fh(ggv);
2587 SETERRNO(EBADF,SS_IVCHAN);
2597 const int how = POPi;
2598 GV * const gv = MUTABLE_GV(POPs);
2599 register IO * const io = GvIOn(gv);
2601 if (!io || !IoIFP(io))
2604 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2609 SETERRNO(EBADF,SS_IVCHAN);
2616 const int optype = PL_op->op_type;
2617 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2618 const unsigned int optname = (unsigned int) POPi;
2619 const unsigned int lvl = (unsigned int) POPi;
2620 GV * const gv = MUTABLE_GV(POPs);
2621 register IO * const io = GvIOn(gv);
2625 if (!io || !IoIFP(io))
2628 fd = PerlIO_fileno(IoIFP(io));
2632 (void)SvPOK_only(sv);
2636 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2643 #if defined(__SYMBIAN32__)
2644 # define SETSOCKOPT_OPTION_VALUE_T void *
2646 # define SETSOCKOPT_OPTION_VALUE_T const char *
2648 /* XXX TODO: We need to have a proper type (a Configure probe,
2649 * etc.) for what the C headers think of the third argument of
2650 * setsockopt(), the option_value read-only buffer: is it
2651 * a "char *", or a "void *", const or not. Some compilers
2652 * don't take kindly to e.g. assuming that "char *" implicitly
2653 * promotes to a "void *", or to explicitly promoting/demoting
2654 * consts to non/vice versa. The "const void *" is the SUS
2655 * definition, but that does not fly everywhere for the above
2657 SETSOCKOPT_OPTION_VALUE_T buf;
2661 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2665 aint = (int)SvIV(sv);
2666 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2669 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2679 SETERRNO(EBADF,SS_IVCHAN);
2688 const int optype = PL_op->op_type;
2689 GV * const gv = MUTABLE_GV(POPs);
2690 register IO * const io = GvIOn(gv);
2695 if (!io || !IoIFP(io))
2698 sv = sv_2mortal(newSV(257));
2699 (void)SvPOK_only(sv);
2703 fd = PerlIO_fileno(IoIFP(io));
2705 case OP_GETSOCKNAME:
2706 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2709 case OP_GETPEERNAME:
2710 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2712 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2714 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";
2715 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2716 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2717 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2718 sizeof(u_short) + sizeof(struct in_addr))) {
2725 #ifdef BOGUS_GETNAME_RETURN
2726 /* Interactive Unix, getpeername() and getsockname()
2727 does not return valid namelen */
2728 if (len == BOGUS_GETNAME_RETURN)
2729 len = sizeof(struct sockaddr);
2738 SETERRNO(EBADF,SS_IVCHAN);
2756 if (PL_op->op_flags & OPf_REF) {
2758 if (PL_op->op_type == OP_LSTAT) {
2759 if (gv != PL_defgv) {
2760 do_fstat_warning_check:
2761 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2762 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2763 } else if (PL_laststype != OP_LSTAT)
2764 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2768 if (gv != PL_defgv) {
2769 PL_laststype = OP_STAT;
2771 sv_setpvs(PL_statname, "");
2778 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2779 } else if (IoDIRP(io)) {
2781 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2783 PL_laststatval = -1;
2789 if (PL_laststatval < 0) {
2795 SV* const sv = POPs;
2796 if (isGV_with_GP(sv)) {
2797 gv = MUTABLE_GV(sv);
2799 } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2800 gv = MUTABLE_GV(SvRV(sv));
2801 if (PL_op->op_type == OP_LSTAT)
2802 goto do_fstat_warning_check;
2804 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2805 io = MUTABLE_IO(SvRV(sv));
2806 if (PL_op->op_type == OP_LSTAT)
2807 goto do_fstat_warning_check;
2808 goto do_fstat_have_io;
2811 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2813 PL_laststype = PL_op->op_type;
2814 if (PL_op->op_type == OP_LSTAT)
2815 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2817 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2818 if (PL_laststatval < 0) {
2819 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2820 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2826 if (gimme != G_ARRAY) {
2827 if (gimme != G_VOID)
2828 XPUSHs(boolSV(max));
2834 mPUSHi(PL_statcache.st_dev);
2835 mPUSHi(PL_statcache.st_ino);
2836 mPUSHu(PL_statcache.st_mode);
2837 mPUSHu(PL_statcache.st_nlink);
2838 #if Uid_t_size > IVSIZE
2839 mPUSHn(PL_statcache.st_uid);
2841 # if Uid_t_sign <= 0
2842 mPUSHi(PL_statcache.st_uid);
2844 mPUSHu(PL_statcache.st_uid);
2847 #if Gid_t_size > IVSIZE
2848 mPUSHn(PL_statcache.st_gid);
2850 # if Gid_t_sign <= 0
2851 mPUSHi(PL_statcache.st_gid);
2853 mPUSHu(PL_statcache.st_gid);
2856 #ifdef USE_STAT_RDEV
2857 mPUSHi(PL_statcache.st_rdev);
2859 PUSHs(newSVpvs_flags("", SVs_TEMP));
2861 #if Off_t_size > IVSIZE
2862 mPUSHn(PL_statcache.st_size);
2864 mPUSHi(PL_statcache.st_size);
2867 mPUSHn(PL_statcache.st_atime);
2868 mPUSHn(PL_statcache.st_mtime);
2869 mPUSHn(PL_statcache.st_ctime);
2871 mPUSHi(PL_statcache.st_atime);
2872 mPUSHi(PL_statcache.st_mtime);
2873 mPUSHi(PL_statcache.st_ctime);
2875 #ifdef USE_STAT_BLOCKS
2876 mPUSHu(PL_statcache.st_blksize);
2877 mPUSHu(PL_statcache.st_blocks);
2879 PUSHs(newSVpvs_flags("", SVs_TEMP));
2880 PUSHs(newSVpvs_flags("", SVs_TEMP));
2886 #define tryAMAGICftest_MG(chr) STMT_START { \
2887 if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
2888 && S_try_amagic_ftest(aTHX_ chr)) \
2893 S_try_amagic_ftest(pTHX_ char chr) {
2896 SV* const arg = TOPs;
2901 if ((PL_op->op_flags & OPf_KIDS)
2904 const char tmpchr = chr;
2906 SV * const tmpsv = amagic_call(arg,
2907 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2908 ftest_amg, AMGf_unary);
2915 next = PL_op->op_next;
2916 if (next->op_type >= OP_FTRREAD &&
2917 next->op_type <= OP_FTBINARY &&
2918 next->op_private & OPpFT_STACKED
2921 /* leave the object alone */
2933 /* This macro is used by the stacked filetest operators :
2934 * if the previous filetest failed, short-circuit and pass its value.
2935 * Else, discard it from the stack and continue. --rgs
2937 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2938 if (!SvTRUE(TOPs)) { RETURN; } \
2939 else { (void)POPs; PUTBACK; } \
2946 /* Not const, because things tweak this below. Not bool, because there's
2947 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2948 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2949 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2950 /* Giving some sort of initial value silences compilers. */
2952 int access_mode = R_OK;
2954 int access_mode = 0;
2957 /* access_mode is never used, but leaving use_access in makes the
2958 conditional compiling below much clearer. */
2961 Mode_t stat_mode = S_IRUSR;
2963 bool effective = FALSE;
2967 switch (PL_op->op_type) {
2968 case OP_FTRREAD: opchar = 'R'; break;
2969 case OP_FTRWRITE: opchar = 'W'; break;
2970 case OP_FTREXEC: opchar = 'X'; break;
2971 case OP_FTEREAD: opchar = 'r'; break;
2972 case OP_FTEWRITE: opchar = 'w'; break;
2973 case OP_FTEEXEC: opchar = 'x'; break;
2975 tryAMAGICftest_MG(opchar);
2977 STACKED_FTEST_CHECK;
2979 switch (PL_op->op_type) {
2981 #if !(defined(HAS_ACCESS) && defined(R_OK))
2987 #if defined(HAS_ACCESS) && defined(W_OK)
2992 stat_mode = S_IWUSR;
2996 #if defined(HAS_ACCESS) && defined(X_OK)
3001 stat_mode = S_IXUSR;
3005 #ifdef PERL_EFF_ACCESS
3008 stat_mode = S_IWUSR;
3012 #ifndef PERL_EFF_ACCESS
3019 #ifdef PERL_EFF_ACCESS
3024 stat_mode = S_IXUSR;
3030 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3031 const char *name = POPpx;
3033 # ifdef PERL_EFF_ACCESS
3034 result = PERL_EFF_ACCESS(name, access_mode);
3036 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3042 result = access(name, access_mode);
3044 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3055 result = my_stat_flags(0);
3059 if (cando(stat_mode, effective, &PL_statcache))
3068 const int op_type = PL_op->op_type;
3073 case OP_FTIS: opchar = 'e'; break;
3074 case OP_FTSIZE: opchar = 's'; break;
3075 case OP_FTMTIME: opchar = 'M'; break;
3076 case OP_FTCTIME: opchar = 'C'; break;
3077 case OP_FTATIME: opchar = 'A'; break;
3079 tryAMAGICftest_MG(opchar);
3081 STACKED_FTEST_CHECK;
3083 result = my_stat_flags(0);
3087 if (op_type == OP_FTIS)
3090 /* You can't dTARGET inside OP_FTIS, because you'll get
3091 "panic: pad_sv po" - the op is not flagged to have a target. */
3095 #if Off_t_size > IVSIZE
3096 PUSHn(PL_statcache.st_size);
3098 PUSHi(PL_statcache.st_size);
3102 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3105 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3108 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3122 switch (PL_op->op_type) {
3123 case OP_FTROWNED: opchar = 'O'; break;
3124 case OP_FTEOWNED: opchar = 'o'; break;
3125 case OP_FTZERO: opchar = 'z'; break;
3126 case OP_FTSOCK: opchar = 'S'; break;
3127 case OP_FTCHR: opchar = 'c'; break;
3128 case OP_FTBLK: opchar = 'b'; break;
3129 case OP_FTFILE: opchar = 'f'; break;
3130 case OP_FTDIR: opchar = 'd'; break;
3131 case OP_FTPIPE: opchar = 'p'; break;
3132 case OP_FTSUID: opchar = 'u'; break;
3133 case OP_FTSGID: opchar = 'g'; break;
3134 case OP_FTSVTX: opchar = 'k'; break;
3136 tryAMAGICftest_MG(opchar);
3138 STACKED_FTEST_CHECK;
3140 /* I believe that all these three are likely to be defined on most every
3141 system these days. */
3143 if(PL_op->op_type == OP_FTSUID) {
3144 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3150 if(PL_op->op_type == OP_FTSGID) {
3151 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3157 if(PL_op->op_type == OP_FTSVTX) {
3158 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3164 result = my_stat_flags(0);
3168 switch (PL_op->op_type) {
3170 if (PL_statcache.st_uid == PL_uid)
3174 if (PL_statcache.st_uid == PL_euid)
3178 if (PL_statcache.st_size == 0)
3182 if (S_ISSOCK(PL_statcache.st_mode))
3186 if (S_ISCHR(PL_statcache.st_mode))
3190 if (S_ISBLK(PL_statcache.st_mode))
3194 if (S_ISREG(PL_statcache.st_mode))
3198 if (S_ISDIR(PL_statcache.st_mode))
3202 if (S_ISFIFO(PL_statcache.st_mode))
3207 if (PL_statcache.st_mode & S_ISUID)
3213 if (PL_statcache.st_mode & S_ISGID)
3219 if (PL_statcache.st_mode & S_ISVTX)
3233 tryAMAGICftest_MG('l');
3234 result = my_lstat_flags(0);
3239 if (S_ISLNK(PL_statcache.st_mode))
3254 tryAMAGICftest_MG('t');
3256 STACKED_FTEST_CHECK;
3258 if (PL_op->op_flags & OPf_REF)
3260 else if (isGV_with_GP(TOPs))
3261 gv = MUTABLE_GV(POPs);
3262 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3263 gv = MUTABLE_GV(SvRV(POPs));
3266 name = SvPV_nomg(tmpsv, namelen);
3267 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3270 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3271 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3272 else if (tmpsv && SvOK(tmpsv)) {
3280 if (PerlLIO_isatty(fd))
3285 #if defined(atarist) /* this will work with atariST. Configure will
3286 make guesses for other systems. */
3287 # define FILE_base(f) ((f)->_base)
3288 # define FILE_ptr(f) ((f)->_ptr)
3289 # define FILE_cnt(f) ((f)->_cnt)
3290 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3301 register STDCHAR *s;
3307 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3309 STACKED_FTEST_CHECK;
3311 if (PL_op->op_flags & OPf_REF)
3313 else if (isGV_with_GP(TOPs))
3314 gv = MUTABLE_GV(POPs);
3315 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3316 gv = MUTABLE_GV(SvRV(POPs));
3322 if (gv == PL_defgv) {
3324 io = GvIO(PL_statgv);
3327 goto really_filename;
3332 PL_laststatval = -1;
3333 sv_setpvs(PL_statname, "");
3334 io = GvIO(PL_statgv);
3336 if (io && IoIFP(io)) {
3337 if (! PerlIO_has_base(IoIFP(io)))
3338 DIE(aTHX_ "-T and -B not implemented on filehandles");
3339 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3340 if (PL_laststatval < 0)
3342 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3343 if (PL_op->op_type == OP_FTTEXT)
3348 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3349 i = PerlIO_getc(IoIFP(io));
3351 (void)PerlIO_ungetc(IoIFP(io),i);
3353 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3355 len = PerlIO_get_bufsiz(IoIFP(io));
3356 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3357 /* sfio can have large buffers - limit to 512 */
3362 report_evil_fh(cGVOP_gv);
3363 SETERRNO(EBADF,RMS_IFI);
3371 PL_laststype = OP_STAT;
3372 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3373 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3374 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3376 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3379 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3380 if (PL_laststatval < 0) {
3381 (void)PerlIO_close(fp);
3384 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3385 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3386 (void)PerlIO_close(fp);
3388 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3389 RETPUSHNO; /* special case NFS directories */
3390 RETPUSHYES; /* null file is anything */
3395 /* now scan s to look for textiness */
3396 /* XXX ASCII dependent code */
3398 #if defined(DOSISH) || defined(USEMYBINMODE)
3399 /* ignore trailing ^Z on short files */
3400 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3404 for (i = 0; i < len; i++, s++) {
3405 if (!*s) { /* null never allowed in text */
3410 else if (!(isPRINT(*s) || isSPACE(*s)))
3413 else if (*s & 128) {
3415 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3418 /* utf8 characters don't count as odd */
3419 if (UTF8_IS_START(*s)) {
3420 int ulen = UTF8SKIP(s);
3421 if (ulen < len - i) {
3423 for (j = 1; j < ulen; j++) {
3424 if (!UTF8_IS_CONTINUATION(s[j]))
3427 --ulen; /* loop does extra increment */
3437 *s != '\n' && *s != '\r' && *s != '\b' &&
3438 *s != '\t' && *s != '\f' && *s != 27)
3443 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3454 const char *tmps = NULL;
3458 SV * const sv = POPs;
3459 if (PL_op->op_flags & OPf_SPECIAL) {
3460 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3462 else if (isGV_with_GP(sv)) {
3463 gv = MUTABLE_GV(sv);
3465 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
3466 gv = MUTABLE_GV(SvRV(sv));
3469 tmps = SvPV_nolen_const(sv);
3473 if( !gv && (!tmps || !*tmps) ) {
3474 HV * const table = GvHVn(PL_envgv);
3477 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3478 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3480 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3485 deprecate("chdir('') or chdir(undef) as chdir()");
3486 tmps = SvPV_nolen_const(*svp);
3490 TAINT_PROPER("chdir");
3495 TAINT_PROPER("chdir");
3498 IO* const io = GvIO(gv);
3501 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3502 } else if (IoIFP(io)) {
3503 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3507 SETERRNO(EBADF, RMS_IFI);
3513 SETERRNO(EBADF,RMS_IFI);
3517 DIE(aTHX_ PL_no_func, "fchdir");
3521 PUSHi( PerlDir_chdir(tmps) >= 0 );
3523 /* Clear the DEFAULT element of ENV so we'll get the new value
3525 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3532 dVAR; dSP; dMARK; dTARGET;
3533 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3544 char * const tmps = POPpx;
3545 TAINT_PROPER("chroot");
3546 PUSHi( chroot(tmps) >= 0 );
3549 DIE(aTHX_ PL_no_func, "chroot");
3557 const char * const tmps2 = POPpconstx;
3558 const char * const tmps = SvPV_nolen_const(TOPs);
3559 TAINT_PROPER("rename");
3561 anum = PerlLIO_rename(tmps, tmps2);
3563 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3564 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3567 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3568 (void)UNLINK(tmps2);
3569 if (!(anum = link(tmps, tmps2)))
3570 anum = UNLINK(tmps);
3578 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3582 const int op_type = PL_op->op_type;
3586 if (op_type == OP_LINK)
3587 DIE(aTHX_ PL_no_func, "link");
3589 # ifndef HAS_SYMLINK
3590 if (op_type == OP_SYMLINK)
3591 DIE(aTHX_ PL_no_func, "symlink");
3595 const char * const tmps2 = POPpconstx;
3596 const char * const tmps = SvPV_nolen_const(TOPs);
3597 TAINT_PROPER(PL_op_desc[op_type]);
3599 # if defined(HAS_LINK)
3600 # if defined(HAS_SYMLINK)
3601 /* Both present - need to choose which. */
3602 (op_type == OP_LINK) ?
3603 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3605 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3606 PerlLIO_link(tmps, tmps2);
3609 # if defined(HAS_SYMLINK)
3610 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3611 symlink(tmps, tmps2);
3616 SETi( result >= 0 );
3623 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3634 char buf[MAXPATHLEN];
3637 #ifndef INCOMPLETE_TAINTS
3641 len = readlink(tmps, buf, sizeof(buf) - 1);
3648 RETSETUNDEF; /* just pretend it's a normal file */
3652 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3654 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3656 char * const save_filename = filename;
3661 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3663 PERL_ARGS_ASSERT_DOONELINER;
3665 Newx(cmdline, size, char);
3666 my_strlcpy(cmdline, cmd, size);
3667 my_strlcat(cmdline, " ", size);
3668 for (s = cmdline + strlen(cmdline); *filename; ) {
3672 if (s - cmdline < size)
3673 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3674 myfp = PerlProc_popen(cmdline, "r");
3678 SV * const tmpsv = sv_newmortal();
3679 /* Need to save/restore 'PL_rs' ?? */
3680 s = sv_gets(tmpsv, myfp, 0);
3681 (void)PerlProc_pclose(myfp);
3685 #ifdef HAS_SYS_ERRLIST
3690 /* you don't see this */
3691 const char * const errmsg =
3692 #ifdef HAS_SYS_ERRLIST
3700 if (instr(s, errmsg)) {
3707 #define EACCES EPERM
3709 if (instr(s, "cannot make"))
3710 SETERRNO(EEXIST,RMS_FEX);
3711 else if (instr(s, "existing file"))
3712 SETERRNO(EEXIST,RMS_FEX);
3713 else if (instr(s, "ile exists"))
3714 SETERRNO(EEXIST,RMS_FEX);
3715 else if (instr(s, "non-exist"))
3716 SETERRNO(ENOENT,RMS_FNF);
3717 else if (instr(s, "does not exist"))
3718 SETERRNO(ENOENT,RMS_FNF);
3719 else if (instr(s, "not empty"))
3720 SETERRNO(EBUSY,SS_DEVOFFLINE);
3721 else if (instr(s, "cannot access"))
3722 SETERRNO(EACCES,RMS_PRV);
3724 SETERRNO(EPERM,RMS_PRV);
3727 else { /* some mkdirs return no failure indication */
3728 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3729 if (PL_op->op_type == OP_RMDIR)
3734 SETERRNO(EACCES,RMS_PRV); /* a guess */
3743 /* This macro removes trailing slashes from a directory name.
3744 * Different operating and file systems take differently to
3745 * trailing slashes. According to POSIX 1003.1 1996 Edition
3746 * any number of trailing slashes should be allowed.
3747 * Thusly we snip them away so that even non-conforming
3748 * systems are happy.
3749 * We should probably do this "filtering" for all
3750 * the functions that expect (potentially) directory names:
3751 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3752 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3754 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3755 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3758 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3759 (tmps) = savepvn((tmps), (len)); \
3769 const int mode = (MAXARG > 1) ? POPi : 0777;
3771 TRIMSLASHES(tmps,len,copy);
3773 TAINT_PROPER("mkdir");
3775 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3779 SETi( dooneliner("mkdir", tmps) );
3780 oldumask = PerlLIO_umask(0);
3781 PerlLIO_umask(oldumask);
3782 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3797 TRIMSLASHES(tmps,len,copy);
3798 TAINT_PROPER("rmdir");
3800 SETi( PerlDir_rmdir(tmps) >= 0 );
3802 SETi( dooneliner("rmdir", tmps) );
3809 /* Directory calls. */
3813 #if defined(Direntry_t) && defined(HAS_READDIR)
3815 const char * const dirname = POPpconstx;
3816 GV * const gv = MUTABLE_GV(POPs);
3817 register IO * const io = GvIOn(gv);
3822 if ((IoIFP(io) || IoOFP(io)))
3823 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3824 "Opening filehandle %s also as a directory",
3827 PerlDir_close(IoDIRP(io));
3828 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3834 SETERRNO(EBADF,RMS_DIR);
3837 DIE(aTHX_ PL_no_dir_func, "opendir");
3843 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3844 DIE(aTHX_ PL_no_dir_func, "readdir");
3846 #if !defined(I_DIRENT) && !defined(VMS)
3847 Direntry_t *readdir (DIR *);
3853 const I32 gimme = GIMME;
3854 GV * const gv = MUTABLE_GV(POPs);
3855 register const Direntry_t *dp;
3856 register IO * const io = GvIOn(gv);
3858 if (!io || !IoDIRP(io)) {
3859 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3860 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3865 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3869 sv = newSVpvn(dp->d_name, dp->d_namlen);
3871 sv = newSVpv(dp->d_name, 0);
3873 #ifndef INCOMPLETE_TAINTS
3874 if (!(IoFLAGS(io) & IOf_UNTAINT))
3878 } while (gimme == G_ARRAY);
3880 if (!dp && gimme != G_ARRAY)
3887 SETERRNO(EBADF,RMS_ISI);
3888 if (GIMME == G_ARRAY)
3897 #if defined(HAS_TELLDIR) || defined(telldir)
3899 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3900 /* XXX netbsd still seemed to.
3901 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3902 --JHI 1999-Feb-02 */
3903 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3904 long telldir (DIR *);
3906 GV * const gv = MUTABLE_GV(POPs);
3907 register IO * const io = GvIOn(gv);
3909 if (!io || !IoDIRP(io)) {
3910 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3911 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3915 PUSHi( PerlDir_tell(IoDIRP(io)) );
3919 SETERRNO(EBADF,RMS_ISI);
3922 DIE(aTHX_ PL_no_dir_func, "telldir");
3928 #if defined(HAS_SEEKDIR) || defined(seekdir)
3930 const long along = POPl;
3931 GV * const gv = MUTABLE_GV(POPs);
3932 register IO * const io = GvIOn(gv);
3934 if (!io || !IoDIRP(io)) {
3935 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3936 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3939 (void)PerlDir_seek(IoDIRP(io), along);
3944 SETERRNO(EBADF,RMS_ISI);
3947 DIE(aTHX_ PL_no_dir_func, "seekdir");
3953 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3955 GV * const gv = MUTABLE_GV(POPs);
3956 register IO * const io = GvIOn(gv);
3958 if (!io || !IoDIRP(io)) {
3959 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3960 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3963 (void)PerlDir_rewind(IoDIRP(io));
3967 SETERRNO(EBADF,RMS_ISI);
3970 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3976 #if defined(Direntry_t) && defined(HAS_READDIR)
3978 GV * const gv = MUTABLE_GV(POPs);
3979 register IO * const io = GvIOn(gv);
3981 if (!io || !IoDIRP(io)) {
3982 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3983 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3986 #ifdef VOID_CLOSEDIR
3987 PerlDir_close(IoDIRP(io));
3989 if (PerlDir_close(IoDIRP(io)) < 0) {
3990 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3999 SETERRNO(EBADF,RMS_IFI);
4002 DIE(aTHX_ PL_no_dir_func, "closedir");
4006 /* Process control. */
4015 PERL_FLUSHALL_FOR_CHILD;
4016 childpid = PerlProc_fork();
4020 #ifdef THREADS_HAVE_PIDS
4021 PL_ppid = (IV)getppid();
4023 #ifdef PERL_USES_PL_PIDSTATUS
4024 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4030 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4035 PERL_FLUSHALL_FOR_CHILD;
4036 childpid = PerlProc_fork();
4042 DIE(aTHX_ PL_no_func, "fork");
4049 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4054 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4055 childpid = wait4pid(-1, &argflags, 0);
4057 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4062 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4063 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4064 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4066 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4071 DIE(aTHX_ PL_no_func, "wait");
4077 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4079 const int optype = POPi;
4080 const Pid_t pid = TOPi;
4084 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4085 result = wait4pid(pid, &argflags, optype);
4087 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4092 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4093 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4094 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4096 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4101 DIE(aTHX_ PL_no_func, "waitpid");
4107 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4108 #if defined(__LIBCATAMOUNT__)
4109 PL_statusvalue = -1;
4118 while (++MARK <= SP) {
4119 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4124 TAINT_PROPER("system");
4126 PERL_FLUSHALL_FOR_CHILD;
4127 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4133 if (PerlProc_pipe(pp) >= 0)
4135 while ((childpid = PerlProc_fork()) == -1) {
4136 if (errno != EAGAIN) {
4141 PerlLIO_close(pp[0]);
4142 PerlLIO_close(pp[1]);
4149 Sigsave_t ihand,qhand; /* place to save signals during system() */
4153 PerlLIO_close(pp[1]);
4155 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4156 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4159 result = wait4pid(childpid, &status, 0);
4160 } while (result == -1 && errno == EINTR);
4162 (void)rsignal_restore(SIGINT, &ihand);
4163 (void)rsignal_restore(SIGQUIT, &qhand);
4165 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4166 do_execfree(); /* free any memory child malloced on fork */
4173 while (n < sizeof(int)) {
4174 n1 = PerlLIO_read(pp[0],
4175 (void*)(((char*)&errkid)+n),
4181 PerlLIO_close(pp[0]);
4182 if (n) { /* Error */
4183 if (n != sizeof(int))
4184 DIE(aTHX_ "panic: kid popen errno read");
4185 errno = errkid; /* Propagate errno from kid */
4186 STATUS_NATIVE_CHILD_SET(-1);
4189 XPUSHi(STATUS_CURRENT);
4193 PerlLIO_close(pp[0]);
4194 #if defined(HAS_FCNTL) && defined(F_SETFD)
4195 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4198 if (PL_op->op_flags & OPf_STACKED) {
4199 SV * const really = *++MARK;
4200 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4202 else if (SP - MARK != 1)
4203 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4205 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4209 #else /* ! FORK or VMS or OS/2 */
4212 if (PL_op->op_flags & OPf_STACKED) {
4213 SV * const really = *++MARK;
4214 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4215 value = (I32)do_aspawn(really, MARK, SP);
4217 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4220 else if (SP - MARK != 1) {
4221 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4222 value = (I32)do_aspawn(NULL, MARK, SP);
4224 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4228 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4230 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4232 STATUS_NATIVE_CHILD_SET(value);
4235 XPUSHi(result ? value : STATUS_CURRENT);
4236 #endif /* !FORK or VMS or OS/2 */
4243 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4248 while (++MARK <= SP) {
4249 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4254 TAINT_PROPER("exec");
4256 PERL_FLUSHALL_FOR_CHILD;
4257 if (PL_op->op_flags & OPf_STACKED) {
4258 SV * const really = *++MARK;
4259 value = (I32)do_aexec(really, MARK, SP);
4261 else if (SP - MARK != 1)
4263 value = (I32)vms_do_aexec(NULL, MARK, SP);
4267 (void ) do_aspawn(NULL, MARK, SP);
4271 value = (I32)do_aexec(NULL, MARK, SP);
4276 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4279 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4282 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4296 # ifdef THREADS_HAVE_PIDS
4297 if (PL_ppid != 1 && getppid() == 1)
4298 /* maybe the parent process has died. Refresh ppid cache */
4302 XPUSHi( getppid() );
4306 DIE(aTHX_ PL_no_func, "getppid");
4315 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4318 pgrp = (I32)BSD_GETPGRP(pid);
4320 if (pid != 0 && pid != PerlProc_getpid())
4321 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4327 DIE(aTHX_ PL_no_func, "getpgrp()");
4347 TAINT_PROPER("setpgrp");
4349 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4351 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4352 || (pid != 0 && pid != PerlProc_getpid()))
4354 DIE(aTHX_ "setpgrp can't take arguments");
4356 SETi( setpgrp() >= 0 );
4357 #endif /* USE_BSDPGRP */
4360 DIE(aTHX_ PL_no_func, "setpgrp()");
4364 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4365 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4367 # define PRIORITY_WHICH_T(which) which
4372 #ifdef HAS_GETPRIORITY
4374 const int who = POPi;
4375 const int which = TOPi;
4376 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4379 DIE(aTHX_ PL_no_func, "getpriority()");
4385 #ifdef HAS_SETPRIORITY
4387 const int niceval = POPi;
4388 const int who = POPi;
4389 const int which = TOPi;
4390 TAINT_PROPER("setpriority");
4391 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4394 DIE(aTHX_ PL_no_func, "setpriority()");
4398 #undef PRIORITY_WHICH_T
4406 XPUSHn( time(NULL) );
4408 XPUSHi( time(NULL) );
4420 (void)PerlProc_times(&PL_timesbuf);
4422 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4423 /* struct tms, though same data */
4427 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4428 if (GIMME == G_ARRAY) {
4429 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4430 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4431 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4439 if (GIMME == G_ARRAY) {
4446 DIE(aTHX_ "times not implemented");
4448 #endif /* HAS_TIMES */
4451 /* The 32 bit int year limits the times we can represent to these
4452 boundaries with a few days wiggle room to account for time zone
4455 /* Sat Jan 3 00:00:00 -2147481748 */
4456 #define TIME_LOWER_BOUND -67768100567755200.0
4457 /* Sun Dec 29 12:00:00 2147483647 */
4458 #define TIME_UPPER_BOUND 67767976233316800.0
4467 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4468 static const char * const dayname[] =
4469 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4470 static const char * const monname[] =
4471 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4472 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4477 when = (Time64_T)now;
4480 NV input = Perl_floor(POPn);
4481 when = (Time64_T)input;
4482 if (when != input) {
4483 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4484 "%s(%.0" NVff ") too large", opname, input);
4488 if ( TIME_LOWER_BOUND > when ) {
4489 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4490 "%s(%.0" NVff ") too small", opname, when);
4493 else if( when > TIME_UPPER_BOUND ) {
4494 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4495 "%s(%.0" NVff ") too large", opname, when);
4499 if (PL_op->op_type == OP_LOCALTIME)
4500 err = S_localtime64_r(&when, &tmbuf);
4502 err = S_gmtime64_r(&when, &tmbuf);
4506 /* XXX %lld broken for quads */
4507 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4508 "%s(%.0" NVff ") failed", opname, when);
4511 if (GIMME != G_ARRAY) { /* scalar context */
4513 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4514 double year = (double)tmbuf.tm_year + 1900;
4521 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4522 dayname[tmbuf.tm_wday],
4523 monname[tmbuf.tm_mon],
4531 else { /* list context */
4537 mPUSHi(tmbuf.tm_sec);
4538 mPUSHi(tmbuf.tm_min);
4539 mPUSHi(tmbuf.tm_hour);
4540 mPUSHi(tmbuf.tm_mday);
4541 mPUSHi(tmbuf.tm_mon);
4542 mPUSHn(tmbuf.tm_year);
4543 mPUSHi(tmbuf.tm_wday);
4544 mPUSHi(tmbuf.tm_yday);
4545 mPUSHi(tmbuf.tm_isdst);
4556 anum = alarm((unsigned int)anum);
4562 DIE(aTHX_ PL_no_func, "alarm");
4573 (void)time(&lasttime);
4578 PerlProc_sleep((unsigned int)duration);
4581 XPUSHi(when - lasttime);
4585 /* Shared memory. */
4586 /* Merged with some message passing. */
4590 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4591 dVAR; dSP; dMARK; dTARGET;
4592 const int op_type = PL_op->op_type;
4597 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4600 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4603 value = (I32)(do_semop(MARK, SP) >= 0);
4606 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4614 return Perl_pp_semget(aTHX);
4622 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4623 dVAR; dSP; dMARK; dTARGET;
4624 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4631 DIE(aTHX_ "System V IPC is not implemented on this machine");
4637 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4638 dVAR; dSP; dMARK; dTARGET;
4639 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4647 PUSHp(zero_but_true, ZBTLEN);
4651 return Perl_pp_semget(aTHX);
4655 /* I can't const this further without getting warnings about the types of
4656 various arrays passed in from structures. */
4658 S_space_join_names_mortal(pTHX_ char *const *array)
4662 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4664 if (array && *array) {
4665 target = newSVpvs_flags("", SVs_TEMP);
4667 sv_catpv(target, *array);
4670 sv_catpvs(target, " ");
4673 target = sv_mortalcopy(&PL_sv_no);
4678 /* Get system info. */
4682 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4684 I32 which = PL_op->op_type;
4685 register char **elem;
4687 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4688 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4689 struct hostent *gethostbyname(Netdb_name_t);
4690 struct hostent *gethostent(void);
4692 struct hostent *hent = NULL;
4696 if (which == OP_GHBYNAME) {
4697 #ifdef HAS_GETHOSTBYNAME
4698 const char* const name = POPpbytex;
4699 hent = PerlSock_gethostbyname(name);
4701 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4704 else if (which == OP_GHBYADDR) {
4705 #ifdef HAS_GETHOSTBYADDR
4706 const int addrtype = POPi;
4707 SV * const addrsv = POPs;
4709 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4711 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4713 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4717 #ifdef HAS_GETHOSTENT
4718 hent = PerlSock_gethostent();
4720 DIE(aTHX_ PL_no_sock_func, "gethostent");
4723 #ifdef HOST_NOT_FOUND
4725 #ifdef USE_REENTRANT_API
4726 # ifdef USE_GETHOSTENT_ERRNO
4727 h_errno = PL_reentrant_buffer->_gethostent_errno;
4730 STATUS_UNIX_SET(h_errno);
4734 if (GIMME != G_ARRAY) {
4735 PUSHs(sv = sv_newmortal());
4737 if (which == OP_GHBYNAME) {
4739 sv_setpvn(sv, hent->h_addr, hent->h_length);
4742 sv_setpv(sv, (char*)hent->h_name);
4748 mPUSHs(newSVpv((char*)hent->h_name, 0));
4749 PUSHs(space_join_names_mortal(hent->h_aliases));
4750 mPUSHi(hent->h_addrtype);
4751 len = hent->h_length;
4754 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4755 mXPUSHp(*elem, len);
4759 mPUSHp(hent->h_addr, len);
4761 PUSHs(sv_mortalcopy(&PL_sv_no));
4766 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4772 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4774 I32 which = PL_op->op_type;
4776 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4777 struct netent *getnetbyaddr(Netdb_net_t, int);
4778 struct netent *getnetbyname(Netdb_name_t);
4779 struct netent *getnetent(void);
4781 struct netent *nent;
4783 if (which == OP_GNBYNAME){
4784 #ifdef HAS_GETNETBYNAME
4785 const char * const name = POPpbytex;
4786 nent = PerlSock_getnetbyname(name);
4788 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4791 else if (which == OP_GNBYADDR) {
4792 #ifdef HAS_GETNETBYADDR
4793 const int addrtype = POPi;
4794 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4795 nent = PerlSock_getnetbyaddr(addr, addrtype);
4797 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4801 #ifdef HAS_GETNETENT
4802 nent = PerlSock_getnetent();
4804 DIE(aTHX_ PL_no_sock_func, "getnetent");
4807 #ifdef HOST_NOT_FOUND
4809 #ifdef USE_REENTRANT_API
4810 # ifdef USE_GETNETENT_ERRNO
4811 h_errno = PL_reentrant_buffer->_getnetent_errno;
4814 STATUS_UNIX_SET(h_errno);
4819 if (GIMME != G_ARRAY) {
4820 PUSHs(sv = sv_newmortal());
4822 if (which == OP_GNBYNAME)
4823 sv_setiv(sv, (IV)nent->n_net);
4825 sv_setpv(sv, nent->n_name);
4831 mPUSHs(newSVpv(nent->n_name, 0));
4832 PUSHs(space_join_names_mortal(nent->n_aliases));
4833 mPUSHi(nent->n_addrtype);
4834 mPUSHi(nent->n_net);
4839 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4845 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4847 I32 which = PL_op->op_type;
4849 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4850 struct protoent *getprotobyname(Netdb_name_t);
4851 struct protoent *getprotobynumber(int);
4852 struct protoent *getprotoent(void);
4854 struct protoent *pent;
4856 if (which == OP_GPBYNAME) {
4857 #ifdef HAS_GETPROTOBYNAME
4858 const char* const name = POPpbytex;
4859 pent = PerlSock_getprotobyname(name);
4861 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4864 else if (which == OP_GPBYNUMBER) {
4865 #ifdef HAS_GETPROTOBYNUMBER
4866 const int number = POPi;
4867 pent = PerlSock_getprotobynumber(number);
4869 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4873 #ifdef HAS_GETPROTOENT
4874 pent = PerlSock_getprotoent();
4876 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4880 if (GIMME != G_ARRAY) {
4881 PUSHs(sv = sv_newmortal());
4883 if (which == OP_GPBYNAME)
4884 sv_setiv(sv, (IV)pent->p_proto);
4886 sv_setpv(sv, pent->p_name);
4892 mPUSHs(newSVpv(pent->p_name, 0));
4893 PUSHs(space_join_names_mortal(pent->p_aliases));
4894 mPUSHi(pent->p_proto);
4899 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4905 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4907 I32 which = PL_op->op_type;
4909 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4910 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4911 struct servent *getservbyport(int, Netdb_name_t);
4912 struct servent *getservent(void);
4914 struct servent *sent;
4916 if (which == OP_GSBYNAME) {
4917 #ifdef HAS_GETSERVBYNAME
4918 const char * const proto = POPpbytex;
4919 const char * const name = POPpbytex;
4920 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4922 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4925 else if (which == OP_GSBYPORT) {
4926 #ifdef HAS_GETSERVBYPORT
4927 const char * const proto = POPpbytex;
4928 unsigned short port = (unsigned short)POPu;
4930 port = PerlSock_htons(port);
4932 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4934 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4938 #ifdef HAS_GETSERVENT
4939 sent = PerlSock_getservent();
4941 DIE(aTHX_ PL_no_sock_func, "getservent");
4945 if (GIMME != G_ARRAY) {
4946 PUSHs(sv = sv_newmortal());
4948 if (which == OP_GSBYNAME) {
4950 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4952 sv_setiv(sv, (IV)(sent->s_port));
4956 sv_setpv(sv, sent->s_name);
4962 mPUSHs(newSVpv(sent->s_name, 0));
4963 PUSHs(space_join_names_mortal(sent->s_aliases));
4965 mPUSHi(PerlSock_ntohs(sent->s_port));
4967 mPUSHi(sent->s_port);
4969 mPUSHs(newSVpv(sent->s_proto, 0));
4974 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4981 const int stayopen = TOPi;
4982 switch(PL_op->op_type) {
4984 #ifdef HAS_SETHOSTENT
4985 PerlSock_sethostent(stayopen);
4987 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4990 #ifdef HAS_SETNETENT
4992 PerlSock_setnetent(stayopen);
4994 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4998 #ifdef HAS_SETPROTOENT
4999 PerlSock_setprotoent(stayopen);
5001 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5005 #ifdef HAS_SETSERVENT
5006 PerlSock_setservent(stayopen);
5008 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5018 switch(PL_op->op_type) {
5020 #ifdef HAS_ENDHOSTENT
5021 PerlSock_endhostent();
5023 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5027 #ifdef HAS_ENDNETENT
5028 PerlSock_endnetent();
5030 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5034 #ifdef HAS_ENDPROTOENT
5035 PerlSock_endprotoent();
5037 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5041 #ifdef HAS_ENDSERVENT
5042 PerlSock_endservent();
5044 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5048 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5051 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5055 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5058 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5062 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5065 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5069 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5072 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5084 I32 which = PL_op->op_type;
5086 struct passwd *pwent = NULL;
5088 * We currently support only the SysV getsp* shadow password interface.
5089 * The interface is declared in <shadow.h> and often one needs to link
5090 * with -lsecurity or some such.
5091 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5094 * AIX getpwnam() is clever enough to return the encrypted password
5095 * only if the caller (euid?) is root.
5097 * There are at least three other shadow password APIs. Many platforms
5098 * seem to contain more than one interface for accessing the shadow
5099 * password databases, possibly for compatibility reasons.
5100 * The getsp*() is by far he simplest one, the other two interfaces
5101 * are much more complicated, but also very similar to each other.
5106 * struct pr_passwd *getprpw*();
5107 * The password is in
5108 * char getprpw*(...).ufld.fd_encrypt[]
5109 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5114 * struct es_passwd *getespw*();
5115 * The password is in
5116 * char *(getespw*(...).ufld.fd_encrypt)
5117 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5120 * struct userpw *getuserpw();
5121 * The password is in
5122 * char *(getuserpw(...)).spw_upw_passwd
5123 * (but the de facto standard getpwnam() should work okay)
5125 * Mention I_PROT here so that Configure probes for it.
5127 * In HP-UX for getprpw*() the manual page claims that one should include
5128 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5129 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5130 * and pp_sys.c already includes <shadow.h> if there is such.
5132 * Note that <sys/security.h> is already probed for, but currently
5133 * it is only included in special cases.
5135 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5136 * be preferred interface, even though also the getprpw*() interface
5137 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5138 * One also needs to call set_auth_parameters() in main() before
5139 * doing anything else, whether one is using getespw*() or getprpw*().
5141 * Note that accessing the shadow databases can be magnitudes
5142 * slower than accessing the standard databases.
5147 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5148 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5149 * the pw_comment is left uninitialized. */
5150 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5156 const char* const name = POPpbytex;
5157 pwent = getpwnam(name);
5163 pwent = getpwuid(uid);
5167 # ifdef HAS_GETPWENT
5169 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5170 if (pwent) pwent = getpwnam(pwent->pw_name);
5173 DIE(aTHX_ PL_no_func, "getpwent");
5179 if (GIMME != G_ARRAY) {
5180 PUSHs(sv = sv_newmortal());
5182 if (which == OP_GPWNAM)
5183 # if Uid_t_sign <= 0
5184 sv_setiv(sv, (IV)pwent->pw_uid);
5186 sv_setuv(sv, (UV)pwent->pw_uid);
5189 sv_setpv(sv, pwent->pw_name);
5195 mPUSHs(newSVpv(pwent->pw_name, 0));
5199 /* If we have getspnam(), we try to dig up the shadow
5200 * password. If we are underprivileged, the shadow
5201 * interface will set the errno to EACCES or similar,
5202 * and return a null pointer. If this happens, we will
5203 * use the dummy password (usually "*" or "x") from the
5204 * standard password database.
5206 * In theory we could skip the shadow call completely
5207 * if euid != 0 but in practice we cannot know which
5208 * security measures are guarding the shadow databases
5209 * on a random platform.
5211 * Resist the urge to use additional shadow interfaces.
5212 * Divert the urge to writing an extension instead.
5215 /* Some AIX setups falsely(?) detect some getspnam(), which
5216 * has a different API than the Solaris/IRIX one. */
5217 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5220 const struct spwd * const spwent = getspnam(pwent->pw_name);
5221 /* Save and restore errno so that
5222 * underprivileged attempts seem
5223 * to have never made the unsuccessful
5224 * attempt to retrieve the shadow password. */
5226 if (spwent && spwent->sp_pwdp)
5227 sv_setpv(sv, spwent->sp_pwdp);
5231 if (!SvPOK(sv)) /* Use the standard password, then. */
5232 sv_setpv(sv, pwent->pw_passwd);
5235 # ifndef INCOMPLETE_TAINTS
5236 /* passwd is tainted because user himself can diddle with it.
5237 * admittedly not much and in a very limited way, but nevertheless. */
5241 # if Uid_t_sign <= 0
5242 mPUSHi(pwent->pw_uid);
5244 mPUSHu(pwent->pw_uid);
5247 # if Uid_t_sign <= 0
5248 mPUSHi(pwent->pw_gid);
5250 mPUSHu(pwent->pw_gid);
5252 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5253 * because of the poor interface of the Perl getpw*(),
5254 * not because there's some standard/convention saying so.
5255 * A better interface would have been to return a hash,
5256 * but we are accursed by our history, alas. --jhi. */
5258 mPUSHi(pwent->pw_change);
5261 mPUSHi(pwent->pw_quota);
5264 mPUSHs(newSVpv(pwent->pw_age, 0));
5266 /* I think that you can never get this compiled, but just in case. */
5267 PUSHs(sv_mortalcopy(&PL_sv_no));
5272 /* pw_class and pw_comment are mutually exclusive--.
5273 * see the above note for pw_change, pw_quota, and pw_age. */
5275 mPUSHs(newSVpv(pwent->pw_class, 0));
5278 mPUSHs(newSVpv(pwent->pw_comment, 0));
5280 /* I think that you can never get this compiled, but just in case. */
5281 PUSHs(sv_mortalcopy(&PL_sv_no));
5286 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5288 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5290 # ifndef INCOMPLETE_TAINTS
5291 /* pw_gecos is tainted because user himself can diddle with it. */
5295 mPUSHs(newSVpv(pwent->pw_dir, 0));
5297 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5298 # ifndef INCOMPLETE_TAINTS
5299 /* pw_shell is tainted because user himself can diddle with it. */
5304 mPUSHi(pwent->pw_expire);
5309 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5317 const I32 which = PL_op->op_type;
5318 const struct group *grent;
5320 if (which == OP_GGRNAM) {
5321 const char* const name = POPpbytex;
5322 grent = (const struct group *)getgrnam(name);
5324 else if (which == OP_GGRGID) {
5325 const Gid_t gid = POPi;
5326 grent = (const struct group *)getgrgid(gid);
5330 grent = (struct group *)getgrent();
5332 DIE(aTHX_ PL_no_func, "getgrent");
5336 if (GIMME != G_ARRAY) {
5337 SV * const sv = sv_newmortal();
5341 if (which == OP_GGRNAM)
5343 sv_setiv(sv, (IV)grent->gr_gid);
5345 sv_setuv(sv, (UV)grent->gr_gid);
5348 sv_setpv(sv, grent->gr_name);
5354 mPUSHs(newSVpv(grent->gr_name, 0));
5357 mPUSHs(newSVpv(grent->gr_passwd, 0));
5359 PUSHs(sv_mortalcopy(&PL_sv_no));
5363 mPUSHi(grent->gr_gid);
5365 mPUSHu(grent->gr_gid);
5368 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5369 /* In UNICOS/mk (_CRAYMPP) the multithreading
5370 * versions (getgrnam_r, getgrgid_r)
5371 * seem to return an illegal pointer
5372 * as the group members list, gr_mem.
5373 * getgrent() doesn't even have a _r version
5374 * but the gr_mem is poisonous anyway.
5375 * So yes, you cannot get the list of group
5376 * members if building multithreaded in UNICOS/mk. */
5377 PUSHs(space_join_names_mortal(grent->gr_mem));
5383 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5393 if (!(tmps = PerlProc_getlogin()))
5395 sv_setpv_mg(TARG, tmps);
5399 DIE(aTHX_ PL_no_func, "getlogin");
5403 /* Miscellaneous. */
5408 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5409 register I32 items = SP - MARK;
5410 unsigned long a[20];
5415 while (++MARK <= SP) {
5416 if (SvTAINTED(*MARK)) {
5422 TAINT_PROPER("syscall");
5425 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5426 * or where sizeof(long) != sizeof(char*). But such machines will
5427 * not likely have syscall implemented either, so who cares?
5429 while (++MARK <= SP) {
5430 if (SvNIOK(*MARK) || !i)
5431 a[i++] = SvIV(*MARK);
5432 else if (*MARK == &PL_sv_undef)
5435 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5441 DIE(aTHX_ "Too many args to syscall");
5443 DIE(aTHX_ "Too few args to syscall");
5445 retval = syscall(a[0]);
5448 retval = syscall(a[0],a[1]);
5451 retval = syscall(a[0],a[1],a[2]);
5454 retval = syscall(a[0],a[1],a[2],a[3]);
5457 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5460 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5463 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5466 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5470 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5473 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5476 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5480 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5484 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5488 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5489 a[10],a[11],a[12],a[13]);
5491 #endif /* atarist */
5497 DIE(aTHX_ PL_no_func, "syscall");
5501 #ifdef FCNTL_EMULATE_FLOCK
5503 /* XXX Emulate flock() with fcntl().
5504 What's really needed is a good file locking module.
5508 fcntl_emulate_flock(int fd, int operation)
5513 switch (operation & ~LOCK_NB) {
5515 flock.l_type = F_RDLCK;
5518 flock.l_type = F_WRLCK;
5521 flock.l_type = F_UNLCK;
5527 flock.l_whence = SEEK_SET;
5528 flock.l_start = flock.l_len = (Off_t)0;
5530 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5531 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5532 errno = EWOULDBLOCK;
5536 #endif /* FCNTL_EMULATE_FLOCK */
5538 #ifdef LOCKF_EMULATE_FLOCK
5540 /* XXX Emulate flock() with lockf(). This is just to increase
5541 portability of scripts. The calls are not completely
5542 interchangeable. What's really needed is a good file
5546 /* The lockf() constants might have been defined in <unistd.h>.
5547 Unfortunately, <unistd.h> causes troubles on some mixed
5548 (BSD/POSIX) systems, such as SunOS 4.1.3.
5550 Further, the lockf() constants aren't POSIX, so they might not be
5551 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5552 just stick in the SVID values and be done with it. Sigh.
5556 # define F_ULOCK 0 /* Unlock a previously locked region */
5559 # define F_LOCK 1 /* Lock a region for exclusive use */
5562 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5565 # define F_TEST 3 /* Test a region for other processes locks */
5569 lockf_emulate_flock(int fd, int operation)
5575 /* flock locks entire file so for lockf we need to do the same */
5576 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5577 if (pos > 0) /* is seekable and needs to be repositioned */
5578 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5579 pos = -1; /* seek failed, so don't seek back afterwards */
5582 switch (operation) {
5584 /* LOCK_SH - get a shared lock */
5586 /* LOCK_EX - get an exclusive lock */
5588 i = lockf (fd, F_LOCK, 0);
5591 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5592 case LOCK_SH|LOCK_NB:
5593 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5594 case LOCK_EX|LOCK_NB:
5595 i = lockf (fd, F_TLOCK, 0);
5597 if ((errno == EAGAIN) || (errno == EACCES))
5598 errno = EWOULDBLOCK;
5601 /* LOCK_UN - unlock (non-blocking is a no-op) */
5603 case LOCK_UN|LOCK_NB:
5604 i = lockf (fd, F_ULOCK, 0);
5607 /* Default - can't decipher operation */
5614 if (pos > 0) /* need to restore position of the handle */
5615 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5620 #endif /* LOCKF_EMULATE_FLOCK */
5624 * c-indentation-style: bsd
5626 * indent-tabs-mode: t
5629 * ex: set ts=8 sts=4 sw=4 noet: