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, ...)
517 PERL_ARGS_ASSERT_TIED_METHOD;
519 /* Ensure that our flag bits do not overlap. */
520 assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
521 assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
522 assert((TIED_METHOD_SAY & G_WANT) == 0);
524 PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
525 PUSHSTACKi(PERLSI_MAGIC);
526 EXTEND(SP, argc+1); /* object + args */
528 PUSHs(SvTIED_obj(sv, mg));
529 if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
530 Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
534 const U32 mortalize_not_needed
535 = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
537 va_start(args, argc);
539 SV *const arg = va_arg(args, SV *);
540 if(mortalize_not_needed)
549 ENTER_with_name("call_tied_method");
550 if (flags & TIED_METHOD_SAY) {
551 /* local $\ = "\n" */
552 SAVEGENERICSV(PL_ors_sv);
553 PL_ors_sv = newSVpvs("\n");
555 ret_args = call_method(methname, flags & G_WANT);
560 if (ret_args) { /* copy results back to original stack */
561 EXTEND(sp, ret_args);
562 Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
566 LEAVE_with_name("call_tied_method");
570 #define tied_method0(a,b,c,d) \
571 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
572 #define tied_method1(a,b,c,d,e) \
573 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
574 #define tied_method2(a,b,c,d,e,f) \
575 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
588 GV * const gv = MUTABLE_GV(*++MARK);
590 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
591 DIE(aTHX_ PL_no_usym, "filehandle");
593 if ((io = GvIOp(gv))) {
595 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
598 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
599 "Opening dirhandle %s also as a file",
602 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
604 /* Method's args are same as ours ... */
605 /* ... except handle is replaced by the object */
606 return Perl_tied_method(aTHX_ "OPEN", mark - 1, MUTABLE_SV(io), mg,
607 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
619 tmps = SvPV_const(sv, len);
620 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
623 PUSHi( (I32)PL_forkprocess );
624 else if (PL_forkprocess == 0) /* we are a new child */
634 GV * const gv = (MAXARG == 0) ? PL_defoutgv : MUTABLE_GV(POPs);
640 IO * const io = GvIO(gv);
642 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
644 return tied_method0("CLOSE", SP, MUTABLE_SV(io), mg);
648 PUSHs(boolSV(do_close(gv, TRUE)));
661 GV * const wgv = MUTABLE_GV(POPs);
662 GV * const rgv = MUTABLE_GV(POPs);
667 if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
668 DIE(aTHX_ PL_no_usym, "filehandle");
673 do_close(rgv, FALSE);
675 do_close(wgv, FALSE);
677 if (PerlProc_pipe(fd) < 0)
680 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
681 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
682 IoOFP(rstio) = IoIFP(rstio);
683 IoIFP(wstio) = IoOFP(wstio);
684 IoTYPE(rstio) = IoTYPE_RDONLY;
685 IoTYPE(wstio) = IoTYPE_WRONLY;
687 if (!IoIFP(rstio) || !IoOFP(wstio)) {
689 PerlIO_close(IoIFP(rstio));
691 PerlLIO_close(fd[0]);
693 PerlIO_close(IoOFP(wstio));
695 PerlLIO_close(fd[1]);
698 #if defined(HAS_FCNTL) && defined(F_SETFD)
699 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
700 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
707 DIE(aTHX_ PL_no_func, "pipe");
721 gv = MUTABLE_GV(POPs);
725 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
727 return tied_method0("FILENO", SP, MUTABLE_SV(io), mg);
730 if (!io || !(fp = IoIFP(io))) {
731 /* Can't do this because people seem to do things like
732 defined(fileno($foo)) to check whether $foo is a valid fh.
739 PUSHi(PerlIO_fileno(fp));
752 anum = PerlLIO_umask(022);
753 /* setting it to 022 between the two calls to umask avoids
754 * to have a window where the umask is set to 0 -- meaning
755 * that another thread could create world-writeable files. */
757 (void)PerlLIO_umask(anum);
760 anum = PerlLIO_umask(POPi);
761 TAINT_PROPER("umask");
764 /* Only DIE if trying to restrict permissions on "user" (self).
765 * Otherwise it's harmless and more useful to just return undef
766 * since 'group' and 'other' concepts probably don't exist here. */
767 if (MAXARG >= 1 && (POPi & 0700))
768 DIE(aTHX_ "umask not implemented");
769 XPUSHs(&PL_sv_undef);
788 gv = MUTABLE_GV(POPs);
792 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
794 /* This takes advantage of the implementation of the varargs
795 function, which I don't think that the optimiser will be able to
796 figure out. Although, as it's a static function, in theory it
798 return Perl_tied_method(aTHX_ "BINMODE", SP, MUTABLE_SV(io), mg,
799 G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
800 discp ? 1 : 0, discp);
804 if (!io || !(fp = IoIFP(io))) {
806 SETERRNO(EBADF,RMS_IFI);
813 const char *d = NULL;
816 d = SvPV_const(discp, len);
817 mode = mode_from_discipline(d, len);
818 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
819 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
820 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
841 const I32 markoff = MARK - PL_stack_base;
842 const char *methname;
843 int how = PERL_MAGIC_tied;
847 switch(SvTYPE(varsv)) {
849 methname = "TIEHASH";
850 HvEITER_set(MUTABLE_HV(varsv), 0);
853 methname = "TIEARRAY";
857 if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
858 methname = "TIEHANDLE";
859 how = PERL_MAGIC_tiedscalar;
860 /* For tied filehandles, we apply tiedscalar magic to the IO
861 slot of the GP rather than the GV itself. AMS 20010812 */
863 GvIOp(varsv) = newIO();
864 varsv = MUTABLE_SV(GvIOp(varsv));
869 methname = "TIESCALAR";
870 how = PERL_MAGIC_tiedscalar;
874 if (sv_isobject(*MARK)) { /* Calls GET magic. */
875 ENTER_with_name("call_TIE");
876 PUSHSTACKi(PERLSI_MAGIC);
878 EXTEND(SP,(I32)items);
882 call_method(methname, G_SCALAR);
885 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
886 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
887 * wrong error message, and worse case, supreme action at a distance.
888 * (Sorry obfuscation writers. You're not going to be given this one.)
891 const char *name = SvPV_nomg_const(*MARK, len);
892 stash = gv_stashpvn(name, len, 0);
893 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
894 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
895 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
897 ENTER_with_name("call_TIE");
898 PUSHSTACKi(PERLSI_MAGIC);
900 EXTEND(SP,(I32)items);
904 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
910 if (sv_isobject(sv)) {
911 sv_unmagic(varsv, how);
912 /* Croak if a self-tie on an aggregate is attempted. */
913 if (varsv == SvRV(sv) &&
914 (SvTYPE(varsv) == SVt_PVAV ||
915 SvTYPE(varsv) == SVt_PVHV))
917 "Self-ties of arrays and hashes are not supported");
918 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
920 LEAVE_with_name("call_TIE");
921 SP = PL_stack_base + markoff;
931 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
932 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
934 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
937 if ((mg = SvTIED_mg(sv, how))) {
938 SV * const obj = SvRV(SvTIED_obj(sv, mg));
940 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
942 if (gv && isGV(gv) && (cv = GvCV(gv))) {
944 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
945 mXPUSHi(SvREFCNT(obj) - 1);
947 ENTER_with_name("call_UNTIE");
948 call_sv(MUTABLE_SV(cv), G_VOID);
949 LEAVE_with_name("call_UNTIE");
952 else if (mg && SvREFCNT(obj) > 1) {
953 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
954 "untie attempted while %"UVuf" inner references still exist",
955 (UV)SvREFCNT(obj) - 1 ) ;
959 sv_unmagic(sv, how) ;
969 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
970 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
972 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
975 if ((mg = SvTIED_mg(sv, how))) {
976 SV *osv = SvTIED_obj(sv, mg);
977 if (osv == mg->mg_obj)
978 osv = sv_mortalcopy(osv);
992 HV * const hv = MUTABLE_HV(POPs);
993 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
994 stash = gv_stashsv(sv, 0);
995 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
997 require_pv("AnyDBM_File.pm");
999 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1000 DIE(aTHX_ "No dbm on this machine");
1010 mPUSHu(O_RDWR|O_CREAT);
1015 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1018 if (!sv_isobject(TOPs)) {
1026 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1030 if (sv_isobject(TOPs)) {
1031 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1032 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1049 struct timeval timebuf;
1050 struct timeval *tbuf = &timebuf;
1053 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1058 # if BYTEORDER & 0xf0000
1059 # define ORDERBYTE (0x88888888 - BYTEORDER)
1061 # define ORDERBYTE (0x4444 - BYTEORDER)
1067 for (i = 1; i <= 3; i++) {
1068 SV * const sv = SP[i];
1071 if (SvREADONLY(sv)) {
1073 sv_force_normal_flags(sv, 0);
1074 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1075 Perl_croak_no_modify(aTHX);
1078 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1079 SvPV_force_nolen(sv); /* force string conversion */
1086 /* little endians can use vecs directly */
1087 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1094 masksize = NFDBITS / NBBY;
1096 masksize = sizeof(long); /* documented int, everyone seems to use long */
1098 Zero(&fd_sets[0], 4, char*);
1101 # if SELECT_MIN_BITS == 1
1102 growsize = sizeof(fd_set);
1104 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1105 # undef SELECT_MIN_BITS
1106 # define SELECT_MIN_BITS __FD_SETSIZE
1108 /* If SELECT_MIN_BITS is greater than one we most probably will want
1109 * to align the sizes with SELECT_MIN_BITS/8 because for example
1110 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1111 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1112 * on (sets/tests/clears bits) is 32 bits. */
1113 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1121 timebuf.tv_sec = (long)value;
1122 value -= (NV)timebuf.tv_sec;
1123 timebuf.tv_usec = (long)(value * 1000000.0);
1128 for (i = 1; i <= 3; i++) {
1130 if (!SvOK(sv) || SvCUR(sv) == 0) {
1137 Sv_Grow(sv, growsize);
1141 while (++j <= growsize) {
1145 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1147 Newx(fd_sets[i], growsize, char);
1148 for (offset = 0; offset < growsize; offset += masksize) {
1149 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1150 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1153 fd_sets[i] = SvPVX(sv);
1157 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1158 /* Can't make just the (void*) conditional because that would be
1159 * cpp #if within cpp macro, and not all compilers like that. */
1160 nfound = PerlSock_select(
1162 (Select_fd_set_t) fd_sets[1],
1163 (Select_fd_set_t) fd_sets[2],
1164 (Select_fd_set_t) fd_sets[3],
1165 (void*) tbuf); /* Workaround for compiler bug. */
1167 nfound = PerlSock_select(
1169 (Select_fd_set_t) fd_sets[1],
1170 (Select_fd_set_t) fd_sets[2],
1171 (Select_fd_set_t) fd_sets[3],
1174 for (i = 1; i <= 3; i++) {
1177 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1179 for (offset = 0; offset < growsize; offset += masksize) {
1180 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1181 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1183 Safefree(fd_sets[i]);
1190 if (GIMME == G_ARRAY && tbuf) {
1191 value = (NV)(timebuf.tv_sec) +
1192 (NV)(timebuf.tv_usec) / 1000000.0;
1197 DIE(aTHX_ "select not implemented");
1202 =for apidoc setdefout
1204 Sets PL_defoutgv, the default file handle for output, to the passed in
1205 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1206 count of the passed in typeglob is increased by one, and the reference count
1207 of the typeglob that PL_defoutgv points to is decreased by one.
1213 Perl_setdefout(pTHX_ GV *gv)
1216 SvREFCNT_inc_simple_void(gv);
1217 SvREFCNT_dec(PL_defoutgv);
1225 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1226 GV * egv = GvEGVx(PL_defoutgv);
1230 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1232 XPUSHs(&PL_sv_undef);
1234 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1235 if (gvp && *gvp == egv) {
1236 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1240 mXPUSHs(newRV(MUTABLE_SV(egv)));
1245 if (!GvIO(newdefout))
1246 gv_IOadd(newdefout);
1247 setdefout(newdefout);
1256 GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs);
1257 IO *const io = GvIO(gv);
1263 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1265 const U32 gimme = GIMME_V;
1266 Perl_tied_method(aTHX_ "GETC", SP, MUTABLE_SV(io), mg, gimme, 0);
1267 if (gimme == G_SCALAR) {
1269 SvSetMagicSV_nosteal(TARG, TOPs);
1274 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1275 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1277 SETERRNO(EBADF,RMS_IFI);
1281 sv_setpvs(TARG, " ");
1282 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1283 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1284 /* Find out how many bytes the char needs */
1285 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1288 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1289 SvCUR_set(TARG,1+len);
1298 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1301 register PERL_CONTEXT *cx;
1302 const I32 gimme = GIMME_V;
1304 PERL_ARGS_ASSERT_DOFORM;
1306 if (cv && CvCLONE(cv))
1307 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1312 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1313 PUSHFORMAT(cx, retop);
1315 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1317 setdefout(gv); /* locally select filehandle so $% et al work */
1336 gv = MUTABLE_GV(POPs);
1350 goto not_a_format_reference;
1355 tmpsv = sv_newmortal();
1356 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1357 name = SvPV_nolen_const(tmpsv);
1359 DIE(aTHX_ "Undefined format \"%s\" called", name);
1361 not_a_format_reference:
1362 DIE(aTHX_ "Not a format reference");
1364 IoFLAGS(io) &= ~IOf_DIDTOP;
1365 return doform(cv,gv,PL_op->op_next);
1371 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1372 register IO * const io = GvIOp(gv);
1377 register PERL_CONTEXT *cx;
1380 if (!io || !(ofp = IoOFP(io)))
1383 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1384 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1386 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1387 PL_formtarget != PL_toptarget)
1391 if (!IoTOP_GV(io)) {
1394 if (!IoTOP_NAME(io)) {
1396 if (!IoFMT_NAME(io))
1397 IoFMT_NAME(io) = savepv(GvNAME(gv));
1398 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1399 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1400 if ((topgv && GvFORM(topgv)) ||
1401 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1402 IoTOP_NAME(io) = savesvpv(topname);
1404 IoTOP_NAME(io) = savepvs("top");
1406 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1407 if (!topgv || !GvFORM(topgv)) {
1408 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1411 IoTOP_GV(io) = topgv;
1413 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1414 I32 lines = IoLINES_LEFT(io);
1415 const char *s = SvPVX_const(PL_formtarget);
1416 if (lines <= 0) /* Yow, header didn't even fit!!! */
1418 while (lines-- > 0) {
1419 s = strchr(s, '\n');
1425 const STRLEN save = SvCUR(PL_formtarget);
1426 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1427 do_print(PL_formtarget, ofp);
1428 SvCUR_set(PL_formtarget, save);
1429 sv_chop(PL_formtarget, s);
1430 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1433 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1434 do_print(PL_formfeed, ofp);
1435 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1437 PL_formtarget = PL_toptarget;
1438 IoFLAGS(io) |= IOf_DIDTOP;
1441 DIE(aTHX_ "bad top format reference");
1444 SV * const sv = sv_newmortal();
1446 gv_efullname4(sv, fgv, NULL, FALSE);
1447 name = SvPV_nolen_const(sv);
1449 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1451 DIE(aTHX_ "Undefined top format called");
1453 return doform(cv, gv, PL_op);
1457 POPBLOCK(cx,PL_curpm);
1459 retop = cx->blk_sub.retop;
1465 report_wrongway_fh(gv, '<');
1471 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1472 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1474 if (!do_print(PL_formtarget, fp))
1477 FmLINES(PL_formtarget) = 0;
1478 SvCUR_set(PL_formtarget, 0);
1479 *SvEND(PL_formtarget) = '\0';
1480 if (IoFLAGS(io) & IOf_FLUSH)
1481 (void)PerlIO_flush(fp);
1486 PL_formtarget = PL_bodytarget;
1488 PERL_UNUSED_VAR(newsp);
1489 PERL_UNUSED_VAR(gimme);
1495 dVAR; dSP; dMARK; dORIGMARK;
1500 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1501 IO *const io = GvIO(gv);
1504 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1506 if (MARK == ORIGMARK) {
1509 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1512 return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io),
1514 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1522 SETERRNO(EBADF,RMS_IFI);
1525 else if (!(fp = IoOFP(io))) {
1527 report_wrongway_fh(gv, '<');
1528 else if (ckWARN(WARN_CLOSED))
1530 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1534 do_sprintf(sv, SP - MARK, MARK + 1);
1535 if (!do_print(sv, fp))
1538 if (IoFLAGS(io) & IOf_FLUSH)
1539 if (PerlIO_flush(fp) == EOF)
1550 PUSHs(&PL_sv_undef);
1558 const int perm = (MAXARG > 3) ? POPi : 0666;
1559 const int mode = POPi;
1560 SV * const sv = POPs;
1561 GV * const gv = MUTABLE_GV(POPs);
1564 /* Need TIEHANDLE method ? */
1565 const char * const tmps = SvPV_const(sv, len);
1566 /* FIXME? do_open should do const */
1567 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1568 IoLINES(GvIOp(gv)) = 0;
1572 PUSHs(&PL_sv_undef);
1579 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1585 Sock_size_t bufsize;
1593 bool charstart = FALSE;
1594 STRLEN charskip = 0;
1597 GV * const gv = MUTABLE_GV(*++MARK);
1598 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1599 && gv && (io = GvIO(gv)) )
1601 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1603 return Perl_tied_method(aTHX_ "READ", mark - 1, MUTABLE_SV(io), mg,
1604 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1613 sv_setpvs(bufsv, "");
1614 length = SvIVx(*++MARK);
1617 offset = SvIVx(*++MARK);
1621 if (!io || !IoIFP(io)) {
1623 SETERRNO(EBADF,RMS_IFI);
1626 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1627 buffer = SvPVutf8_force(bufsv, blen);
1628 /* UTF-8 may not have been set if they are all low bytes */
1633 buffer = SvPV_force(bufsv, blen);
1634 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1637 DIE(aTHX_ "Negative length");
1645 if (PL_op->op_type == OP_RECV) {
1646 char namebuf[MAXPATHLEN];
1647 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1648 bufsize = sizeof (struct sockaddr_in);
1650 bufsize = sizeof namebuf;
1652 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1656 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1657 /* 'offset' means 'flags' here */
1658 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1659 (struct sockaddr *)namebuf, &bufsize);
1662 /* MSG_TRUNC can give oversized count; quietly lose it */
1666 /* Bogus return without padding */
1667 bufsize = sizeof (struct sockaddr_in);
1669 SvCUR_set(bufsv, count);
1670 *SvEND(bufsv) = '\0';
1671 (void)SvPOK_only(bufsv);
1675 /* This should not be marked tainted if the fp is marked clean */
1676 if (!(IoFLAGS(io) & IOf_UNTAINT))
1677 SvTAINTED_on(bufsv);
1679 sv_setpvn(TARG, namebuf, bufsize);
1684 if (DO_UTF8(bufsv)) {
1685 /* offset adjust in characters not bytes */
1686 blen = sv_len_utf8(bufsv);
1689 if (-offset > (int)blen)
1690 DIE(aTHX_ "Offset outside string");
1693 if (DO_UTF8(bufsv)) {
1694 /* convert offset-as-chars to offset-as-bytes */
1695 if (offset >= (int)blen)
1696 offset += SvCUR(bufsv) - blen;
1698 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1701 bufsize = SvCUR(bufsv);
1702 /* Allocating length + offset + 1 isn't perfect in the case of reading
1703 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1705 (should be 2 * length + offset + 1, or possibly something longer if
1706 PL_encoding is true) */
1707 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1708 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1709 Zero(buffer+bufsize, offset-bufsize, char);
1711 buffer = buffer + offset;
1713 read_target = bufsv;
1715 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1716 concatenate it to the current buffer. */
1718 /* Truncate the existing buffer to the start of where we will be
1720 SvCUR_set(bufsv, offset);
1722 read_target = sv_newmortal();
1723 SvUPGRADE(read_target, SVt_PV);
1724 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1727 if (PL_op->op_type == OP_SYSREAD) {
1728 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1729 if (IoTYPE(io) == IoTYPE_SOCKET) {
1730 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1736 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1741 #ifdef HAS_SOCKET__bad_code_maybe
1742 if (IoTYPE(io) == IoTYPE_SOCKET) {
1743 char namebuf[MAXPATHLEN];
1744 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1745 bufsize = sizeof (struct sockaddr_in);
1747 bufsize = sizeof namebuf;
1749 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1750 (struct sockaddr *)namebuf, &bufsize);
1755 count = PerlIO_read(IoIFP(io), buffer, length);
1756 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1757 if (count == 0 && PerlIO_error(IoIFP(io)))
1761 if (IoTYPE(io) == IoTYPE_WRONLY)
1762 report_wrongway_fh(gv, '>');
1765 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1766 *SvEND(read_target) = '\0';
1767 (void)SvPOK_only(read_target);
1768 if (fp_utf8 && !IN_BYTES) {
1769 /* Look at utf8 we got back and count the characters */
1770 const char *bend = buffer + count;
1771 while (buffer < bend) {
1773 skip = UTF8SKIP(buffer);
1776 if (buffer - charskip + skip > bend) {
1777 /* partial character - try for rest of it */
1778 length = skip - (bend-buffer);
1779 offset = bend - SvPVX_const(bufsv);
1791 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1792 provided amount read (count) was what was requested (length)
1794 if (got < wanted && count == length) {
1795 length = wanted - got;
1796 offset = bend - SvPVX_const(bufsv);
1799 /* return value is character count */
1803 else if (buffer_utf8) {
1804 /* Let svcatsv upgrade the bytes we read in to utf8.
1805 The buffer is a mortal so will be freed soon. */
1806 sv_catsv_nomg(bufsv, read_target);
1809 /* This should not be marked tainted if the fp is marked clean */
1810 if (!(IoFLAGS(io) & IOf_UNTAINT))
1811 SvTAINTED_on(bufsv);
1823 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1828 STRLEN orig_blen_bytes;
1829 const int op_type = PL_op->op_type;
1832 GV *const gv = MUTABLE_GV(*++MARK);
1833 IO *const io = GvIO(gv);
1835 if (op_type == OP_SYSWRITE && io) {
1836 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1838 if (MARK == SP - 1) {
1840 mXPUSHi(sv_len(sv));
1844 return Perl_tied_method(aTHX_ "WRITE", mark - 1, MUTABLE_SV(io), mg,
1845 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1855 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1857 if (io && IoIFP(io))
1858 report_wrongway_fh(gv, '<');
1861 SETERRNO(EBADF,RMS_IFI);
1865 /* Do this first to trigger any overloading. */
1866 buffer = SvPV_const(bufsv, blen);
1867 orig_blen_bytes = blen;
1868 doing_utf8 = DO_UTF8(bufsv);
1870 if (PerlIO_isutf8(IoIFP(io))) {
1871 if (!SvUTF8(bufsv)) {
1872 /* We don't modify the original scalar. */
1873 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1874 buffer = (char *) tmpbuf;
1878 else if (doing_utf8) {
1879 STRLEN tmplen = blen;
1880 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1883 buffer = (char *) tmpbuf;
1887 assert((char *)result == buffer);
1888 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1893 if (op_type == OP_SEND) {
1894 const int flags = SvIVx(*++MARK);
1897 char * const sockbuf = SvPVx(*++MARK, mlen);
1898 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1899 flags, (struct sockaddr *)sockbuf, mlen);
1903 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1909 Size_t length = 0; /* This length is in characters. */
1915 /* The SV is bytes, and we've had to upgrade it. */
1916 blen_chars = orig_blen_bytes;
1918 /* The SV really is UTF-8. */
1919 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1920 /* Don't call sv_len_utf8 again because it will call magic
1921 or overloading a second time, and we might get back a
1922 different result. */
1923 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1925 /* It's safe, and it may well be cached. */
1926 blen_chars = sv_len_utf8(bufsv);
1934 length = blen_chars;
1936 #if Size_t_size > IVSIZE
1937 length = (Size_t)SvNVx(*++MARK);
1939 length = (Size_t)SvIVx(*++MARK);
1941 if ((SSize_t)length < 0) {
1943 DIE(aTHX_ "Negative length");
1948 offset = SvIVx(*++MARK);
1950 if (-offset > (IV)blen_chars) {
1952 DIE(aTHX_ "Offset outside string");
1954 offset += blen_chars;
1955 } else if (offset > (IV)blen_chars) {
1957 DIE(aTHX_ "Offset outside string");
1961 if (length > blen_chars - offset)
1962 length = blen_chars - offset;
1964 /* Here we convert length from characters to bytes. */
1965 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1966 /* Either we had to convert the SV, or the SV is magical, or
1967 the SV has overloading, in which case we can't or mustn't
1968 or mustn't call it again. */
1970 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1971 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1973 /* It's a real UTF-8 SV, and it's not going to change under
1974 us. Take advantage of any cache. */
1976 I32 len_I32 = length;
1978 /* Convert the start and end character positions to bytes.
1979 Remember that the second argument to sv_pos_u2b is relative
1981 sv_pos_u2b(bufsv, &start, &len_I32);
1988 buffer = buffer+offset;
1990 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1991 if (IoTYPE(io) == IoTYPE_SOCKET) {
1992 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1998 /* See the note at doio.c:do_print about filesize limits. --jhi */
1999 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2008 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2011 #if Size_t_size > IVSIZE
2031 * in Perl 5.12 and later, the additional parameter is a bitmask:
2034 * 2 = eof() <- ARGV magic
2036 * I'll rely on the compiler's trace flow analysis to decide whether to
2037 * actually assign this out here, or punt it into the only block where it is
2038 * used. Doing it out here is DRY on the condition logic.
2043 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2049 if (PL_op->op_flags & OPf_SPECIAL) {
2050 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2054 gv = PL_last_in_gv; /* eof */
2062 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2063 return tied_method1("EOF", SP, MUTABLE_SV(io), mg, newSVuv(which));
2066 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2067 if (io && !IoIFP(io)) {
2068 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2070 IoFLAGS(io) &= ~IOf_START;
2071 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2073 sv_setpvs(GvSV(gv), "-");
2075 GvSV(gv) = newSVpvs("-");
2076 SvSETMAGIC(GvSV(gv));
2078 else if (!nextargv(gv))
2083 PUSHs(boolSV(do_eof(gv)));
2094 PL_last_in_gv = MUTABLE_GV(POPs);
2101 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2103 return tied_method0("TELL", SP, MUTABLE_SV(io), mg);
2108 SETERRNO(EBADF,RMS_IFI);
2113 #if LSEEKSIZE > IVSIZE
2114 PUSHn( do_tell(gv) );
2116 PUSHi( do_tell(gv) );
2124 const int whence = POPi;
2125 #if LSEEKSIZE > IVSIZE
2126 const Off_t offset = (Off_t)SvNVx(POPs);
2128 const Off_t offset = (Off_t)SvIVx(POPs);
2131 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2132 IO *const io = GvIO(gv);
2135 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2137 #if LSEEKSIZE > IVSIZE
2138 SV *const offset_sv = newSVnv((NV) offset);
2140 SV *const offset_sv = newSViv(offset);
2143 return tied_method2("SEEK", SP, MUTABLE_SV(io), mg, offset_sv,
2148 if (PL_op->op_type == OP_SEEK)
2149 PUSHs(boolSV(do_seek(gv, offset, whence)));
2151 const Off_t sought = do_sysseek(gv, offset, whence);
2153 PUSHs(&PL_sv_undef);
2155 SV* const sv = sought ?
2156 #if LSEEKSIZE > IVSIZE
2161 : newSVpvn(zero_but_true, ZBTLEN);
2172 /* There seems to be no consensus on the length type of truncate()
2173 * and ftruncate(), both off_t and size_t have supporters. In
2174 * general one would think that when using large files, off_t is
2175 * at least as wide as size_t, so using an off_t should be okay. */
2176 /* XXX Configure probe for the length type of *truncate() needed XXX */
2179 #if Off_t_size > IVSIZE
2184 /* Checking for length < 0 is problematic as the type might or
2185 * might not be signed: if it is not, clever compilers will moan. */
2186 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2193 if (PL_op->op_flags & OPf_SPECIAL) {
2194 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2203 TAINT_PROPER("truncate");
2204 if (!(fp = IoIFP(io))) {
2210 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2212 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2219 SV * const sv = POPs;
2222 if (isGV_with_GP(sv)) {
2223 tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */
2224 goto do_ftruncate_gv;
2226 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2227 tmpgv = MUTABLE_GV(SvRV(sv)); /* \*main::FRED for example */
2228 goto do_ftruncate_gv;
2230 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2231 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2232 goto do_ftruncate_io;
2235 name = SvPV_nolen_const(sv);
2236 TAINT_PROPER("truncate");
2238 if (truncate(name, len) < 0)
2242 const int tmpfd = PerlLIO_open(name, O_RDWR);
2247 if (my_chsize(tmpfd, len) < 0)
2249 PerlLIO_close(tmpfd);
2258 SETERRNO(EBADF,RMS_IFI);
2266 SV * const argsv = POPs;
2267 const unsigned int func = POPu;
2268 const int optype = PL_op->op_type;
2269 GV * const gv = MUTABLE_GV(POPs);
2270 IO * const io = gv ? GvIOn(gv) : NULL;
2274 if (!io || !argsv || !IoIFP(io)) {
2276 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2280 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2283 s = SvPV_force(argsv, len);
2284 need = IOCPARM_LEN(func);
2286 s = Sv_Grow(argsv, need + 1);
2287 SvCUR_set(argsv, need);
2290 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2293 retval = SvIV(argsv);
2294 s = INT2PTR(char*,retval); /* ouch */
2297 TAINT_PROPER(PL_op_desc[optype]);
2299 if (optype == OP_IOCTL)
2301 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2303 DIE(aTHX_ "ioctl is not implemented");
2307 DIE(aTHX_ "fcntl is not implemented");
2309 #if defined(OS2) && defined(__EMX__)
2310 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2312 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2316 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2318 if (s[SvCUR(argsv)] != 17)
2319 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2321 s[SvCUR(argsv)] = 0; /* put our null back */
2322 SvSETMAGIC(argsv); /* Assume it has changed */
2331 PUSHp(zero_but_true, ZBTLEN);
2342 const int argtype = POPi;
2343 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
2344 IO *const io = GvIO(gv);
2345 PerlIO *const fp = io ? IoIFP(io) : NULL;
2347 /* XXX Looks to me like io is always NULL at this point */
2349 (void)PerlIO_flush(fp);
2350 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2355 SETERRNO(EBADF,RMS_IFI);
2360 DIE(aTHX_ PL_no_func, "flock()");
2371 const int protocol = POPi;
2372 const int type = POPi;
2373 const int domain = POPi;
2374 GV * const gv = MUTABLE_GV(POPs);
2375 register IO * const io = gv ? GvIOn(gv) : NULL;
2380 if (io && IoIFP(io))
2381 do_close(gv, FALSE);
2382 SETERRNO(EBADF,LIB_INVARG);
2387 do_close(gv, FALSE);
2389 TAINT_PROPER("socket");
2390 fd = PerlSock_socket(domain, type, protocol);
2393 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2394 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2395 IoTYPE(io) = IoTYPE_SOCKET;
2396 if (!IoIFP(io) || !IoOFP(io)) {
2397 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2398 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2399 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2402 #if defined(HAS_FCNTL) && defined(F_SETFD)
2403 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2407 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2416 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2418 const int protocol = POPi;
2419 const int type = POPi;
2420 const int domain = POPi;
2421 GV * const gv2 = MUTABLE_GV(POPs);
2422 GV * const gv1 = MUTABLE_GV(POPs);
2423 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2424 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2428 report_evil_fh(gv1);
2430 report_evil_fh(gv2);
2432 if (io1 && IoIFP(io1))
2433 do_close(gv1, FALSE);
2434 if (io2 && IoIFP(io2))
2435 do_close(gv2, FALSE);
2440 TAINT_PROPER("socketpair");
2441 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2443 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2444 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2445 IoTYPE(io1) = IoTYPE_SOCKET;
2446 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2447 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2448 IoTYPE(io2) = IoTYPE_SOCKET;
2449 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2450 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2451 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2452 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2453 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2454 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2455 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2458 #if defined(HAS_FCNTL) && defined(F_SETFD)
2459 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2460 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2465 DIE(aTHX_ PL_no_sock_func, "socketpair");
2474 SV * const addrsv = POPs;
2475 /* OK, so on what platform does bind modify addr? */
2477 GV * const gv = MUTABLE_GV(POPs);
2478 register IO * const io = GvIOn(gv);
2480 const int op_type = PL_op->op_type;
2482 if (!io || !IoIFP(io))
2485 addr = SvPV_const(addrsv, len);
2486 TAINT_PROPER(PL_op_desc[op_type]);
2487 if ((op_type == OP_BIND
2488 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2489 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2497 SETERRNO(EBADF,SS_IVCHAN);
2504 const int backlog = POPi;
2505 GV * const gv = MUTABLE_GV(POPs);
2506 register IO * const io = gv ? GvIOn(gv) : NULL;
2508 if (!io || !IoIFP(io))
2511 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2518 SETERRNO(EBADF,SS_IVCHAN);
2527 char namebuf[MAXPATHLEN];
2528 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2529 Sock_size_t len = sizeof (struct sockaddr_in);
2531 Sock_size_t len = sizeof namebuf;
2533 GV * const ggv = MUTABLE_GV(POPs);
2534 GV * const ngv = MUTABLE_GV(POPs);
2543 if (!gstio || !IoIFP(gstio))
2547 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2550 /* Some platforms indicate zero length when an AF_UNIX client is
2551 * not bound. Simulate a non-zero-length sockaddr structure in
2553 namebuf[0] = 0; /* sun_len */
2554 namebuf[1] = AF_UNIX; /* sun_family */
2562 do_close(ngv, FALSE);
2563 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2564 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2565 IoTYPE(nstio) = IoTYPE_SOCKET;
2566 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2567 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2568 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2569 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2572 #if defined(HAS_FCNTL) && defined(F_SETFD)
2573 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2577 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2578 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2580 #ifdef __SCO_VERSION__
2581 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2584 PUSHp(namebuf, len);
2588 report_evil_fh(ggv);
2589 SETERRNO(EBADF,SS_IVCHAN);
2599 const int how = POPi;
2600 GV * const gv = MUTABLE_GV(POPs);
2601 register IO * const io = GvIOn(gv);
2603 if (!io || !IoIFP(io))
2606 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2611 SETERRNO(EBADF,SS_IVCHAN);
2618 const int optype = PL_op->op_type;
2619 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2620 const unsigned int optname = (unsigned int) POPi;
2621 const unsigned int lvl = (unsigned int) POPi;
2622 GV * const gv = MUTABLE_GV(POPs);
2623 register IO * const io = GvIOn(gv);
2627 if (!io || !IoIFP(io))
2630 fd = PerlIO_fileno(IoIFP(io));
2634 (void)SvPOK_only(sv);
2638 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2645 #if defined(__SYMBIAN32__)
2646 # define SETSOCKOPT_OPTION_VALUE_T void *
2648 # define SETSOCKOPT_OPTION_VALUE_T const char *
2650 /* XXX TODO: We need to have a proper type (a Configure probe,
2651 * etc.) for what the C headers think of the third argument of
2652 * setsockopt(), the option_value read-only buffer: is it
2653 * a "char *", or a "void *", const or not. Some compilers
2654 * don't take kindly to e.g. assuming that "char *" implicitly
2655 * promotes to a "void *", or to explicitly promoting/demoting
2656 * consts to non/vice versa. The "const void *" is the SUS
2657 * definition, but that does not fly everywhere for the above
2659 SETSOCKOPT_OPTION_VALUE_T buf;
2663 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2667 aint = (int)SvIV(sv);
2668 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2671 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2681 SETERRNO(EBADF,SS_IVCHAN);
2690 const int optype = PL_op->op_type;
2691 GV * const gv = MUTABLE_GV(POPs);
2692 register IO * const io = GvIOn(gv);
2697 if (!io || !IoIFP(io))
2700 sv = sv_2mortal(newSV(257));
2701 (void)SvPOK_only(sv);
2705 fd = PerlIO_fileno(IoIFP(io));
2707 case OP_GETSOCKNAME:
2708 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2711 case OP_GETPEERNAME:
2712 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2714 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2716 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";
2717 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2718 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2719 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2720 sizeof(u_short) + sizeof(struct in_addr))) {
2727 #ifdef BOGUS_GETNAME_RETURN
2728 /* Interactive Unix, getpeername() and getsockname()
2729 does not return valid namelen */
2730 if (len == BOGUS_GETNAME_RETURN)
2731 len = sizeof(struct sockaddr);
2740 SETERRNO(EBADF,SS_IVCHAN);
2758 if (PL_op->op_flags & OPf_REF) {
2760 if (PL_op->op_type == OP_LSTAT) {
2761 if (gv != PL_defgv) {
2762 do_fstat_warning_check:
2763 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2764 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2765 } else if (PL_laststype != OP_LSTAT)
2766 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2770 if (gv != PL_defgv) {
2771 PL_laststype = OP_STAT;
2773 sv_setpvs(PL_statname, "");
2780 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2781 } else if (IoDIRP(io)) {
2783 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2785 PL_laststatval = -1;
2791 if (PL_laststatval < 0) {
2797 SV* const sv = POPs;
2798 if (isGV_with_GP(sv)) {
2799 gv = MUTABLE_GV(sv);
2801 } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2802 gv = MUTABLE_GV(SvRV(sv));
2803 if (PL_op->op_type == OP_LSTAT)
2804 goto do_fstat_warning_check;
2806 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2807 io = MUTABLE_IO(SvRV(sv));
2808 if (PL_op->op_type == OP_LSTAT)
2809 goto do_fstat_warning_check;
2810 goto do_fstat_have_io;
2813 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2815 PL_laststype = PL_op->op_type;
2816 if (PL_op->op_type == OP_LSTAT)
2817 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2819 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2820 if (PL_laststatval < 0) {
2821 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2822 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2828 if (gimme != G_ARRAY) {
2829 if (gimme != G_VOID)
2830 XPUSHs(boolSV(max));
2836 mPUSHi(PL_statcache.st_dev);
2837 mPUSHi(PL_statcache.st_ino);
2838 mPUSHu(PL_statcache.st_mode);
2839 mPUSHu(PL_statcache.st_nlink);
2840 #if Uid_t_size > IVSIZE
2841 mPUSHn(PL_statcache.st_uid);
2843 # if Uid_t_sign <= 0
2844 mPUSHi(PL_statcache.st_uid);
2846 mPUSHu(PL_statcache.st_uid);
2849 #if Gid_t_size > IVSIZE
2850 mPUSHn(PL_statcache.st_gid);
2852 # if Gid_t_sign <= 0
2853 mPUSHi(PL_statcache.st_gid);
2855 mPUSHu(PL_statcache.st_gid);
2858 #ifdef USE_STAT_RDEV
2859 mPUSHi(PL_statcache.st_rdev);
2861 PUSHs(newSVpvs_flags("", SVs_TEMP));
2863 #if Off_t_size > IVSIZE
2864 mPUSHn(PL_statcache.st_size);
2866 mPUSHi(PL_statcache.st_size);
2869 mPUSHn(PL_statcache.st_atime);
2870 mPUSHn(PL_statcache.st_mtime);
2871 mPUSHn(PL_statcache.st_ctime);
2873 mPUSHi(PL_statcache.st_atime);
2874 mPUSHi(PL_statcache.st_mtime);
2875 mPUSHi(PL_statcache.st_ctime);
2877 #ifdef USE_STAT_BLOCKS
2878 mPUSHu(PL_statcache.st_blksize);
2879 mPUSHu(PL_statcache.st_blocks);
2881 PUSHs(newSVpvs_flags("", SVs_TEMP));
2882 PUSHs(newSVpvs_flags("", SVs_TEMP));
2888 #define tryAMAGICftest_MG(chr) STMT_START { \
2889 if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
2890 && S_try_amagic_ftest(aTHX_ chr)) \
2895 S_try_amagic_ftest(pTHX_ char chr) {
2898 SV* const arg = TOPs;
2903 if ((PL_op->op_flags & OPf_KIDS)
2906 const char tmpchr = chr;
2908 SV * const tmpsv = amagic_call(arg,
2909 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2910 ftest_amg, AMGf_unary);
2917 next = PL_op->op_next;
2918 if (next->op_type >= OP_FTRREAD &&
2919 next->op_type <= OP_FTBINARY &&
2920 next->op_private & OPpFT_STACKED
2923 /* leave the object alone */
2935 /* This macro is used by the stacked filetest operators :
2936 * if the previous filetest failed, short-circuit and pass its value.
2937 * Else, discard it from the stack and continue. --rgs
2939 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2940 if (!SvTRUE(TOPs)) { RETURN; } \
2941 else { (void)POPs; PUTBACK; } \
2948 /* Not const, because things tweak this below. Not bool, because there's
2949 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2950 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2951 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2952 /* Giving some sort of initial value silences compilers. */
2954 int access_mode = R_OK;
2956 int access_mode = 0;
2959 /* access_mode is never used, but leaving use_access in makes the
2960 conditional compiling below much clearer. */
2963 Mode_t stat_mode = S_IRUSR;
2965 bool effective = FALSE;
2969 switch (PL_op->op_type) {
2970 case OP_FTRREAD: opchar = 'R'; break;
2971 case OP_FTRWRITE: opchar = 'W'; break;
2972 case OP_FTREXEC: opchar = 'X'; break;
2973 case OP_FTEREAD: opchar = 'r'; break;
2974 case OP_FTEWRITE: opchar = 'w'; break;
2975 case OP_FTEEXEC: opchar = 'x'; break;
2977 tryAMAGICftest_MG(opchar);
2979 STACKED_FTEST_CHECK;
2981 switch (PL_op->op_type) {
2983 #if !(defined(HAS_ACCESS) && defined(R_OK))
2989 #if defined(HAS_ACCESS) && defined(W_OK)
2994 stat_mode = S_IWUSR;
2998 #if defined(HAS_ACCESS) && defined(X_OK)
3003 stat_mode = S_IXUSR;
3007 #ifdef PERL_EFF_ACCESS
3010 stat_mode = S_IWUSR;
3014 #ifndef PERL_EFF_ACCESS
3021 #ifdef PERL_EFF_ACCESS
3026 stat_mode = S_IXUSR;
3032 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3033 const char *name = POPpx;
3035 # ifdef PERL_EFF_ACCESS
3036 result = PERL_EFF_ACCESS(name, access_mode);
3038 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3044 result = access(name, access_mode);
3046 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3057 result = my_stat_flags(0);
3061 if (cando(stat_mode, effective, &PL_statcache))
3070 const int op_type = PL_op->op_type;
3075 case OP_FTIS: opchar = 'e'; break;
3076 case OP_FTSIZE: opchar = 's'; break;
3077 case OP_FTMTIME: opchar = 'M'; break;
3078 case OP_FTCTIME: opchar = 'C'; break;
3079 case OP_FTATIME: opchar = 'A'; break;
3081 tryAMAGICftest_MG(opchar);
3083 STACKED_FTEST_CHECK;
3085 result = my_stat_flags(0);
3089 if (op_type == OP_FTIS)
3092 /* You can't dTARGET inside OP_FTIS, because you'll get
3093 "panic: pad_sv po" - the op is not flagged to have a target. */
3097 #if Off_t_size > IVSIZE
3098 PUSHn(PL_statcache.st_size);
3100 PUSHi(PL_statcache.st_size);
3104 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3107 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3110 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3124 switch (PL_op->op_type) {
3125 case OP_FTROWNED: opchar = 'O'; break;
3126 case OP_FTEOWNED: opchar = 'o'; break;
3127 case OP_FTZERO: opchar = 'z'; break;
3128 case OP_FTSOCK: opchar = 'S'; break;
3129 case OP_FTCHR: opchar = 'c'; break;
3130 case OP_FTBLK: opchar = 'b'; break;
3131 case OP_FTFILE: opchar = 'f'; break;
3132 case OP_FTDIR: opchar = 'd'; break;
3133 case OP_FTPIPE: opchar = 'p'; break;
3134 case OP_FTSUID: opchar = 'u'; break;
3135 case OP_FTSGID: opchar = 'g'; break;
3136 case OP_FTSVTX: opchar = 'k'; break;
3138 tryAMAGICftest_MG(opchar);
3140 STACKED_FTEST_CHECK;
3142 /* I believe that all these three are likely to be defined on most every
3143 system these days. */
3145 if(PL_op->op_type == OP_FTSUID) {
3146 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3152 if(PL_op->op_type == OP_FTSGID) {
3153 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3159 if(PL_op->op_type == OP_FTSVTX) {
3160 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3166 result = my_stat_flags(0);
3170 switch (PL_op->op_type) {
3172 if (PL_statcache.st_uid == PL_uid)
3176 if (PL_statcache.st_uid == PL_euid)
3180 if (PL_statcache.st_size == 0)
3184 if (S_ISSOCK(PL_statcache.st_mode))
3188 if (S_ISCHR(PL_statcache.st_mode))
3192 if (S_ISBLK(PL_statcache.st_mode))
3196 if (S_ISREG(PL_statcache.st_mode))
3200 if (S_ISDIR(PL_statcache.st_mode))
3204 if (S_ISFIFO(PL_statcache.st_mode))
3209 if (PL_statcache.st_mode & S_ISUID)
3215 if (PL_statcache.st_mode & S_ISGID)
3221 if (PL_statcache.st_mode & S_ISVTX)
3235 tryAMAGICftest_MG('l');
3236 result = my_lstat_flags(0);
3241 if (S_ISLNK(PL_statcache.st_mode))
3256 tryAMAGICftest_MG('t');
3258 STACKED_FTEST_CHECK;
3260 if (PL_op->op_flags & OPf_REF)
3262 else if (isGV_with_GP(TOPs))
3263 gv = MUTABLE_GV(POPs);
3264 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3265 gv = MUTABLE_GV(SvRV(POPs));
3268 name = SvPV_nomg(tmpsv, namelen);
3269 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3272 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3273 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3274 else if (tmpsv && SvOK(tmpsv)) {
3282 if (PerlLIO_isatty(fd))
3287 #if defined(atarist) /* this will work with atariST. Configure will
3288 make guesses for other systems. */
3289 # define FILE_base(f) ((f)->_base)
3290 # define FILE_ptr(f) ((f)->_ptr)
3291 # define FILE_cnt(f) ((f)->_cnt)
3292 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3303 register STDCHAR *s;
3309 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3311 STACKED_FTEST_CHECK;
3313 if (PL_op->op_flags & OPf_REF)
3315 else if (isGV_with_GP(TOPs))
3316 gv = MUTABLE_GV(POPs);
3317 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3318 gv = MUTABLE_GV(SvRV(POPs));
3324 if (gv == PL_defgv) {
3326 io = GvIO(PL_statgv);
3329 goto really_filename;
3334 PL_laststatval = -1;
3335 sv_setpvs(PL_statname, "");
3336 io = GvIO(PL_statgv);
3338 if (io && IoIFP(io)) {
3339 if (! PerlIO_has_base(IoIFP(io)))
3340 DIE(aTHX_ "-T and -B not implemented on filehandles");
3341 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3342 if (PL_laststatval < 0)
3344 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3345 if (PL_op->op_type == OP_FTTEXT)
3350 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3351 i = PerlIO_getc(IoIFP(io));
3353 (void)PerlIO_ungetc(IoIFP(io),i);
3355 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3357 len = PerlIO_get_bufsiz(IoIFP(io));
3358 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3359 /* sfio can have large buffers - limit to 512 */
3364 report_evil_fh(cGVOP_gv);
3365 SETERRNO(EBADF,RMS_IFI);
3373 PL_laststype = OP_STAT;
3374 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3375 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3376 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3378 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3381 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3382 if (PL_laststatval < 0) {
3383 (void)PerlIO_close(fp);
3386 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3387 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3388 (void)PerlIO_close(fp);
3390 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3391 RETPUSHNO; /* special case NFS directories */
3392 RETPUSHYES; /* null file is anything */
3397 /* now scan s to look for textiness */
3398 /* XXX ASCII dependent code */
3400 #if defined(DOSISH) || defined(USEMYBINMODE)
3401 /* ignore trailing ^Z on short files */
3402 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3406 for (i = 0; i < len; i++, s++) {
3407 if (!*s) { /* null never allowed in text */
3412 else if (!(isPRINT(*s) || isSPACE(*s)))
3415 else if (*s & 128) {
3417 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3420 /* utf8 characters don't count as odd */
3421 if (UTF8_IS_START(*s)) {
3422 int ulen = UTF8SKIP(s);
3423 if (ulen < len - i) {
3425 for (j = 1; j < ulen; j++) {
3426 if (!UTF8_IS_CONTINUATION(s[j]))
3429 --ulen; /* loop does extra increment */
3439 *s != '\n' && *s != '\r' && *s != '\b' &&
3440 *s != '\t' && *s != '\f' && *s != 27)
3445 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3456 const char *tmps = NULL;
3460 SV * const sv = POPs;
3461 if (PL_op->op_flags & OPf_SPECIAL) {
3462 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3464 else if (isGV_with_GP(sv)) {
3465 gv = MUTABLE_GV(sv);
3467 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
3468 gv = MUTABLE_GV(SvRV(sv));
3471 tmps = SvPV_nolen_const(sv);
3475 if( !gv && (!tmps || !*tmps) ) {
3476 HV * const table = GvHVn(PL_envgv);
3479 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3480 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3482 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3487 deprecate("chdir('') or chdir(undef) as chdir()");
3488 tmps = SvPV_nolen_const(*svp);
3492 TAINT_PROPER("chdir");
3497 TAINT_PROPER("chdir");
3500 IO* const io = GvIO(gv);
3503 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3504 } else if (IoIFP(io)) {
3505 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3509 SETERRNO(EBADF, RMS_IFI);
3515 SETERRNO(EBADF,RMS_IFI);
3519 DIE(aTHX_ PL_no_func, "fchdir");
3523 PUSHi( PerlDir_chdir(tmps) >= 0 );
3525 /* Clear the DEFAULT element of ENV so we'll get the new value
3527 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3534 dVAR; dSP; dMARK; dTARGET;
3535 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3546 char * const tmps = POPpx;
3547 TAINT_PROPER("chroot");
3548 PUSHi( chroot(tmps) >= 0 );
3551 DIE(aTHX_ PL_no_func, "chroot");
3559 const char * const tmps2 = POPpconstx;
3560 const char * const tmps = SvPV_nolen_const(TOPs);
3561 TAINT_PROPER("rename");
3563 anum = PerlLIO_rename(tmps, tmps2);
3565 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3566 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3569 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3570 (void)UNLINK(tmps2);
3571 if (!(anum = link(tmps, tmps2)))
3572 anum = UNLINK(tmps);
3580 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3584 const int op_type = PL_op->op_type;
3588 if (op_type == OP_LINK)
3589 DIE(aTHX_ PL_no_func, "link");
3591 # ifndef HAS_SYMLINK
3592 if (op_type == OP_SYMLINK)
3593 DIE(aTHX_ PL_no_func, "symlink");
3597 const char * const tmps2 = POPpconstx;
3598 const char * const tmps = SvPV_nolen_const(TOPs);
3599 TAINT_PROPER(PL_op_desc[op_type]);
3601 # if defined(HAS_LINK)
3602 # if defined(HAS_SYMLINK)
3603 /* Both present - need to choose which. */
3604 (op_type == OP_LINK) ?
3605 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3607 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3608 PerlLIO_link(tmps, tmps2);
3611 # if defined(HAS_SYMLINK)
3612 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3613 symlink(tmps, tmps2);
3618 SETi( result >= 0 );
3625 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3636 char buf[MAXPATHLEN];
3639 #ifndef INCOMPLETE_TAINTS
3643 len = readlink(tmps, buf, sizeof(buf) - 1);
3650 RETSETUNDEF; /* just pretend it's a normal file */
3654 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3656 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3658 char * const save_filename = filename;
3663 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3665 PERL_ARGS_ASSERT_DOONELINER;
3667 Newx(cmdline, size, char);
3668 my_strlcpy(cmdline, cmd, size);
3669 my_strlcat(cmdline, " ", size);
3670 for (s = cmdline + strlen(cmdline); *filename; ) {
3674 if (s - cmdline < size)
3675 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3676 myfp = PerlProc_popen(cmdline, "r");
3680 SV * const tmpsv = sv_newmortal();
3681 /* Need to save/restore 'PL_rs' ?? */
3682 s = sv_gets(tmpsv, myfp, 0);
3683 (void)PerlProc_pclose(myfp);
3687 #ifdef HAS_SYS_ERRLIST
3692 /* you don't see this */
3693 const char * const errmsg =
3694 #ifdef HAS_SYS_ERRLIST
3702 if (instr(s, errmsg)) {
3709 #define EACCES EPERM
3711 if (instr(s, "cannot make"))
3712 SETERRNO(EEXIST,RMS_FEX);
3713 else if (instr(s, "existing file"))
3714 SETERRNO(EEXIST,RMS_FEX);
3715 else if (instr(s, "ile exists"))
3716 SETERRNO(EEXIST,RMS_FEX);
3717 else if (instr(s, "non-exist"))
3718 SETERRNO(ENOENT,RMS_FNF);
3719 else if (instr(s, "does not exist"))
3720 SETERRNO(ENOENT,RMS_FNF);
3721 else if (instr(s, "not empty"))
3722 SETERRNO(EBUSY,SS_DEVOFFLINE);
3723 else if (instr(s, "cannot access"))
3724 SETERRNO(EACCES,RMS_PRV);
3726 SETERRNO(EPERM,RMS_PRV);
3729 else { /* some mkdirs return no failure indication */
3730 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3731 if (PL_op->op_type == OP_RMDIR)
3736 SETERRNO(EACCES,RMS_PRV); /* a guess */
3745 /* This macro removes trailing slashes from a directory name.
3746 * Different operating and file systems take differently to
3747 * trailing slashes. According to POSIX 1003.1 1996 Edition
3748 * any number of trailing slashes should be allowed.
3749 * Thusly we snip them away so that even non-conforming
3750 * systems are happy.
3751 * We should probably do this "filtering" for all
3752 * the functions that expect (potentially) directory names:
3753 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3754 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3756 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3757 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3760 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3761 (tmps) = savepvn((tmps), (len)); \
3771 const int mode = (MAXARG > 1) ? POPi : 0777;
3773 TRIMSLASHES(tmps,len,copy);
3775 TAINT_PROPER("mkdir");
3777 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3781 SETi( dooneliner("mkdir", tmps) );
3782 oldumask = PerlLIO_umask(0);
3783 PerlLIO_umask(oldumask);
3784 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3799 TRIMSLASHES(tmps,len,copy);
3800 TAINT_PROPER("rmdir");
3802 SETi( PerlDir_rmdir(tmps) >= 0 );
3804 SETi( dooneliner("rmdir", tmps) );
3811 /* Directory calls. */
3815 #if defined(Direntry_t) && defined(HAS_READDIR)
3817 const char * const dirname = POPpconstx;
3818 GV * const gv = MUTABLE_GV(POPs);
3819 register IO * const io = GvIOn(gv);
3824 if ((IoIFP(io) || IoOFP(io)))
3825 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3826 "Opening filehandle %s also as a directory",
3829 PerlDir_close(IoDIRP(io));
3830 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3836 SETERRNO(EBADF,RMS_DIR);
3839 DIE(aTHX_ PL_no_dir_func, "opendir");
3845 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3846 DIE(aTHX_ PL_no_dir_func, "readdir");
3848 #if !defined(I_DIRENT) && !defined(VMS)
3849 Direntry_t *readdir (DIR *);
3855 const I32 gimme = GIMME;
3856 GV * const gv = MUTABLE_GV(POPs);
3857 register const Direntry_t *dp;
3858 register IO * const io = GvIOn(gv);
3860 if (!io || !IoDIRP(io)) {
3861 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3862 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3867 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3871 sv = newSVpvn(dp->d_name, dp->d_namlen);
3873 sv = newSVpv(dp->d_name, 0);
3875 #ifndef INCOMPLETE_TAINTS
3876 if (!(IoFLAGS(io) & IOf_UNTAINT))
3880 } while (gimme == G_ARRAY);
3882 if (!dp && gimme != G_ARRAY)
3889 SETERRNO(EBADF,RMS_ISI);
3890 if (GIMME == G_ARRAY)
3899 #if defined(HAS_TELLDIR) || defined(telldir)
3901 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3902 /* XXX netbsd still seemed to.
3903 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3904 --JHI 1999-Feb-02 */
3905 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3906 long telldir (DIR *);
3908 GV * const gv = MUTABLE_GV(POPs);
3909 register IO * const io = GvIOn(gv);
3911 if (!io || !IoDIRP(io)) {
3912 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3913 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3917 PUSHi( PerlDir_tell(IoDIRP(io)) );
3921 SETERRNO(EBADF,RMS_ISI);
3924 DIE(aTHX_ PL_no_dir_func, "telldir");
3930 #if defined(HAS_SEEKDIR) || defined(seekdir)
3932 const long along = POPl;
3933 GV * const gv = MUTABLE_GV(POPs);
3934 register IO * const io = GvIOn(gv);
3936 if (!io || !IoDIRP(io)) {
3937 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3938 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3941 (void)PerlDir_seek(IoDIRP(io), along);
3946 SETERRNO(EBADF,RMS_ISI);
3949 DIE(aTHX_ PL_no_dir_func, "seekdir");
3955 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3957 GV * const gv = MUTABLE_GV(POPs);
3958 register IO * const io = GvIOn(gv);
3960 if (!io || !IoDIRP(io)) {
3961 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3962 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3965 (void)PerlDir_rewind(IoDIRP(io));
3969 SETERRNO(EBADF,RMS_ISI);
3972 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3978 #if defined(Direntry_t) && defined(HAS_READDIR)
3980 GV * const gv = MUTABLE_GV(POPs);
3981 register IO * const io = GvIOn(gv);
3983 if (!io || !IoDIRP(io)) {
3984 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3985 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3988 #ifdef VOID_CLOSEDIR
3989 PerlDir_close(IoDIRP(io));
3991 if (PerlDir_close(IoDIRP(io)) < 0) {
3992 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4001 SETERRNO(EBADF,RMS_IFI);
4004 DIE(aTHX_ PL_no_dir_func, "closedir");
4008 /* Process control. */
4017 PERL_FLUSHALL_FOR_CHILD;
4018 childpid = PerlProc_fork();
4022 #ifdef THREADS_HAVE_PIDS
4023 PL_ppid = (IV)getppid();
4025 #ifdef PERL_USES_PL_PIDSTATUS
4026 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4032 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4037 PERL_FLUSHALL_FOR_CHILD;
4038 childpid = PerlProc_fork();
4044 DIE(aTHX_ PL_no_func, "fork");
4051 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4056 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4057 childpid = wait4pid(-1, &argflags, 0);
4059 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4064 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4065 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4066 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4068 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4073 DIE(aTHX_ PL_no_func, "wait");
4079 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4081 const int optype = POPi;
4082 const Pid_t pid = TOPi;
4086 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4087 result = wait4pid(pid, &argflags, optype);
4089 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4094 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4095 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4096 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4098 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4103 DIE(aTHX_ PL_no_func, "waitpid");
4109 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4110 #if defined(__LIBCATAMOUNT__)
4111 PL_statusvalue = -1;
4120 while (++MARK <= SP) {
4121 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4126 TAINT_PROPER("system");
4128 PERL_FLUSHALL_FOR_CHILD;
4129 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4135 if (PerlProc_pipe(pp) >= 0)
4137 while ((childpid = PerlProc_fork()) == -1) {
4138 if (errno != EAGAIN) {
4143 PerlLIO_close(pp[0]);
4144 PerlLIO_close(pp[1]);
4151 Sigsave_t ihand,qhand; /* place to save signals during system() */
4155 PerlLIO_close(pp[1]);
4157 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4158 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4161 result = wait4pid(childpid, &status, 0);
4162 } while (result == -1 && errno == EINTR);
4164 (void)rsignal_restore(SIGINT, &ihand);
4165 (void)rsignal_restore(SIGQUIT, &qhand);
4167 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4168 do_execfree(); /* free any memory child malloced on fork */
4175 while (n < sizeof(int)) {
4176 n1 = PerlLIO_read(pp[0],
4177 (void*)(((char*)&errkid)+n),
4183 PerlLIO_close(pp[0]);
4184 if (n) { /* Error */
4185 if (n != sizeof(int))
4186 DIE(aTHX_ "panic: kid popen errno read");
4187 errno = errkid; /* Propagate errno from kid */
4188 STATUS_NATIVE_CHILD_SET(-1);
4191 XPUSHi(STATUS_CURRENT);
4195 PerlLIO_close(pp[0]);
4196 #if defined(HAS_FCNTL) && defined(F_SETFD)
4197 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4200 if (PL_op->op_flags & OPf_STACKED) {
4201 SV * const really = *++MARK;
4202 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4204 else if (SP - MARK != 1)
4205 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4207 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4211 #else /* ! FORK or VMS or OS/2 */
4214 if (PL_op->op_flags & OPf_STACKED) {
4215 SV * const really = *++MARK;
4216 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4217 value = (I32)do_aspawn(really, MARK, SP);
4219 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4222 else if (SP - MARK != 1) {
4223 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4224 value = (I32)do_aspawn(NULL, MARK, SP);
4226 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4230 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4232 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4234 STATUS_NATIVE_CHILD_SET(value);
4237 XPUSHi(result ? value : STATUS_CURRENT);
4238 #endif /* !FORK or VMS or OS/2 */
4245 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4250 while (++MARK <= SP) {
4251 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4256 TAINT_PROPER("exec");
4258 PERL_FLUSHALL_FOR_CHILD;
4259 if (PL_op->op_flags & OPf_STACKED) {
4260 SV * const really = *++MARK;
4261 value = (I32)do_aexec(really, MARK, SP);
4263 else if (SP - MARK != 1)
4265 value = (I32)vms_do_aexec(NULL, MARK, SP);
4269 (void ) do_aspawn(NULL, MARK, SP);
4273 value = (I32)do_aexec(NULL, MARK, SP);
4278 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4281 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4284 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4298 # ifdef THREADS_HAVE_PIDS
4299 if (PL_ppid != 1 && getppid() == 1)
4300 /* maybe the parent process has died. Refresh ppid cache */
4304 XPUSHi( getppid() );
4308 DIE(aTHX_ PL_no_func, "getppid");
4317 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4320 pgrp = (I32)BSD_GETPGRP(pid);
4322 if (pid != 0 && pid != PerlProc_getpid())
4323 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4329 DIE(aTHX_ PL_no_func, "getpgrp()");
4349 TAINT_PROPER("setpgrp");
4351 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4353 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4354 || (pid != 0 && pid != PerlProc_getpid()))
4356 DIE(aTHX_ "setpgrp can't take arguments");
4358 SETi( setpgrp() >= 0 );
4359 #endif /* USE_BSDPGRP */
4362 DIE(aTHX_ PL_no_func, "setpgrp()");
4366 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4367 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4369 # define PRIORITY_WHICH_T(which) which
4374 #ifdef HAS_GETPRIORITY
4376 const int who = POPi;
4377 const int which = TOPi;
4378 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4381 DIE(aTHX_ PL_no_func, "getpriority()");
4387 #ifdef HAS_SETPRIORITY
4389 const int niceval = POPi;
4390 const int who = POPi;
4391 const int which = TOPi;
4392 TAINT_PROPER("setpriority");
4393 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4396 DIE(aTHX_ PL_no_func, "setpriority()");
4400 #undef PRIORITY_WHICH_T
4408 XPUSHn( time(NULL) );
4410 XPUSHi( time(NULL) );
4422 (void)PerlProc_times(&PL_timesbuf);
4424 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4425 /* struct tms, though same data */
4429 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4430 if (GIMME == G_ARRAY) {
4431 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4432 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4433 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4441 if (GIMME == G_ARRAY) {
4448 DIE(aTHX_ "times not implemented");
4450 #endif /* HAS_TIMES */
4453 /* The 32 bit int year limits the times we can represent to these
4454 boundaries with a few days wiggle room to account for time zone
4457 /* Sat Jan 3 00:00:00 -2147481748 */
4458 #define TIME_LOWER_BOUND -67768100567755200.0
4459 /* Sun Dec 29 12:00:00 2147483647 */
4460 #define TIME_UPPER_BOUND 67767976233316800.0
4469 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4470 static const char * const dayname[] =
4471 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4472 static const char * const monname[] =
4473 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4474 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4479 when = (Time64_T)now;
4482 NV input = Perl_floor(POPn);
4483 when = (Time64_T)input;
4484 if (when != input) {
4485 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4486 "%s(%.0" NVff ") too large", opname, input);
4490 if ( TIME_LOWER_BOUND > when ) {
4491 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4492 "%s(%.0" NVff ") too small", opname, when);
4495 else if( when > TIME_UPPER_BOUND ) {
4496 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4497 "%s(%.0" NVff ") too large", opname, when);
4501 if (PL_op->op_type == OP_LOCALTIME)
4502 err = S_localtime64_r(&when, &tmbuf);
4504 err = S_gmtime64_r(&when, &tmbuf);
4508 /* XXX %lld broken for quads */
4509 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4510 "%s(%.0" NVff ") failed", opname, when);
4513 if (GIMME != G_ARRAY) { /* scalar context */
4515 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4516 double year = (double)tmbuf.tm_year + 1900;
4523 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4524 dayname[tmbuf.tm_wday],
4525 monname[tmbuf.tm_mon],
4533 else { /* list context */
4539 mPUSHi(tmbuf.tm_sec);
4540 mPUSHi(tmbuf.tm_min);
4541 mPUSHi(tmbuf.tm_hour);
4542 mPUSHi(tmbuf.tm_mday);
4543 mPUSHi(tmbuf.tm_mon);
4544 mPUSHn(tmbuf.tm_year);
4545 mPUSHi(tmbuf.tm_wday);
4546 mPUSHi(tmbuf.tm_yday);
4547 mPUSHi(tmbuf.tm_isdst);
4558 anum = alarm((unsigned int)anum);
4564 DIE(aTHX_ PL_no_func, "alarm");
4575 (void)time(&lasttime);
4580 PerlProc_sleep((unsigned int)duration);
4583 XPUSHi(when - lasttime);
4587 /* Shared memory. */
4588 /* Merged with some message passing. */
4592 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4593 dVAR; dSP; dMARK; dTARGET;
4594 const int op_type = PL_op->op_type;
4599 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4602 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4605 value = (I32)(do_semop(MARK, SP) >= 0);
4608 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4616 return Perl_pp_semget(aTHX);
4624 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4625 dVAR; dSP; dMARK; dTARGET;
4626 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4633 DIE(aTHX_ "System V IPC is not implemented on this machine");
4639 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4640 dVAR; dSP; dMARK; dTARGET;
4641 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4649 PUSHp(zero_but_true, ZBTLEN);
4653 return Perl_pp_semget(aTHX);
4657 /* I can't const this further without getting warnings about the types of
4658 various arrays passed in from structures. */
4660 S_space_join_names_mortal(pTHX_ char *const *array)
4664 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4666 if (array && *array) {
4667 target = newSVpvs_flags("", SVs_TEMP);
4669 sv_catpv(target, *array);
4672 sv_catpvs(target, " ");
4675 target = sv_mortalcopy(&PL_sv_no);
4680 /* Get system info. */
4684 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4686 I32 which = PL_op->op_type;
4687 register char **elem;
4689 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4690 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4691 struct hostent *gethostbyname(Netdb_name_t);
4692 struct hostent *gethostent(void);
4694 struct hostent *hent = NULL;
4698 if (which == OP_GHBYNAME) {
4699 #ifdef HAS_GETHOSTBYNAME
4700 const char* const name = POPpbytex;
4701 hent = PerlSock_gethostbyname(name);
4703 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4706 else if (which == OP_GHBYADDR) {
4707 #ifdef HAS_GETHOSTBYADDR
4708 const int addrtype = POPi;
4709 SV * const addrsv = POPs;
4711 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4713 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4715 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4719 #ifdef HAS_GETHOSTENT
4720 hent = PerlSock_gethostent();
4722 DIE(aTHX_ PL_no_sock_func, "gethostent");
4725 #ifdef HOST_NOT_FOUND
4727 #ifdef USE_REENTRANT_API
4728 # ifdef USE_GETHOSTENT_ERRNO
4729 h_errno = PL_reentrant_buffer->_gethostent_errno;
4732 STATUS_UNIX_SET(h_errno);
4736 if (GIMME != G_ARRAY) {
4737 PUSHs(sv = sv_newmortal());
4739 if (which == OP_GHBYNAME) {
4741 sv_setpvn(sv, hent->h_addr, hent->h_length);
4744 sv_setpv(sv, (char*)hent->h_name);
4750 mPUSHs(newSVpv((char*)hent->h_name, 0));
4751 PUSHs(space_join_names_mortal(hent->h_aliases));
4752 mPUSHi(hent->h_addrtype);
4753 len = hent->h_length;
4756 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4757 mXPUSHp(*elem, len);
4761 mPUSHp(hent->h_addr, len);
4763 PUSHs(sv_mortalcopy(&PL_sv_no));
4768 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4774 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4776 I32 which = PL_op->op_type;
4778 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4779 struct netent *getnetbyaddr(Netdb_net_t, int);
4780 struct netent *getnetbyname(Netdb_name_t);
4781 struct netent *getnetent(void);
4783 struct netent *nent;
4785 if (which == OP_GNBYNAME){
4786 #ifdef HAS_GETNETBYNAME
4787 const char * const name = POPpbytex;
4788 nent = PerlSock_getnetbyname(name);
4790 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4793 else if (which == OP_GNBYADDR) {
4794 #ifdef HAS_GETNETBYADDR
4795 const int addrtype = POPi;
4796 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4797 nent = PerlSock_getnetbyaddr(addr, addrtype);
4799 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4803 #ifdef HAS_GETNETENT
4804 nent = PerlSock_getnetent();
4806 DIE(aTHX_ PL_no_sock_func, "getnetent");
4809 #ifdef HOST_NOT_FOUND
4811 #ifdef USE_REENTRANT_API
4812 # ifdef USE_GETNETENT_ERRNO
4813 h_errno = PL_reentrant_buffer->_getnetent_errno;
4816 STATUS_UNIX_SET(h_errno);
4821 if (GIMME != G_ARRAY) {
4822 PUSHs(sv = sv_newmortal());
4824 if (which == OP_GNBYNAME)
4825 sv_setiv(sv, (IV)nent->n_net);
4827 sv_setpv(sv, nent->n_name);
4833 mPUSHs(newSVpv(nent->n_name, 0));
4834 PUSHs(space_join_names_mortal(nent->n_aliases));
4835 mPUSHi(nent->n_addrtype);
4836 mPUSHi(nent->n_net);
4841 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4847 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4849 I32 which = PL_op->op_type;
4851 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4852 struct protoent *getprotobyname(Netdb_name_t);
4853 struct protoent *getprotobynumber(int);
4854 struct protoent *getprotoent(void);
4856 struct protoent *pent;
4858 if (which == OP_GPBYNAME) {
4859 #ifdef HAS_GETPROTOBYNAME
4860 const char* const name = POPpbytex;
4861 pent = PerlSock_getprotobyname(name);
4863 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4866 else if (which == OP_GPBYNUMBER) {
4867 #ifdef HAS_GETPROTOBYNUMBER
4868 const int number = POPi;
4869 pent = PerlSock_getprotobynumber(number);
4871 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4875 #ifdef HAS_GETPROTOENT
4876 pent = PerlSock_getprotoent();
4878 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4882 if (GIMME != G_ARRAY) {
4883 PUSHs(sv = sv_newmortal());
4885 if (which == OP_GPBYNAME)
4886 sv_setiv(sv, (IV)pent->p_proto);
4888 sv_setpv(sv, pent->p_name);
4894 mPUSHs(newSVpv(pent->p_name, 0));
4895 PUSHs(space_join_names_mortal(pent->p_aliases));
4896 mPUSHi(pent->p_proto);
4901 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4907 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4909 I32 which = PL_op->op_type;
4911 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4912 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4913 struct servent *getservbyport(int, Netdb_name_t);
4914 struct servent *getservent(void);
4916 struct servent *sent;
4918 if (which == OP_GSBYNAME) {
4919 #ifdef HAS_GETSERVBYNAME
4920 const char * const proto = POPpbytex;
4921 const char * const name = POPpbytex;
4922 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4924 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4927 else if (which == OP_GSBYPORT) {
4928 #ifdef HAS_GETSERVBYPORT
4929 const char * const proto = POPpbytex;
4930 unsigned short port = (unsigned short)POPu;
4932 port = PerlSock_htons(port);
4934 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4936 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4940 #ifdef HAS_GETSERVENT
4941 sent = PerlSock_getservent();
4943 DIE(aTHX_ PL_no_sock_func, "getservent");
4947 if (GIMME != G_ARRAY) {
4948 PUSHs(sv = sv_newmortal());
4950 if (which == OP_GSBYNAME) {
4952 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4954 sv_setiv(sv, (IV)(sent->s_port));
4958 sv_setpv(sv, sent->s_name);
4964 mPUSHs(newSVpv(sent->s_name, 0));
4965 PUSHs(space_join_names_mortal(sent->s_aliases));
4967 mPUSHi(PerlSock_ntohs(sent->s_port));
4969 mPUSHi(sent->s_port);
4971 mPUSHs(newSVpv(sent->s_proto, 0));
4976 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4983 const int stayopen = TOPi;
4984 switch(PL_op->op_type) {
4986 #ifdef HAS_SETHOSTENT
4987 PerlSock_sethostent(stayopen);
4989 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4992 #ifdef HAS_SETNETENT
4994 PerlSock_setnetent(stayopen);
4996 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5000 #ifdef HAS_SETPROTOENT
5001 PerlSock_setprotoent(stayopen);
5003 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5007 #ifdef HAS_SETSERVENT
5008 PerlSock_setservent(stayopen);
5010 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5020 switch(PL_op->op_type) {
5022 #ifdef HAS_ENDHOSTENT
5023 PerlSock_endhostent();
5025 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5029 #ifdef HAS_ENDNETENT
5030 PerlSock_endnetent();
5032 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5036 #ifdef HAS_ENDPROTOENT
5037 PerlSock_endprotoent();
5039 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5043 #ifdef HAS_ENDSERVENT
5044 PerlSock_endservent();
5046 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5050 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5053 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5057 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5060 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5064 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5067 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5071 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5074 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5086 I32 which = PL_op->op_type;
5088 struct passwd *pwent = NULL;
5090 * We currently support only the SysV getsp* shadow password interface.
5091 * The interface is declared in <shadow.h> and often one needs to link
5092 * with -lsecurity or some such.
5093 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5096 * AIX getpwnam() is clever enough to return the encrypted password
5097 * only if the caller (euid?) is root.
5099 * There are at least three other shadow password APIs. Many platforms
5100 * seem to contain more than one interface for accessing the shadow
5101 * password databases, possibly for compatibility reasons.
5102 * The getsp*() is by far he simplest one, the other two interfaces
5103 * are much more complicated, but also very similar to each other.
5108 * struct pr_passwd *getprpw*();
5109 * The password is in
5110 * char getprpw*(...).ufld.fd_encrypt[]
5111 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5116 * struct es_passwd *getespw*();
5117 * The password is in
5118 * char *(getespw*(...).ufld.fd_encrypt)
5119 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5122 * struct userpw *getuserpw();
5123 * The password is in
5124 * char *(getuserpw(...)).spw_upw_passwd
5125 * (but the de facto standard getpwnam() should work okay)
5127 * Mention I_PROT here so that Configure probes for it.
5129 * In HP-UX for getprpw*() the manual page claims that one should include
5130 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5131 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5132 * and pp_sys.c already includes <shadow.h> if there is such.
5134 * Note that <sys/security.h> is already probed for, but currently
5135 * it is only included in special cases.
5137 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5138 * be preferred interface, even though also the getprpw*() interface
5139 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5140 * One also needs to call set_auth_parameters() in main() before
5141 * doing anything else, whether one is using getespw*() or getprpw*().
5143 * Note that accessing the shadow databases can be magnitudes
5144 * slower than accessing the standard databases.
5149 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5150 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5151 * the pw_comment is left uninitialized. */
5152 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5158 const char* const name = POPpbytex;
5159 pwent = getpwnam(name);
5165 pwent = getpwuid(uid);
5169 # ifdef HAS_GETPWENT
5171 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5172 if (pwent) pwent = getpwnam(pwent->pw_name);
5175 DIE(aTHX_ PL_no_func, "getpwent");
5181 if (GIMME != G_ARRAY) {
5182 PUSHs(sv = sv_newmortal());
5184 if (which == OP_GPWNAM)
5185 # if Uid_t_sign <= 0
5186 sv_setiv(sv, (IV)pwent->pw_uid);
5188 sv_setuv(sv, (UV)pwent->pw_uid);
5191 sv_setpv(sv, pwent->pw_name);
5197 mPUSHs(newSVpv(pwent->pw_name, 0));
5201 /* If we have getspnam(), we try to dig up the shadow
5202 * password. If we are underprivileged, the shadow
5203 * interface will set the errno to EACCES or similar,
5204 * and return a null pointer. If this happens, we will
5205 * use the dummy password (usually "*" or "x") from the
5206 * standard password database.
5208 * In theory we could skip the shadow call completely
5209 * if euid != 0 but in practice we cannot know which
5210 * security measures are guarding the shadow databases
5211 * on a random platform.
5213 * Resist the urge to use additional shadow interfaces.
5214 * Divert the urge to writing an extension instead.
5217 /* Some AIX setups falsely(?) detect some getspnam(), which
5218 * has a different API than the Solaris/IRIX one. */
5219 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5222 const struct spwd * const spwent = getspnam(pwent->pw_name);
5223 /* Save and restore errno so that
5224 * underprivileged attempts seem
5225 * to have never made the unsuccessful
5226 * attempt to retrieve the shadow password. */
5228 if (spwent && spwent->sp_pwdp)
5229 sv_setpv(sv, spwent->sp_pwdp);
5233 if (!SvPOK(sv)) /* Use the standard password, then. */
5234 sv_setpv(sv, pwent->pw_passwd);
5237 # ifndef INCOMPLETE_TAINTS
5238 /* passwd is tainted because user himself can diddle with it.
5239 * admittedly not much and in a very limited way, but nevertheless. */
5243 # if Uid_t_sign <= 0
5244 mPUSHi(pwent->pw_uid);
5246 mPUSHu(pwent->pw_uid);
5249 # if Uid_t_sign <= 0
5250 mPUSHi(pwent->pw_gid);
5252 mPUSHu(pwent->pw_gid);
5254 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5255 * because of the poor interface of the Perl getpw*(),
5256 * not because there's some standard/convention saying so.
5257 * A better interface would have been to return a hash,
5258 * but we are accursed by our history, alas. --jhi. */
5260 mPUSHi(pwent->pw_change);
5263 mPUSHi(pwent->pw_quota);
5266 mPUSHs(newSVpv(pwent->pw_age, 0));
5268 /* I think that you can never get this compiled, but just in case. */
5269 PUSHs(sv_mortalcopy(&PL_sv_no));
5274 /* pw_class and pw_comment are mutually exclusive--.
5275 * see the above note for pw_change, pw_quota, and pw_age. */
5277 mPUSHs(newSVpv(pwent->pw_class, 0));
5280 mPUSHs(newSVpv(pwent->pw_comment, 0));
5282 /* I think that you can never get this compiled, but just in case. */
5283 PUSHs(sv_mortalcopy(&PL_sv_no));
5288 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5290 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5292 # ifndef INCOMPLETE_TAINTS
5293 /* pw_gecos is tainted because user himself can diddle with it. */
5297 mPUSHs(newSVpv(pwent->pw_dir, 0));
5299 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5300 # ifndef INCOMPLETE_TAINTS
5301 /* pw_shell is tainted because user himself can diddle with it. */
5306 mPUSHi(pwent->pw_expire);
5311 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5319 const I32 which = PL_op->op_type;
5320 const struct group *grent;
5322 if (which == OP_GGRNAM) {
5323 const char* const name = POPpbytex;
5324 grent = (const struct group *)getgrnam(name);
5326 else if (which == OP_GGRGID) {
5327 const Gid_t gid = POPi;
5328 grent = (const struct group *)getgrgid(gid);
5332 grent = (struct group *)getgrent();
5334 DIE(aTHX_ PL_no_func, "getgrent");
5338 if (GIMME != G_ARRAY) {
5339 SV * const sv = sv_newmortal();
5343 if (which == OP_GGRNAM)
5345 sv_setiv(sv, (IV)grent->gr_gid);
5347 sv_setuv(sv, (UV)grent->gr_gid);
5350 sv_setpv(sv, grent->gr_name);
5356 mPUSHs(newSVpv(grent->gr_name, 0));
5359 mPUSHs(newSVpv(grent->gr_passwd, 0));
5361 PUSHs(sv_mortalcopy(&PL_sv_no));
5365 mPUSHi(grent->gr_gid);
5367 mPUSHu(grent->gr_gid);
5370 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5371 /* In UNICOS/mk (_CRAYMPP) the multithreading
5372 * versions (getgrnam_r, getgrgid_r)
5373 * seem to return an illegal pointer
5374 * as the group members list, gr_mem.
5375 * getgrent() doesn't even have a _r version
5376 * but the gr_mem is poisonous anyway.
5377 * So yes, you cannot get the list of group
5378 * members if building multithreaded in UNICOS/mk. */
5379 PUSHs(space_join_names_mortal(grent->gr_mem));
5385 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5395 if (!(tmps = PerlProc_getlogin()))
5397 sv_setpv_mg(TARG, tmps);
5401 DIE(aTHX_ PL_no_func, "getlogin");
5405 /* Miscellaneous. */
5410 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5411 register I32 items = SP - MARK;
5412 unsigned long a[20];
5417 while (++MARK <= SP) {
5418 if (SvTAINTED(*MARK)) {
5424 TAINT_PROPER("syscall");
5427 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5428 * or where sizeof(long) != sizeof(char*). But such machines will
5429 * not likely have syscall implemented either, so who cares?
5431 while (++MARK <= SP) {
5432 if (SvNIOK(*MARK) || !i)
5433 a[i++] = SvIV(*MARK);
5434 else if (*MARK == &PL_sv_undef)
5437 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5443 DIE(aTHX_ "Too many args to syscall");
5445 DIE(aTHX_ "Too few args to syscall");
5447 retval = syscall(a[0]);
5450 retval = syscall(a[0],a[1]);
5453 retval = syscall(a[0],a[1],a[2]);
5456 retval = syscall(a[0],a[1],a[2],a[3]);
5459 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5462 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5465 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5468 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5472 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5475 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5478 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5482 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5486 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5490 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5491 a[10],a[11],a[12],a[13]);
5493 #endif /* atarist */
5499 DIE(aTHX_ PL_no_func, "syscall");
5503 #ifdef FCNTL_EMULATE_FLOCK
5505 /* XXX Emulate flock() with fcntl().
5506 What's really needed is a good file locking module.
5510 fcntl_emulate_flock(int fd, int operation)
5515 switch (operation & ~LOCK_NB) {
5517 flock.l_type = F_RDLCK;
5520 flock.l_type = F_WRLCK;
5523 flock.l_type = F_UNLCK;
5529 flock.l_whence = SEEK_SET;
5530 flock.l_start = flock.l_len = (Off_t)0;
5532 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5533 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5534 errno = EWOULDBLOCK;
5538 #endif /* FCNTL_EMULATE_FLOCK */
5540 #ifdef LOCKF_EMULATE_FLOCK
5542 /* XXX Emulate flock() with lockf(). This is just to increase
5543 portability of scripts. The calls are not completely
5544 interchangeable. What's really needed is a good file
5548 /* The lockf() constants might have been defined in <unistd.h>.
5549 Unfortunately, <unistd.h> causes troubles on some mixed
5550 (BSD/POSIX) systems, such as SunOS 4.1.3.
5552 Further, the lockf() constants aren't POSIX, so they might not be
5553 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5554 just stick in the SVID values and be done with it. Sigh.
5558 # define F_ULOCK 0 /* Unlock a previously locked region */
5561 # define F_LOCK 1 /* Lock a region for exclusive use */
5564 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5567 # define F_TEST 3 /* Test a region for other processes locks */
5571 lockf_emulate_flock(int fd, int operation)
5577 /* flock locks entire file so for lockf we need to do the same */
5578 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5579 if (pos > 0) /* is seekable and needs to be repositioned */
5580 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5581 pos = -1; /* seek failed, so don't seek back afterwards */
5584 switch (operation) {
5586 /* LOCK_SH - get a shared lock */
5588 /* LOCK_EX - get an exclusive lock */
5590 i = lockf (fd, F_LOCK, 0);
5593 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5594 case LOCK_SH|LOCK_NB:
5595 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5596 case LOCK_EX|LOCK_NB:
5597 i = lockf (fd, F_TLOCK, 0);
5599 if ((errno == EAGAIN) || (errno == EACCES))
5600 errno = EWOULDBLOCK;
5603 /* LOCK_UN - unlock (non-blocking is a no-op) */
5605 case LOCK_UN|LOCK_NB:
5606 i = lockf (fd, F_ULOCK, 0);
5609 /* Default - can't decipher operation */
5616 if (pos > 0) /* need to restore position of the handle */
5617 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5622 #endif /* LOCKF_EMULATE_FLOCK */
5626 * c-indentation-style: bsd
5628 * indent-tabs-mode: t
5631 * ex: set ts=8 sts=4 sw=4 noet: