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/resource.h>
62 # include <sys/select.h>
66 /* XXX Configure test needed.
67 h_errno might not be a simple 'int', especially for multi-threaded
68 applications, see "extern int errno in perl.h". Creating such
69 a test requires taking into account the differences between
70 compiling multithreaded and singlethreaded ($ccflags et al).
71 HOST_NOT_FOUND is typically defined in <netdb.h>.
73 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
82 struct passwd *getpwnam (char *);
83 struct passwd *getpwuid (Uid_t);
88 struct passwd *getpwent (void);
89 #elif defined (VMS) && defined (my_getpwent)
90 struct passwd *Perl_my_getpwent (pTHX);
99 struct group *getgrnam (char *);
100 struct group *getgrgid (Gid_t);
104 struct group *getgrent (void);
110 # if defined(_MSC_VER) || defined(__MINGW32__)
111 # include <sys/utime.h>
118 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
121 # define my_chsize PerlLIO_chsize
124 # define my_chsize PerlLIO_chsize
126 I32 my_chsize(int fd, Off_t length);
132 #else /* no flock() */
134 /* fcntl.h might not have been included, even if it exists, because
135 the current Configure only sets I_FCNTL if it's needed to pick up
136 the *_OK constants. Make sure it has been included before testing
137 the fcntl() locking constants. */
138 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
142 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
143 # define FLOCK fcntl_emulate_flock
144 # define FCNTL_EMULATE_FLOCK
145 # else /* no flock() or fcntl(F_SETLK,...) */
147 # define FLOCK lockf_emulate_flock
148 # define LOCKF_EMULATE_FLOCK
150 # endif /* no flock() or fcntl(F_SETLK,...) */
153 static int FLOCK (int, int);
156 * These are the flock() constants. Since this sytems doesn't have
157 * flock(), the values of the constants are probably not available.
171 # endif /* emulating flock() */
173 #endif /* no flock() */
176 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
178 #if defined(I_SYS_ACCESS) && !defined(R_OK)
179 # include <sys/access.h>
182 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
183 # define FD_CLOEXEC 1 /* NeXT needs this */
189 /* Missing protos on LynxOS */
190 void sethostent(int);
191 void endhostent(void);
193 void endnetent(void);
194 void setprotoent(int);
195 void endprotoent(void);
196 void setservent(int);
197 void endservent(void);
200 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
202 /* F_OK unused: if stat() cannot find it... */
204 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
205 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
206 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
209 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
210 # ifdef I_SYS_SECURITY
211 # include <sys/security.h>
215 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
218 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
222 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
224 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
228 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
229 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
230 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
233 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
235 const Uid_t ruid = getuid();
236 const Uid_t euid = geteuid();
237 const Gid_t rgid = getgid();
238 const Gid_t egid = getegid();
241 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
242 Perl_croak(aTHX_ "switching effective uid is not implemented");
245 if (setreuid(euid, ruid))
248 if (setresuid(euid, ruid, (Uid_t)-1))
251 /* diag_listed_as: entering effective %s failed */
252 Perl_croak(aTHX_ "entering effective uid failed");
255 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
256 Perl_croak(aTHX_ "switching effective gid is not implemented");
259 if (setregid(egid, rgid))
262 if (setresgid(egid, rgid, (Gid_t)-1))
265 /* diag_listed_as: entering effective %s failed */
266 Perl_croak(aTHX_ "entering effective gid failed");
269 res = access(path, mode);
272 if (setreuid(ruid, euid))
275 if (setresuid(ruid, euid, (Uid_t)-1))
278 /* diag_listed_as: leaving effective %s failed */
279 Perl_croak(aTHX_ "leaving effective uid failed");
282 if (setregid(rgid, egid))
285 if (setresgid(rgid, egid, (Gid_t)-1))
288 /* diag_listed_as: leaving effective %s failed */
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 GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs;
366 /* make a copy of the pattern if it is gmagical, to ensure that magic
367 * is called once and only once */
368 if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs));
370 tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL));
372 if (PL_op->op_flags & OPf_SPECIAL) {
373 /* call Perl-level glob function instead. Stack args are:
375 * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
384 /* Note that we only ever get here if File::Glob fails to load
385 * without at the same time croaking, for some reason, or if
386 * perl was built with PERL_EXTERNAL_GLOB */
388 ENTER_with_name("glob");
393 * The external globbing program may use things we can't control,
394 * so for security reasons we must assume the worst.
397 taint_proper(PL_no_security, "glob");
401 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
404 SAVESPTR(PL_rs); /* This is not permanent, either. */
405 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
408 *SvPVX(PL_rs) = '\n';
412 result = do_readline();
413 LEAVE_with_name("glob");
420 PL_last_in_gv = cGVOP_gv;
421 return do_readline();
431 do_join(TARG, &PL_sv_no, MARK, SP);
435 else if (SP == MARK) {
442 if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
445 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
446 /* well-formed exception supplied */
449 SV * const errsv = ERRSV;
452 if (SvGMAGICAL(errsv)) {
453 exsv = sv_newmortal();
454 sv_setsv_nomg(exsv, errsv);
458 else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) {
459 exsv = sv_newmortal();
460 sv_setsv_nomg(exsv, errsv);
461 sv_catpvs(exsv, "\t...caught");
464 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
467 if (SvROK(exsv) && !PL_warnhook)
468 Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
479 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
481 if (SP - MARK != 1) {
483 do_join(TARG, &PL_sv_no, MARK, SP);
491 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
492 /* well-formed exception supplied */
495 SV * const errsv = ERRSV;
499 if (sv_isobject(exsv)) {
500 HV * const stash = SvSTASH(SvRV(exsv));
501 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
503 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
504 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
511 call_sv(MUTABLE_SV(GvCV(gv)),
512 G_SCALAR|G_EVAL|G_KEEPERR);
513 exsv = sv_mortalcopy(*PL_stack_sp--);
517 else if (SvPOK(errsv) && SvCUR(errsv)) {
518 exsv = sv_mortalcopy(errsv);
519 sv_catpvs(exsv, "\t...propagated");
522 exsv = newSVpvs_flags("Died", SVs_TEMP);
531 Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv,
532 const MAGIC *const mg, const U32 flags, U32 argc, ...)
537 PERL_ARGS_ASSERT_TIED_METHOD;
539 /* Ensure that our flag bits do not overlap. */
540 assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
541 assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
542 assert((TIED_METHOD_SAY & G_WANT) == 0);
544 PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
545 PUSHSTACKi(PERLSI_MAGIC);
546 EXTEND(SP, argc+1); /* object + args */
548 PUSHs(SvTIED_obj(sv, mg));
549 if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
550 Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
554 const U32 mortalize_not_needed
555 = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
557 va_start(args, argc);
559 SV *const arg = va_arg(args, SV *);
560 if(mortalize_not_needed)
569 ENTER_with_name("call_tied_method");
570 if (flags & TIED_METHOD_SAY) {
571 /* local $\ = "\n" */
572 SAVEGENERICSV(PL_ors_sv);
573 PL_ors_sv = newSVpvs("\n");
575 ret_args = call_method(methname, flags & G_WANT);
580 if (ret_args) { /* copy results back to original stack */
581 EXTEND(sp, ret_args);
582 Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
586 LEAVE_with_name("call_tied_method");
590 #define tied_method0(a,b,c,d) \
591 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
592 #define tied_method1(a,b,c,d,e) \
593 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
594 #define tied_method2(a,b,c,d,e,f) \
595 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
608 GV * const gv = MUTABLE_GV(*++MARK);
610 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
611 DIE(aTHX_ PL_no_usym, "filehandle");
613 if ((io = GvIOp(gv))) {
615 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
618 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
619 "Opening dirhandle %"HEKf" also as a file",
620 HEKfARG(GvENAME_HEK(gv)));
622 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
624 /* Method's args are same as ours ... */
625 /* ... except handle is replaced by the object */
626 return Perl_tied_method(aTHX_ "OPEN", mark - 1, MUTABLE_SV(io), mg,
627 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
639 tmps = SvPV_const(sv, len);
640 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
643 PUSHi( (I32)PL_forkprocess );
644 else if (PL_forkprocess == 0) /* we are a new child */
655 MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
661 IO * const io = GvIO(gv);
663 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
665 return tied_method0("CLOSE", SP, MUTABLE_SV(io), mg);
669 PUSHs(boolSV(do_close(gv, TRUE)));
682 GV * const wgv = MUTABLE_GV(POPs);
683 GV * const rgv = MUTABLE_GV(POPs);
688 if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
689 DIE(aTHX_ PL_no_usym, "filehandle");
694 do_close(rgv, FALSE);
696 do_close(wgv, FALSE);
698 if (PerlProc_pipe(fd) < 0)
701 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
702 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
703 IoOFP(rstio) = IoIFP(rstio);
704 IoIFP(wstio) = IoOFP(wstio);
705 IoTYPE(rstio) = IoTYPE_RDONLY;
706 IoTYPE(wstio) = IoTYPE_WRONLY;
708 if (!IoIFP(rstio) || !IoOFP(wstio)) {
710 PerlIO_close(IoIFP(rstio));
712 PerlLIO_close(fd[0]);
714 PerlIO_close(IoOFP(wstio));
716 PerlLIO_close(fd[1]);
719 #if defined(HAS_FCNTL) && defined(F_SETFD)
720 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
721 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
728 DIE(aTHX_ PL_no_func, "pipe");
742 gv = MUTABLE_GV(POPs);
746 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
748 return tied_method0("FILENO", SP, MUTABLE_SV(io), mg);
751 if (!io || !(fp = IoIFP(io))) {
752 /* Can't do this because people seem to do things like
753 defined(fileno($foo)) to check whether $foo is a valid fh.
760 PUSHi(PerlIO_fileno(fp));
772 if (MAXARG < 1 || (!TOPs && !POPs)) {
773 anum = PerlLIO_umask(022);
774 /* setting it to 022 between the two calls to umask avoids
775 * to have a window where the umask is set to 0 -- meaning
776 * that another thread could create world-writeable files. */
778 (void)PerlLIO_umask(anum);
781 anum = PerlLIO_umask(POPi);
782 TAINT_PROPER("umask");
785 /* Only DIE if trying to restrict permissions on "user" (self).
786 * Otherwise it's harmless and more useful to just return undef
787 * since 'group' and 'other' concepts probably don't exist here. */
788 if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
789 DIE(aTHX_ "umask not implemented");
790 XPUSHs(&PL_sv_undef);
809 gv = MUTABLE_GV(POPs);
813 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
815 /* This takes advantage of the implementation of the varargs
816 function, which I don't think that the optimiser will be able to
817 figure out. Although, as it's a static function, in theory it
819 return Perl_tied_method(aTHX_ "BINMODE", SP, MUTABLE_SV(io), mg,
820 G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
821 discp ? 1 : 0, discp);
825 if (!io || !(fp = IoIFP(io))) {
827 SETERRNO(EBADF,RMS_IFI);
834 const char *d = NULL;
837 d = SvPV_const(discp, len);
838 mode = mode_from_discipline(d, len);
839 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
840 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
841 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
862 const I32 markoff = MARK - PL_stack_base;
863 const char *methname;
864 int how = PERL_MAGIC_tied;
868 switch(SvTYPE(varsv)) {
872 methname = "TIEHASH";
873 if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
874 HvLAZYDEL_off(varsv);
875 hv_free_ent((HV *)varsv, entry);
877 HvEITER_set(MUTABLE_HV(varsv), 0);
881 methname = "TIEARRAY";
882 if (!AvREAL(varsv)) {
884 Perl_croak(aTHX_ "Cannot tie unreifiable array");
885 av_clear((AV *)varsv);
892 if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
893 methname = "TIEHANDLE";
894 how = PERL_MAGIC_tiedscalar;
895 /* For tied filehandles, we apply tiedscalar magic to the IO
896 slot of the GP rather than the GV itself. AMS 20010812 */
898 GvIOp(varsv) = newIO();
899 varsv = MUTABLE_SV(GvIOp(varsv));
904 methname = "TIESCALAR";
905 how = PERL_MAGIC_tiedscalar;
909 if (sv_isobject(*MARK)) { /* Calls GET magic. */
910 ENTER_with_name("call_TIE");
911 PUSHSTACKi(PERLSI_MAGIC);
913 EXTEND(SP,(I32)items);
917 call_method(methname, G_SCALAR);
920 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
921 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
922 * wrong error message, and worse case, supreme action at a distance.
923 * (Sorry obfuscation writers. You're not going to be given this one.)
925 stash = gv_stashsv(*MARK, 0);
926 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
927 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
928 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
930 ENTER_with_name("call_TIE");
931 PUSHSTACKi(PERLSI_MAGIC);
933 EXTEND(SP,(I32)items);
937 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
943 if (sv_isobject(sv)) {
944 sv_unmagic(varsv, how);
945 /* Croak if a self-tie on an aggregate is attempted. */
946 if (varsv == SvRV(sv) &&
947 (SvTYPE(varsv) == SVt_PVAV ||
948 SvTYPE(varsv) == SVt_PVHV))
950 "Self-ties of arrays and hashes are not supported");
951 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
953 LEAVE_with_name("call_TIE");
954 SP = PL_stack_base + markoff;
964 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
965 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
967 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
970 if ((mg = SvTIED_mg(sv, how))) {
971 SV * const obj = SvRV(SvTIED_obj(sv, mg));
973 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
975 if (gv && isGV(gv) && (cv = GvCV(gv))) {
977 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
978 mXPUSHi(SvREFCNT(obj) - 1);
980 ENTER_with_name("call_UNTIE");
981 call_sv(MUTABLE_SV(cv), G_VOID);
982 LEAVE_with_name("call_UNTIE");
985 else if (mg && SvREFCNT(obj) > 1) {
986 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
987 "untie attempted while %"UVuf" inner references still exist",
988 (UV)SvREFCNT(obj) - 1 ) ;
992 sv_unmagic(sv, how) ;
1002 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1003 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1005 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1008 if ((mg = SvTIED_mg(sv, how))) {
1009 PUSHs(SvTIED_obj(sv, mg));
1022 HV * const hv = MUTABLE_HV(POPs);
1023 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1024 stash = gv_stashsv(sv, 0);
1025 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1027 require_pv("AnyDBM_File.pm");
1029 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1030 DIE(aTHX_ "No dbm on this machine");
1040 mPUSHu(O_RDWR|O_CREAT);
1044 if (!SvOK(right)) right = &PL_sv_no;
1048 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1051 if (!sv_isobject(TOPs)) {
1059 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1063 if (sv_isobject(TOPs)) {
1064 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1065 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1082 struct timeval timebuf;
1083 struct timeval *tbuf = &timebuf;
1086 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1091 # if BYTEORDER & 0xf0000
1092 # define ORDERBYTE (0x88888888 - BYTEORDER)
1094 # define ORDERBYTE (0x4444 - BYTEORDER)
1100 for (i = 1; i <= 3; i++) {
1101 SV * const sv = SP[i];
1106 sv_force_normal_flags(sv, 0);
1107 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1108 Perl_croak_no_modify();
1111 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1112 "Non-string passed as bitmask");
1113 SvPV_force_nomg_nolen(sv); /* force string conversion */
1120 /* little endians can use vecs directly */
1121 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1128 masksize = NFDBITS / NBBY;
1130 masksize = sizeof(long); /* documented int, everyone seems to use long */
1132 Zero(&fd_sets[0], 4, char*);
1135 # if SELECT_MIN_BITS == 1
1136 growsize = sizeof(fd_set);
1138 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1139 # undef SELECT_MIN_BITS
1140 # define SELECT_MIN_BITS __FD_SETSIZE
1142 /* If SELECT_MIN_BITS is greater than one we most probably will want
1143 * to align the sizes with SELECT_MIN_BITS/8 because for example
1144 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1145 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1146 * on (sets/tests/clears bits) is 32 bits. */
1147 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1155 timebuf.tv_sec = (long)value;
1156 value -= (NV)timebuf.tv_sec;
1157 timebuf.tv_usec = (long)(value * 1000000.0);
1162 for (i = 1; i <= 3; i++) {
1164 if (!SvOK(sv) || SvCUR(sv) == 0) {
1171 Sv_Grow(sv, growsize);
1175 while (++j <= growsize) {
1179 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1181 Newx(fd_sets[i], growsize, char);
1182 for (offset = 0; offset < growsize; offset += masksize) {
1183 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1184 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1187 fd_sets[i] = SvPVX(sv);
1191 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1192 /* Can't make just the (void*) conditional because that would be
1193 * cpp #if within cpp macro, and not all compilers like that. */
1194 nfound = PerlSock_select(
1196 (Select_fd_set_t) fd_sets[1],
1197 (Select_fd_set_t) fd_sets[2],
1198 (Select_fd_set_t) fd_sets[3],
1199 (void*) tbuf); /* Workaround for compiler bug. */
1201 nfound = PerlSock_select(
1203 (Select_fd_set_t) fd_sets[1],
1204 (Select_fd_set_t) fd_sets[2],
1205 (Select_fd_set_t) fd_sets[3],
1208 for (i = 1; i <= 3; i++) {
1211 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1213 for (offset = 0; offset < growsize; offset += masksize) {
1214 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1215 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1217 Safefree(fd_sets[i]);
1224 if (GIMME == G_ARRAY && tbuf) {
1225 value = (NV)(timebuf.tv_sec) +
1226 (NV)(timebuf.tv_usec) / 1000000.0;
1231 DIE(aTHX_ "select not implemented");
1236 =for apidoc setdefout
1238 Sets PL_defoutgv, the default file handle for output, to the passed in
1239 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1240 count of the passed in typeglob is increased by one, and the reference count
1241 of the typeglob that PL_defoutgv points to is decreased by one.
1247 Perl_setdefout(pTHX_ GV *gv)
1250 PERL_ARGS_ASSERT_SETDEFOUT;
1251 SvREFCNT_inc_simple_void_NN(gv);
1252 SvREFCNT_dec(PL_defoutgv);
1260 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1261 GV * egv = GvEGVx(PL_defoutgv);
1266 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1267 gvp = hv && HvENAME(hv)
1268 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1270 if (gvp && *gvp == egv) {
1271 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1275 mXPUSHs(newRV(MUTABLE_SV(egv)));
1279 if (!GvIO(newdefout))
1280 gv_IOadd(newdefout);
1281 setdefout(newdefout);
1291 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1292 IO *const io = GvIO(gv);
1298 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1300 const U32 gimme = GIMME_V;
1301 Perl_tied_method(aTHX_ "GETC", SP, MUTABLE_SV(io), mg, gimme, 0);
1302 if (gimme == G_SCALAR) {
1304 SvSetMagicSV_nosteal(TARG, TOPs);
1309 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1310 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1312 SETERRNO(EBADF,RMS_IFI);
1316 sv_setpvs(TARG, " ");
1317 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1318 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1319 /* Find out how many bytes the char needs */
1320 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1323 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1324 SvCUR_set(TARG,1+len);
1333 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1337 const I32 gimme = GIMME_V;
1339 PERL_ARGS_ASSERT_DOFORM;
1341 if (cv && CvCLONE(cv))
1342 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1347 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1348 PUSHFORMAT(cx, retop);
1349 if (CvDEPTH(cv) >= 2) {
1350 PERL_STACK_OVERFLOW_CHECK();
1351 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1354 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1356 setdefout(gv); /* locally select filehandle so $% et al work */
1375 gv = MUTABLE_GV(POPs);
1392 tmpsv = sv_newmortal();
1393 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1394 DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
1396 IoFLAGS(io) &= ~IOf_DIDTOP;
1397 RETURNOP(doform(cv,gv,PL_op->op_next));
1403 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1404 IO * const io = GvIOp(gv);
1412 if (!io || !(ofp = IoOFP(io)))
1415 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1416 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1418 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1419 PL_formtarget != PL_toptarget)
1423 if (!IoTOP_GV(io)) {
1426 if (!IoTOP_NAME(io)) {
1428 if (!IoFMT_NAME(io))
1429 IoFMT_NAME(io) = savepv(GvNAME(gv));
1430 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1431 HEKfARG(GvNAME_HEK(gv))));
1432 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1433 if ((topgv && GvFORM(topgv)) ||
1434 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1435 IoTOP_NAME(io) = savesvpv(topname);
1437 IoTOP_NAME(io) = savepvs("top");
1439 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1440 if (!topgv || !GvFORM(topgv)) {
1441 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1444 IoTOP_GV(io) = topgv;
1446 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1447 I32 lines = IoLINES_LEFT(io);
1448 const char *s = SvPVX_const(PL_formtarget);
1449 if (lines <= 0) /* Yow, header didn't even fit!!! */
1451 while (lines-- > 0) {
1452 s = strchr(s, '\n');
1458 const STRLEN save = SvCUR(PL_formtarget);
1459 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1460 do_print(PL_formtarget, ofp);
1461 SvCUR_set(PL_formtarget, save);
1462 sv_chop(PL_formtarget, s);
1463 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1466 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1467 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1468 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1470 PL_formtarget = PL_toptarget;
1471 IoFLAGS(io) |= IOf_DIDTOP;
1474 DIE(aTHX_ "bad top format reference");
1477 SV * const sv = sv_newmortal();
1478 gv_efullname4(sv, fgv, NULL, FALSE);
1479 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1481 return doform(cv, gv, PL_op);
1485 POPBLOCK(cx,PL_curpm);
1487 retop = cx->blk_sub.retop;
1488 SP = newsp; /* ignore retval of formline */
1491 if (!io || !(fp = IoOFP(io))) {
1492 if (io && IoIFP(io))
1493 report_wrongway_fh(gv, '<');
1499 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1500 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1502 if (!do_print(PL_formtarget, fp))
1505 FmLINES(PL_formtarget) = 0;
1506 SvCUR_set(PL_formtarget, 0);
1507 *SvEND(PL_formtarget) = '\0';
1508 if (IoFLAGS(io) & IOf_FLUSH)
1509 (void)PerlIO_flush(fp);
1513 PL_formtarget = PL_bodytarget;
1514 PERL_UNUSED_VAR(gimme);
1520 dVAR; dSP; dMARK; dORIGMARK;
1524 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1525 IO *const io = GvIO(gv);
1527 /* Treat empty list as "" */
1528 if (MARK == SP) XPUSHs(&PL_sv_no);
1531 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1533 if (MARK == ORIGMARK) {
1536 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1539 return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io),
1541 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1548 SETERRNO(EBADF,RMS_IFI);
1551 else if (!(fp = IoOFP(io))) {
1553 report_wrongway_fh(gv, '<');
1554 else if (ckWARN(WARN_CLOSED))
1556 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1560 SV *sv = sv_newmortal();
1561 do_sprintf(sv, SP - MARK, MARK + 1);
1562 if (!do_print(sv, fp))
1565 if (IoFLAGS(io) & IOf_FLUSH)
1566 if (PerlIO_flush(fp) == EOF)
1575 PUSHs(&PL_sv_undef);
1583 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1584 const int mode = POPi;
1585 SV * const sv = POPs;
1586 GV * const gv = MUTABLE_GV(POPs);
1589 /* Need TIEHANDLE method ? */
1590 const char * const tmps = SvPV_const(sv, len);
1591 /* FIXME? do_open should do const */
1592 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1593 IoLINES(GvIOp(gv)) = 0;
1597 PUSHs(&PL_sv_undef);
1604 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1618 bool charstart = FALSE;
1619 STRLEN charskip = 0;
1622 GV * const gv = MUTABLE_GV(*++MARK);
1623 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1624 && gv && (io = GvIO(gv)) )
1626 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1628 return Perl_tied_method(aTHX_ "READ", mark - 1, MUTABLE_SV(io), mg,
1629 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1638 sv_setpvs(bufsv, "");
1639 length = SvIVx(*++MARK);
1641 DIE(aTHX_ "Negative length");
1644 offset = SvIVx(*++MARK);
1648 if (!io || !IoIFP(io)) {
1650 SETERRNO(EBADF,RMS_IFI);
1653 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1654 buffer = SvPVutf8_force(bufsv, blen);
1655 /* UTF-8 may not have been set if they are all low bytes */
1660 buffer = SvPV_force(bufsv, blen);
1661 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1663 if (DO_UTF8(bufsv)) {
1664 blen = sv_len_utf8_nomg(bufsv);
1673 if (PL_op->op_type == OP_RECV) {
1674 Sock_size_t bufsize;
1675 char namebuf[MAXPATHLEN];
1676 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1677 bufsize = sizeof (struct sockaddr_in);
1679 bufsize = sizeof namebuf;
1681 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1685 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1686 /* 'offset' means 'flags' here */
1687 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1688 (struct sockaddr *)namebuf, &bufsize);
1691 /* MSG_TRUNC can give oversized count; quietly lose it */
1694 SvCUR_set(bufsv, count);
1695 *SvEND(bufsv) = '\0';
1696 (void)SvPOK_only(bufsv);
1700 /* This should not be marked tainted if the fp is marked clean */
1701 if (!(IoFLAGS(io) & IOf_UNTAINT))
1702 SvTAINTED_on(bufsv);
1704 sv_setpvn(TARG, namebuf, bufsize);
1710 if (-offset > (SSize_t)blen)
1711 DIE(aTHX_ "Offset outside string");
1714 if (DO_UTF8(bufsv)) {
1715 /* convert offset-as-chars to offset-as-bytes */
1716 if (offset >= (SSize_t)blen)
1717 offset += SvCUR(bufsv) - blen;
1719 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1722 orig_size = SvCUR(bufsv);
1723 /* Allocating length + offset + 1 isn't perfect in the case of reading
1724 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1726 (should be 2 * length + offset + 1, or possibly something longer if
1727 PL_encoding is true) */
1728 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1729 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1730 Zero(buffer+orig_size, offset-orig_size, char);
1732 buffer = buffer + offset;
1734 read_target = bufsv;
1736 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1737 concatenate it to the current buffer. */
1739 /* Truncate the existing buffer to the start of where we will be
1741 SvCUR_set(bufsv, offset);
1743 read_target = sv_newmortal();
1744 SvUPGRADE(read_target, SVt_PV);
1745 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1748 if (PL_op->op_type == OP_SYSREAD) {
1749 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1750 if (IoTYPE(io) == IoTYPE_SOCKET) {
1751 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1757 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1762 #ifdef HAS_SOCKET__bad_code_maybe
1763 if (IoTYPE(io) == IoTYPE_SOCKET) {
1764 Sock_size_t bufsize;
1765 char namebuf[MAXPATHLEN];
1766 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1767 bufsize = sizeof (struct sockaddr_in);
1769 bufsize = sizeof namebuf;
1771 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1772 (struct sockaddr *)namebuf, &bufsize);
1777 count = PerlIO_read(IoIFP(io), buffer, length);
1778 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1779 if (count == 0 && PerlIO_error(IoIFP(io)))
1783 if (IoTYPE(io) == IoTYPE_WRONLY)
1784 report_wrongway_fh(gv, '>');
1787 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1788 *SvEND(read_target) = '\0';
1789 (void)SvPOK_only(read_target);
1790 if (fp_utf8 && !IN_BYTES) {
1791 /* Look at utf8 we got back and count the characters */
1792 const char *bend = buffer + count;
1793 while (buffer < bend) {
1795 skip = UTF8SKIP(buffer);
1798 if (buffer - charskip + skip > bend) {
1799 /* partial character - try for rest of it */
1800 length = skip - (bend-buffer);
1801 offset = bend - SvPVX_const(bufsv);
1813 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1814 provided amount read (count) was what was requested (length)
1816 if (got < wanted && count == length) {
1817 length = wanted - got;
1818 offset = bend - SvPVX_const(bufsv);
1821 /* return value is character count */
1825 else if (buffer_utf8) {
1826 /* Let svcatsv upgrade the bytes we read in to utf8.
1827 The buffer is a mortal so will be freed soon. */
1828 sv_catsv_nomg(bufsv, read_target);
1831 /* This should not be marked tainted if the fp is marked clean */
1832 if (!(IoFLAGS(io) & IOf_UNTAINT))
1833 SvTAINTED_on(bufsv);
1845 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1850 STRLEN orig_blen_bytes;
1851 const int op_type = PL_op->op_type;
1854 GV *const gv = MUTABLE_GV(*++MARK);
1855 IO *const io = GvIO(gv);
1857 if (op_type == OP_SYSWRITE && io) {
1858 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1860 if (MARK == SP - 1) {
1862 mXPUSHi(sv_len(sv));
1866 return Perl_tied_method(aTHX_ "WRITE", mark - 1, MUTABLE_SV(io), mg,
1867 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1877 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1879 if (io && IoIFP(io))
1880 report_wrongway_fh(gv, '<');
1883 SETERRNO(EBADF,RMS_IFI);
1887 /* Do this first to trigger any overloading. */
1888 buffer = SvPV_const(bufsv, blen);
1889 orig_blen_bytes = blen;
1890 doing_utf8 = DO_UTF8(bufsv);
1892 if (PerlIO_isutf8(IoIFP(io))) {
1893 if (!SvUTF8(bufsv)) {
1894 /* We don't modify the original scalar. */
1895 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1896 buffer = (char *) tmpbuf;
1900 else if (doing_utf8) {
1901 STRLEN tmplen = blen;
1902 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1905 buffer = (char *) tmpbuf;
1909 assert((char *)result == buffer);
1910 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1915 if (op_type == OP_SEND) {
1916 const int flags = SvIVx(*++MARK);
1919 char * const sockbuf = SvPVx(*++MARK, mlen);
1920 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1921 flags, (struct sockaddr *)sockbuf, mlen);
1925 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1931 Size_t length = 0; /* This length is in characters. */
1937 /* The SV is bytes, and we've had to upgrade it. */
1938 blen_chars = orig_blen_bytes;
1940 /* The SV really is UTF-8. */
1941 /* Don't call sv_len_utf8 on a magical or overloaded
1942 scalar, as we might get back a different result. */
1943 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
1950 length = blen_chars;
1952 #if Size_t_size > IVSIZE
1953 length = (Size_t)SvNVx(*++MARK);
1955 length = (Size_t)SvIVx(*++MARK);
1957 if ((SSize_t)length < 0) {
1959 DIE(aTHX_ "Negative length");
1964 offset = SvIVx(*++MARK);
1966 if (-offset > (IV)blen_chars) {
1968 DIE(aTHX_ "Offset outside string");
1970 offset += blen_chars;
1971 } else if (offset > (IV)blen_chars) {
1973 DIE(aTHX_ "Offset outside string");
1977 if (length > blen_chars - offset)
1978 length = blen_chars - offset;
1980 /* Here we convert length from characters to bytes. */
1981 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1982 /* Either we had to convert the SV, or the SV is magical, or
1983 the SV has overloading, in which case we can't or mustn't
1984 or mustn't call it again. */
1986 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1987 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1989 /* It's a real UTF-8 SV, and it's not going to change under
1990 us. Take advantage of any cache. */
1992 I32 len_I32 = length;
1994 /* Convert the start and end character positions to bytes.
1995 Remember that the second argument to sv_pos_u2b is relative
1997 sv_pos_u2b(bufsv, &start, &len_I32);
2004 buffer = buffer+offset;
2006 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2007 if (IoTYPE(io) == IoTYPE_SOCKET) {
2008 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
2014 /* See the note at doio.c:do_print about filesize limits. --jhi */
2015 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2024 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2027 #if Size_t_size > IVSIZE
2047 * in Perl 5.12 and later, the additional parameter is a bitmask:
2050 * 2 = eof() <- ARGV magic
2052 * I'll rely on the compiler's trace flow analysis to decide whether to
2053 * actually assign this out here, or punt it into the only block where it is
2054 * used. Doing it out here is DRY on the condition logic.
2059 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2065 if (PL_op->op_flags & OPf_SPECIAL) {
2066 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2070 gv = PL_last_in_gv; /* eof */
2078 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2079 return tied_method1("EOF", SP, MUTABLE_SV(io), mg, newSVuv(which));
2082 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2083 if (io && !IoIFP(io)) {
2084 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2086 IoFLAGS(io) &= ~IOf_START;
2087 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2089 sv_setpvs(GvSV(gv), "-");
2091 GvSV(gv) = newSVpvs("-");
2092 SvSETMAGIC(GvSV(gv));
2094 else if (!nextargv(gv))
2099 PUSHs(boolSV(do_eof(gv)));
2109 if (MAXARG != 0 && (TOPs || POPs))
2110 PL_last_in_gv = MUTABLE_GV(POPs);
2117 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2119 return tied_method0("TELL", SP, MUTABLE_SV(io), mg);
2124 SETERRNO(EBADF,RMS_IFI);
2129 #if LSEEKSIZE > IVSIZE
2130 PUSHn( do_tell(gv) );
2132 PUSHi( do_tell(gv) );
2140 const int whence = POPi;
2141 #if LSEEKSIZE > IVSIZE
2142 const Off_t offset = (Off_t)SvNVx(POPs);
2144 const Off_t offset = (Off_t)SvIVx(POPs);
2147 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2148 IO *const io = GvIO(gv);
2151 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2153 #if LSEEKSIZE > IVSIZE
2154 SV *const offset_sv = newSVnv((NV) offset);
2156 SV *const offset_sv = newSViv(offset);
2159 return tied_method2("SEEK", SP, MUTABLE_SV(io), mg, offset_sv,
2164 if (PL_op->op_type == OP_SEEK)
2165 PUSHs(boolSV(do_seek(gv, offset, whence)));
2167 const Off_t sought = do_sysseek(gv, offset, whence);
2169 PUSHs(&PL_sv_undef);
2171 SV* const sv = sought ?
2172 #if LSEEKSIZE > IVSIZE
2177 : newSVpvn(zero_but_true, ZBTLEN);
2188 /* There seems to be no consensus on the length type of truncate()
2189 * and ftruncate(), both off_t and size_t have supporters. In
2190 * general one would think that when using large files, off_t is
2191 * at least as wide as size_t, so using an off_t should be okay. */
2192 /* XXX Configure probe for the length type of *truncate() needed XXX */
2195 #if Off_t_size > IVSIZE
2200 /* Checking for length < 0 is problematic as the type might or
2201 * might not be signed: if it is not, clever compilers will moan. */
2202 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2205 SV * const sv = POPs;
2210 if (PL_op->op_flags & OPf_SPECIAL
2211 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2212 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2219 TAINT_PROPER("truncate");
2220 if (!(fp = IoIFP(io))) {
2226 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2228 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2234 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2235 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2236 goto do_ftruncate_io;
2239 const char * const name = SvPV_nomg_const_nolen(sv);
2240 TAINT_PROPER("truncate");
2242 if (truncate(name, len) < 0)
2246 const int tmpfd = PerlLIO_open(name, O_RDWR);
2251 if (my_chsize(tmpfd, len) < 0)
2253 PerlLIO_close(tmpfd);
2262 SETERRNO(EBADF,RMS_IFI);
2270 SV * const argsv = POPs;
2271 const unsigned int func = POPu;
2272 const int optype = PL_op->op_type;
2273 GV * const gv = MUTABLE_GV(POPs);
2274 IO * const io = gv ? GvIOn(gv) : NULL;
2278 if (!io || !argsv || !IoIFP(io)) {
2280 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2284 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2287 s = SvPV_force(argsv, len);
2288 need = IOCPARM_LEN(func);
2290 s = Sv_Grow(argsv, need + 1);
2291 SvCUR_set(argsv, need);
2294 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2297 retval = SvIV(argsv);
2298 s = INT2PTR(char*,retval); /* ouch */
2301 TAINT_PROPER(PL_op_desc[optype]);
2303 if (optype == OP_IOCTL)
2305 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2307 DIE(aTHX_ "ioctl is not implemented");
2311 DIE(aTHX_ "fcntl is not implemented");
2313 #if defined(OS2) && defined(__EMX__)
2314 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2316 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2320 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2322 if (s[SvCUR(argsv)] != 17)
2323 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2325 s[SvCUR(argsv)] = 0; /* put our null back */
2326 SvSETMAGIC(argsv); /* Assume it has changed */
2335 PUSHp(zero_but_true, ZBTLEN);
2346 const int argtype = POPi;
2347 GV * const gv = MUTABLE_GV(POPs);
2348 IO *const io = GvIO(gv);
2349 PerlIO *const fp = io ? IoIFP(io) : NULL;
2351 /* XXX Looks to me like io is always NULL at this point */
2353 (void)PerlIO_flush(fp);
2354 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2359 SETERRNO(EBADF,RMS_IFI);
2364 DIE(aTHX_ PL_no_func, "flock()");
2375 const int protocol = POPi;
2376 const int type = POPi;
2377 const int domain = POPi;
2378 GV * const gv = MUTABLE_GV(POPs);
2379 IO * const io = gv ? GvIOn(gv) : NULL;
2384 if (io && IoIFP(io))
2385 do_close(gv, FALSE);
2386 SETERRNO(EBADF,LIB_INVARG);
2391 do_close(gv, FALSE);
2393 TAINT_PROPER("socket");
2394 fd = PerlSock_socket(domain, type, protocol);
2397 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2398 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2399 IoTYPE(io) = IoTYPE_SOCKET;
2400 if (!IoIFP(io) || !IoOFP(io)) {
2401 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2402 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2403 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2406 #if defined(HAS_FCNTL) && defined(F_SETFD)
2407 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
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 IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2424 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 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 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(__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 */
2576 #ifdef __SCO_VERSION__
2577 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2580 PUSHp(namebuf, len);
2584 report_evil_fh(ggv);
2585 SETERRNO(EBADF,SS_IVCHAN);
2595 const int how = POPi;
2596 GV * const gv = MUTABLE_GV(POPs);
2597 IO * const io = GvIOn(gv);
2599 if (!io || !IoIFP(io))
2602 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2607 SETERRNO(EBADF,SS_IVCHAN);
2614 const int optype = PL_op->op_type;
2615 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2616 const unsigned int optname = (unsigned int) POPi;
2617 const unsigned int lvl = (unsigned int) POPi;
2618 GV * const gv = MUTABLE_GV(POPs);
2619 IO * const io = GvIOn(gv);
2623 if (!io || !IoIFP(io))
2626 fd = PerlIO_fileno(IoIFP(io));
2630 (void)SvPOK_only(sv);
2634 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2641 #if defined(__SYMBIAN32__)
2642 # define SETSOCKOPT_OPTION_VALUE_T void *
2644 # define SETSOCKOPT_OPTION_VALUE_T const char *
2646 /* XXX TODO: We need to have a proper type (a Configure probe,
2647 * etc.) for what the C headers think of the third argument of
2648 * setsockopt(), the option_value read-only buffer: is it
2649 * a "char *", or a "void *", const or not. Some compilers
2650 * don't take kindly to e.g. assuming that "char *" implicitly
2651 * promotes to a "void *", or to explicitly promoting/demoting
2652 * consts to non/vice versa. The "const void *" is the SUS
2653 * definition, but that does not fly everywhere for the above
2655 SETSOCKOPT_OPTION_VALUE_T buf;
2659 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2663 aint = (int)SvIV(sv);
2664 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2667 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2677 SETERRNO(EBADF,SS_IVCHAN);
2686 const int optype = PL_op->op_type;
2687 GV * const gv = MUTABLE_GV(POPs);
2688 IO * const io = GvIOn(gv);
2693 if (!io || !IoIFP(io))
2696 sv = sv_2mortal(newSV(257));
2697 (void)SvPOK_only(sv);
2701 fd = PerlIO_fileno(IoIFP(io));
2703 case OP_GETSOCKNAME:
2704 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2707 case OP_GETPEERNAME:
2708 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2710 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2712 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";
2713 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2714 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2715 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2716 sizeof(u_short) + sizeof(struct in_addr))) {
2723 #ifdef BOGUS_GETNAME_RETURN
2724 /* Interactive Unix, getpeername() and getsockname()
2725 does not return valid namelen */
2726 if (len == BOGUS_GETNAME_RETURN)
2727 len = sizeof(struct sockaddr);
2736 SETERRNO(EBADF,SS_IVCHAN);
2755 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2756 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2757 if (PL_op->op_type == OP_LSTAT) {
2758 if (gv != PL_defgv) {
2759 do_fstat_warning_check:
2760 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2761 "lstat() on filehandle%s%"SVf,
2764 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2766 } else if (PL_laststype != OP_LSTAT)
2767 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2768 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2771 if (gv != PL_defgv) {
2775 PL_laststype = OP_STAT;
2776 PL_statgv = gv ? gv : (GV *)io;
2777 sv_setpvs(PL_statname, "");
2784 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2786 } else if (IoDIRP(io)) {
2788 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2791 PL_laststatval = -1;
2794 else PL_laststatval = -1;
2795 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2798 if (PL_laststatval < 0) {
2803 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2804 io = MUTABLE_IO(SvRV(sv));
2805 if (PL_op->op_type == OP_LSTAT)
2806 goto do_fstat_warning_check;
2807 goto do_fstat_have_io;
2810 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2811 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2813 PL_laststype = PL_op->op_type;
2814 if (PL_op->op_type == OP_LSTAT)
2815 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2817 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2818 if (PL_laststatval < 0) {
2819 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2820 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2826 if (gimme != G_ARRAY) {
2827 if (gimme != G_VOID)
2828 XPUSHs(boolSV(max));
2834 mPUSHi(PL_statcache.st_dev);
2835 #if ST_INO_SIZE > IVSIZE
2836 mPUSHn(PL_statcache.st_ino);
2838 # if ST_INO_SIGN <= 0
2839 mPUSHi(PL_statcache.st_ino);
2841 mPUSHu(PL_statcache.st_ino);
2844 mPUSHu(PL_statcache.st_mode);
2845 mPUSHu(PL_statcache.st_nlink);
2846 #if Uid_t_size > IVSIZE
2847 mPUSHn(PL_statcache.st_uid);
2849 # if Uid_t_sign <= 0
2850 mPUSHi(PL_statcache.st_uid);
2852 mPUSHu(PL_statcache.st_uid);
2855 #if Gid_t_size > IVSIZE
2856 mPUSHn(PL_statcache.st_gid);
2858 # if Gid_t_sign <= 0
2859 mPUSHi(PL_statcache.st_gid);
2861 mPUSHu(PL_statcache.st_gid);
2864 #ifdef USE_STAT_RDEV
2865 mPUSHi(PL_statcache.st_rdev);
2867 PUSHs(newSVpvs_flags("", SVs_TEMP));
2869 #if Off_t_size > IVSIZE
2870 mPUSHn(PL_statcache.st_size);
2872 mPUSHi(PL_statcache.st_size);
2875 mPUSHn(PL_statcache.st_atime);
2876 mPUSHn(PL_statcache.st_mtime);
2877 mPUSHn(PL_statcache.st_ctime);
2879 mPUSHi(PL_statcache.st_atime);
2880 mPUSHi(PL_statcache.st_mtime);
2881 mPUSHi(PL_statcache.st_ctime);
2883 #ifdef USE_STAT_BLOCKS
2884 mPUSHu(PL_statcache.st_blksize);
2885 mPUSHu(PL_statcache.st_blocks);
2887 PUSHs(newSVpvs_flags("", SVs_TEMP));
2888 PUSHs(newSVpvs_flags("", SVs_TEMP));
2894 /* All filetest ops avoid manipulating the perl stack pointer in their main
2895 bodies (since commit d2c4d2d1e22d3125), and return using either
2896 S_ft_return_false() or S_ft_return_true(). These two helper functions are
2897 the only two which manipulate the perl stack. To ensure that no stack
2898 manipulation macros are used, the filetest ops avoid defining a local copy
2899 of the stack pointer with dSP. */
2901 /* If the next filetest is stacked up with this one
2902 (PL_op->op_private & OPpFT_STACKING), we leave
2903 the original argument on the stack for success,
2904 and skip the stacked operators on failure.
2905 The next few macros/functions take care of this.
2909 S_ft_return_false(pTHX_ SV *ret) {
2913 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
2917 if (PL_op->op_private & OPpFT_STACKING) {
2918 while (OP_IS_FILETEST(next->op_type)
2919 && next->op_private & OPpFT_STACKED)
2920 next = next->op_next;
2925 PERL_STATIC_INLINE OP *
2926 S_ft_return_true(pTHX_ SV *ret) {
2928 if (PL_op->op_flags & OPf_REF)
2929 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
2930 else if (!(PL_op->op_private & OPpFT_STACKING))
2936 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
2937 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
2938 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
2940 #define tryAMAGICftest_MG(chr) STMT_START { \
2941 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
2942 && PL_op->op_flags & OPf_KIDS) { \
2943 OP *next = S_try_amagic_ftest(aTHX_ chr); \
2944 if (next) return next; \
2949 S_try_amagic_ftest(pTHX_ char chr) {
2951 SV *const arg = *PL_stack_sp;
2954 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
2958 const char tmpchr = chr;
2959 SV * const tmpsv = amagic_call(arg,
2960 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2961 ftest_amg, AMGf_unary);
2966 return SvTRUE(tmpsv)
2967 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
2977 /* Not const, because things tweak this below. Not bool, because there's
2978 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2979 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2980 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2981 /* Giving some sort of initial value silences compilers. */
2983 int access_mode = R_OK;
2985 int access_mode = 0;
2988 /* access_mode is never used, but leaving use_access in makes the
2989 conditional compiling below much clearer. */
2992 Mode_t stat_mode = S_IRUSR;
2994 bool effective = FALSE;
2997 switch (PL_op->op_type) {
2998 case OP_FTRREAD: opchar = 'R'; break;
2999 case OP_FTRWRITE: opchar = 'W'; break;
3000 case OP_FTREXEC: opchar = 'X'; break;
3001 case OP_FTEREAD: opchar = 'r'; break;
3002 case OP_FTEWRITE: opchar = 'w'; break;
3003 case OP_FTEEXEC: opchar = 'x'; break;
3005 tryAMAGICftest_MG(opchar);
3007 switch (PL_op->op_type) {
3009 #if !(defined(HAS_ACCESS) && defined(R_OK))
3015 #if defined(HAS_ACCESS) && defined(W_OK)
3020 stat_mode = S_IWUSR;
3024 #if defined(HAS_ACCESS) && defined(X_OK)
3029 stat_mode = S_IXUSR;
3033 #ifdef PERL_EFF_ACCESS
3036 stat_mode = S_IWUSR;
3040 #ifndef PERL_EFF_ACCESS
3047 #ifdef PERL_EFF_ACCESS
3052 stat_mode = S_IXUSR;
3058 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3059 const char *name = SvPV_nolen(*PL_stack_sp);
3061 # ifdef PERL_EFF_ACCESS
3062 result = PERL_EFF_ACCESS(name, access_mode);
3064 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3070 result = access(name, access_mode);
3072 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3083 result = my_stat_flags(0);
3086 if (cando(stat_mode, effective, &PL_statcache))
3095 const int op_type = PL_op->op_type;
3099 case OP_FTIS: opchar = 'e'; break;
3100 case OP_FTSIZE: opchar = 's'; break;
3101 case OP_FTMTIME: opchar = 'M'; break;
3102 case OP_FTCTIME: opchar = 'C'; break;
3103 case OP_FTATIME: opchar = 'A'; break;
3105 tryAMAGICftest_MG(opchar);
3107 result = my_stat_flags(0);
3110 if (op_type == OP_FTIS)
3113 /* You can't dTARGET inside OP_FTIS, because you'll get
3114 "panic: pad_sv po" - the op is not flagged to have a target. */
3118 #if Off_t_size > IVSIZE
3119 sv_setnv(TARG, (NV)PL_statcache.st_size);
3121 sv_setiv(TARG, (IV)PL_statcache.st_size);
3126 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3130 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3134 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3138 return SvTRUE_nomg(TARG)
3139 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3149 switch (PL_op->op_type) {
3150 case OP_FTROWNED: opchar = 'O'; break;
3151 case OP_FTEOWNED: opchar = 'o'; break;
3152 case OP_FTZERO: opchar = 'z'; break;
3153 case OP_FTSOCK: opchar = 'S'; break;
3154 case OP_FTCHR: opchar = 'c'; break;
3155 case OP_FTBLK: opchar = 'b'; break;
3156 case OP_FTFILE: opchar = 'f'; break;
3157 case OP_FTDIR: opchar = 'd'; break;
3158 case OP_FTPIPE: opchar = 'p'; break;
3159 case OP_FTSUID: opchar = 'u'; break;
3160 case OP_FTSGID: opchar = 'g'; break;
3161 case OP_FTSVTX: opchar = 'k'; break;
3163 tryAMAGICftest_MG(opchar);
3165 /* I believe that all these three are likely to be defined on most every
3166 system these days. */
3168 if(PL_op->op_type == OP_FTSUID) {
3173 if(PL_op->op_type == OP_FTSGID) {
3178 if(PL_op->op_type == OP_FTSVTX) {
3183 result = my_stat_flags(0);
3186 switch (PL_op->op_type) {
3188 if (PL_statcache.st_uid == PerlProc_getuid())
3192 if (PL_statcache.st_uid == PerlProc_geteuid())
3196 if (PL_statcache.st_size == 0)
3200 if (S_ISSOCK(PL_statcache.st_mode))
3204 if (S_ISCHR(PL_statcache.st_mode))
3208 if (S_ISBLK(PL_statcache.st_mode))
3212 if (S_ISREG(PL_statcache.st_mode))
3216 if (S_ISDIR(PL_statcache.st_mode))
3220 if (S_ISFIFO(PL_statcache.st_mode))
3225 if (PL_statcache.st_mode & S_ISUID)
3231 if (PL_statcache.st_mode & S_ISGID)
3237 if (PL_statcache.st_mode & S_ISVTX)
3250 tryAMAGICftest_MG('l');
3251 result = my_lstat_flags(0);
3255 if (S_ISLNK(PL_statcache.st_mode))
3268 tryAMAGICftest_MG('t');
3270 if (PL_op->op_flags & OPf_REF)
3273 SV *tmpsv = *PL_stack_sp;
3274 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3275 name = SvPV_nomg(tmpsv, namelen);
3276 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3280 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3281 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3282 else if (name && isDIGIT(*name))
3286 if (PerlLIO_isatty(fd))
3304 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3306 if (PL_op->op_flags & OPf_REF)
3308 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3313 gv = MAYBE_DEREF_GV_nomg(sv);
3317 if (gv == PL_defgv) {
3319 io = SvTYPE(PL_statgv) == SVt_PVIO
3323 goto really_filename;
3328 sv_setpvs(PL_statname, "");
3329 io = GvIO(PL_statgv);
3331 PL_laststatval = -1;
3332 PL_laststype = OP_STAT;
3333 if (io && IoIFP(io)) {
3334 if (! PerlIO_has_base(IoIFP(io)))
3335 DIE(aTHX_ "-T and -B not implemented on filehandles");
3336 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3337 if (PL_laststatval < 0)
3339 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3340 if (PL_op->op_type == OP_FTTEXT)
3345 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3346 i = PerlIO_getc(IoIFP(io));
3348 (void)PerlIO_ungetc(IoIFP(io),i);
3350 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3352 len = PerlIO_get_bufsiz(IoIFP(io));
3353 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3354 /* sfio can have large buffers - limit to 512 */
3359 SETERRNO(EBADF,RMS_IFI);
3361 SETERRNO(EBADF,RMS_IFI);
3366 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3369 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3371 PL_laststatval = -1;
3372 PL_laststype = OP_STAT;
3374 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3376 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3379 PL_laststype = OP_STAT;
3380 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3381 if (PL_laststatval < 0) {
3382 (void)PerlIO_close(fp);
3385 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3386 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3387 (void)PerlIO_close(fp);
3389 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3390 FT_RETURNNO; /* special case NFS directories */
3391 FT_RETURNYES; /* null file is anything */
3396 /* now scan s to look for textiness */
3397 /* XXX ASCII dependent code */
3399 #if defined(DOSISH) || defined(USEMYBINMODE)
3400 /* ignore trailing ^Z on short files */
3401 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3405 for (i = 0; i < len; i++, s++) {
3406 if (!*s) { /* null never allowed in text */
3411 else if (!(isPRINT(*s) || isSPACE(*s)))
3414 else if (*s & 128) {
3416 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3419 /* utf8 characters don't count as odd */
3420 if (UTF8_IS_START(*s)) {
3421 int ulen = UTF8SKIP(s);
3422 if (ulen < len - i) {
3424 for (j = 1; j < ulen; j++) {
3425 if (!UTF8_IS_CONTINUATION(s[j]))
3428 --ulen; /* loop does extra increment */
3438 *s != '\n' && *s != '\r' && *s != '\b' &&
3439 *s != '\t' && *s != '\f' && *s != 27)
3444 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3455 const char *tmps = NULL;
3459 SV * const sv = POPs;
3460 if (PL_op->op_flags & OPf_SPECIAL) {
3461 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3463 else if (!(gv = MAYBE_DEREF_GV(sv)))
3464 tmps = SvPV_nomg_const_nolen(sv);
3467 if( !gv && (!tmps || !*tmps) ) {
3468 HV * const table = GvHVn(PL_envgv);
3471 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3472 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3474 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3479 deprecate("chdir('') or chdir(undef) as chdir()");
3480 tmps = SvPV_nolen_const(*svp);
3484 TAINT_PROPER("chdir");
3489 TAINT_PROPER("chdir");
3492 IO* const io = GvIO(gv);
3495 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3496 } else if (IoIFP(io)) {
3497 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3501 SETERRNO(EBADF, RMS_IFI);
3507 SETERRNO(EBADF,RMS_IFI);
3511 DIE(aTHX_ PL_no_func, "fchdir");
3515 PUSHi( PerlDir_chdir(tmps) >= 0 );
3517 /* Clear the DEFAULT element of ENV so we'll get the new value
3519 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3526 dVAR; dSP; dMARK; dTARGET;
3527 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3538 char * const tmps = POPpx;
3539 TAINT_PROPER("chroot");
3540 PUSHi( chroot(tmps) >= 0 );
3543 DIE(aTHX_ PL_no_func, "chroot");
3551 const char * const tmps2 = POPpconstx;
3552 const char * const tmps = SvPV_nolen_const(TOPs);
3553 TAINT_PROPER("rename");
3555 anum = PerlLIO_rename(tmps, tmps2);
3557 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3558 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3561 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3562 (void)UNLINK(tmps2);
3563 if (!(anum = link(tmps, tmps2)))
3564 anum = UNLINK(tmps);
3572 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3576 const int op_type = PL_op->op_type;
3580 if (op_type == OP_LINK)
3581 DIE(aTHX_ PL_no_func, "link");
3583 # ifndef HAS_SYMLINK
3584 if (op_type == OP_SYMLINK)
3585 DIE(aTHX_ PL_no_func, "symlink");
3589 const char * const tmps2 = POPpconstx;
3590 const char * const tmps = SvPV_nolen_const(TOPs);
3591 TAINT_PROPER(PL_op_desc[op_type]);
3593 # if defined(HAS_LINK)
3594 # if defined(HAS_SYMLINK)
3595 /* Both present - need to choose which. */
3596 (op_type == OP_LINK) ?
3597 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3599 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3600 PerlLIO_link(tmps, tmps2);
3603 # if defined(HAS_SYMLINK)
3604 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3605 symlink(tmps, tmps2);
3610 SETi( result >= 0 );
3617 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3628 char buf[MAXPATHLEN];
3631 #ifndef INCOMPLETE_TAINTS
3635 len = readlink(tmps, buf, sizeof(buf) - 1);
3642 RETSETUNDEF; /* just pretend it's a normal file */
3646 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3648 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3650 char * const save_filename = filename;
3655 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3657 PERL_ARGS_ASSERT_DOONELINER;
3659 Newx(cmdline, size, char);
3660 my_strlcpy(cmdline, cmd, size);
3661 my_strlcat(cmdline, " ", size);
3662 for (s = cmdline + strlen(cmdline); *filename; ) {
3666 if (s - cmdline < size)
3667 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3668 myfp = PerlProc_popen(cmdline, "r");
3672 SV * const tmpsv = sv_newmortal();
3673 /* Need to save/restore 'PL_rs' ?? */
3674 s = sv_gets(tmpsv, myfp, 0);
3675 (void)PerlProc_pclose(myfp);
3679 #ifdef HAS_SYS_ERRLIST
3684 /* you don't see this */
3685 const char * const errmsg =
3686 #ifdef HAS_SYS_ERRLIST
3694 if (instr(s, errmsg)) {
3701 #define EACCES EPERM
3703 if (instr(s, "cannot make"))
3704 SETERRNO(EEXIST,RMS_FEX);
3705 else if (instr(s, "existing file"))
3706 SETERRNO(EEXIST,RMS_FEX);
3707 else if (instr(s, "ile exists"))
3708 SETERRNO(EEXIST,RMS_FEX);
3709 else if (instr(s, "non-exist"))
3710 SETERRNO(ENOENT,RMS_FNF);
3711 else if (instr(s, "does not exist"))
3712 SETERRNO(ENOENT,RMS_FNF);
3713 else if (instr(s, "not empty"))
3714 SETERRNO(EBUSY,SS_DEVOFFLINE);
3715 else if (instr(s, "cannot access"))
3716 SETERRNO(EACCES,RMS_PRV);
3718 SETERRNO(EPERM,RMS_PRV);
3721 else { /* some mkdirs return no failure indication */
3722 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3723 if (PL_op->op_type == OP_RMDIR)
3728 SETERRNO(EACCES,RMS_PRV); /* a guess */
3737 /* This macro removes trailing slashes from a directory name.
3738 * Different operating and file systems take differently to
3739 * trailing slashes. According to POSIX 1003.1 1996 Edition
3740 * any number of trailing slashes should be allowed.
3741 * Thusly we snip them away so that even non-conforming
3742 * systems are happy.
3743 * We should probably do this "filtering" for all
3744 * the functions that expect (potentially) directory names:
3745 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3746 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3748 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3749 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3752 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3753 (tmps) = savepvn((tmps), (len)); \
3763 const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3765 TRIMSLASHES(tmps,len,copy);
3767 TAINT_PROPER("mkdir");
3769 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3773 SETi( dooneliner("mkdir", tmps) );
3774 oldumask = PerlLIO_umask(0);
3775 PerlLIO_umask(oldumask);
3776 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3791 TRIMSLASHES(tmps,len,copy);
3792 TAINT_PROPER("rmdir");
3794 SETi( PerlDir_rmdir(tmps) >= 0 );
3796 SETi( dooneliner("rmdir", tmps) );
3803 /* Directory calls. */
3807 #if defined(Direntry_t) && defined(HAS_READDIR)
3809 const char * const dirname = POPpconstx;
3810 GV * const gv = MUTABLE_GV(POPs);
3811 IO * const io = GvIOn(gv);
3816 if ((IoIFP(io) || IoOFP(io)))
3817 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3818 "Opening filehandle %"HEKf" also as a directory",
3819 HEKfARG(GvENAME_HEK(gv)) );
3821 PerlDir_close(IoDIRP(io));
3822 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3828 SETERRNO(EBADF,RMS_DIR);
3831 DIE(aTHX_ PL_no_dir_func, "opendir");
3837 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3838 DIE(aTHX_ PL_no_dir_func, "readdir");
3840 #if !defined(I_DIRENT) && !defined(VMS)
3841 Direntry_t *readdir (DIR *);
3847 const I32 gimme = GIMME;
3848 GV * const gv = MUTABLE_GV(POPs);
3849 const Direntry_t *dp;
3850 IO * const io = GvIOn(gv);
3852 if (!io || !IoDIRP(io)) {
3853 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3854 "readdir() attempted on invalid dirhandle %"HEKf,
3855 HEKfARG(GvENAME_HEK(gv)));
3860 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3864 sv = newSVpvn(dp->d_name, dp->d_namlen);
3866 sv = newSVpv(dp->d_name, 0);
3868 #ifndef INCOMPLETE_TAINTS
3869 if (!(IoFLAGS(io) & IOf_UNTAINT))
3873 } while (gimme == G_ARRAY);
3875 if (!dp && gimme != G_ARRAY)
3882 SETERRNO(EBADF,RMS_ISI);
3883 if (GIMME == G_ARRAY)
3892 #if defined(HAS_TELLDIR) || defined(telldir)
3894 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3895 /* XXX netbsd still seemed to.
3896 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3897 --JHI 1999-Feb-02 */
3898 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3899 long telldir (DIR *);
3901 GV * const gv = MUTABLE_GV(POPs);
3902 IO * const io = GvIOn(gv);
3904 if (!io || !IoDIRP(io)) {
3905 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3906 "telldir() attempted on invalid dirhandle %"HEKf,
3907 HEKfARG(GvENAME_HEK(gv)));
3911 PUSHi( PerlDir_tell(IoDIRP(io)) );
3915 SETERRNO(EBADF,RMS_ISI);
3918 DIE(aTHX_ PL_no_dir_func, "telldir");
3924 #if defined(HAS_SEEKDIR) || defined(seekdir)
3926 const long along = POPl;
3927 GV * const gv = MUTABLE_GV(POPs);
3928 IO * const io = GvIOn(gv);
3930 if (!io || !IoDIRP(io)) {
3931 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3932 "seekdir() attempted on invalid dirhandle %"HEKf,
3933 HEKfARG(GvENAME_HEK(gv)));
3936 (void)PerlDir_seek(IoDIRP(io), along);
3941 SETERRNO(EBADF,RMS_ISI);
3944 DIE(aTHX_ PL_no_dir_func, "seekdir");
3950 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3952 GV * const gv = MUTABLE_GV(POPs);
3953 IO * const io = GvIOn(gv);
3955 if (!io || !IoDIRP(io)) {
3956 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3957 "rewinddir() attempted on invalid dirhandle %"HEKf,
3958 HEKfARG(GvENAME_HEK(gv)));
3961 (void)PerlDir_rewind(IoDIRP(io));
3965 SETERRNO(EBADF,RMS_ISI);
3968 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3974 #if defined(Direntry_t) && defined(HAS_READDIR)
3976 GV * const gv = MUTABLE_GV(POPs);
3977 IO * const io = GvIOn(gv);
3979 if (!io || !IoDIRP(io)) {
3980 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3981 "closedir() attempted on invalid dirhandle %"HEKf,
3982 HEKfARG(GvENAME_HEK(gv)));
3985 #ifdef VOID_CLOSEDIR
3986 PerlDir_close(IoDIRP(io));
3988 if (PerlDir_close(IoDIRP(io)) < 0) {
3989 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3998 SETERRNO(EBADF,RMS_IFI);
4001 DIE(aTHX_ PL_no_dir_func, "closedir");
4005 /* Process control. */
4012 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4013 sigset_t oldmask, newmask;
4017 PERL_FLUSHALL_FOR_CHILD;
4018 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4019 sigfillset(&newmask);
4020 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4022 childpid = PerlProc_fork();
4023 if (childpid == 0) {
4027 for (sig = 1; sig < SIG_SIZE; sig++)
4028 PL_psig_pend[sig] = 0;
4030 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4033 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4040 #ifdef PERL_USES_PL_PIDSTATUS
4041 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4047 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4052 PERL_FLUSHALL_FOR_CHILD;
4053 childpid = PerlProc_fork();
4059 DIE(aTHX_ PL_no_func, "fork");
4066 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4071 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4072 childpid = wait4pid(-1, &argflags, 0);
4074 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4079 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4080 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4081 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4083 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4088 DIE(aTHX_ PL_no_func, "wait");
4094 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4096 const int optype = POPi;
4097 const Pid_t pid = TOPi;
4101 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4102 result = wait4pid(pid, &argflags, optype);
4104 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4109 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4110 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4111 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4113 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4118 DIE(aTHX_ PL_no_func, "waitpid");
4124 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4125 #if defined(__LIBCATAMOUNT__)
4126 PL_statusvalue = -1;
4135 while (++MARK <= SP) {
4136 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4141 TAINT_PROPER("system");
4143 PERL_FLUSHALL_FOR_CHILD;
4144 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4149 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4150 sigset_t newset, oldset;
4153 if (PerlProc_pipe(pp) >= 0)
4155 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4156 sigemptyset(&newset);
4157 sigaddset(&newset, SIGCHLD);
4158 sigprocmask(SIG_BLOCK, &newset, &oldset);
4160 while ((childpid = PerlProc_fork()) == -1) {
4161 if (errno != EAGAIN) {
4166 PerlLIO_close(pp[0]);
4167 PerlLIO_close(pp[1]);
4169 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4170 sigprocmask(SIG_SETMASK, &oldset, NULL);
4177 Sigsave_t ihand,qhand; /* place to save signals during system() */
4181 PerlLIO_close(pp[1]);
4183 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4184 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4187 result = wait4pid(childpid, &status, 0);
4188 } while (result == -1 && errno == EINTR);
4190 #ifdef HAS_SIGPROCMASK
4191 sigprocmask(SIG_SETMASK, &oldset, NULL);
4193 (void)rsignal_restore(SIGINT, &ihand);
4194 (void)rsignal_restore(SIGQUIT, &qhand);
4196 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4197 do_execfree(); /* free any memory child malloced on fork */
4204 while (n < sizeof(int)) {
4205 n1 = PerlLIO_read(pp[0],
4206 (void*)(((char*)&errkid)+n),
4212 PerlLIO_close(pp[0]);
4213 if (n) { /* Error */
4214 if (n != sizeof(int))
4215 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4216 errno = errkid; /* Propagate errno from kid */
4217 STATUS_NATIVE_CHILD_SET(-1);
4220 XPUSHi(STATUS_CURRENT);
4223 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4224 sigprocmask(SIG_SETMASK, &oldset, NULL);
4227 PerlLIO_close(pp[0]);
4228 #if defined(HAS_FCNTL) && defined(F_SETFD)
4229 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4232 if (PL_op->op_flags & OPf_STACKED) {
4233 SV * const really = *++MARK;
4234 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4236 else if (SP - MARK != 1)
4237 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4239 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4243 #else /* ! FORK or VMS or OS/2 */
4246 if (PL_op->op_flags & OPf_STACKED) {
4247 SV * const really = *++MARK;
4248 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4249 value = (I32)do_aspawn(really, MARK, SP);
4251 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4254 else if (SP - MARK != 1) {
4255 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4256 value = (I32)do_aspawn(NULL, MARK, SP);
4258 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4262 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4264 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4266 STATUS_NATIVE_CHILD_SET(value);
4269 XPUSHi(result ? value : STATUS_CURRENT);
4270 #endif /* !FORK or VMS or OS/2 */
4277 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4282 while (++MARK <= SP) {
4283 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4288 TAINT_PROPER("exec");
4290 PERL_FLUSHALL_FOR_CHILD;
4291 if (PL_op->op_flags & OPf_STACKED) {
4292 SV * const really = *++MARK;
4293 value = (I32)do_aexec(really, MARK, SP);
4295 else if (SP - MARK != 1)
4297 value = (I32)vms_do_aexec(NULL, MARK, SP);
4299 value = (I32)do_aexec(NULL, MARK, SP);
4303 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4305 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4318 XPUSHi( getppid() );
4321 DIE(aTHX_ PL_no_func, "getppid");
4331 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4334 pgrp = (I32)BSD_GETPGRP(pid);
4336 if (pid != 0 && pid != PerlProc_getpid())
4337 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4343 DIE(aTHX_ PL_no_func, "getpgrp()");
4353 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4354 if (MAXARG > 0) pid = TOPs && TOPi;
4360 TAINT_PROPER("setpgrp");
4362 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4364 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4365 || (pid != 0 && pid != PerlProc_getpid()))
4367 DIE(aTHX_ "setpgrp can't take arguments");
4369 SETi( setpgrp() >= 0 );
4370 #endif /* USE_BSDPGRP */
4373 DIE(aTHX_ PL_no_func, "setpgrp()");
4377 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4378 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4380 # define PRIORITY_WHICH_T(which) which
4385 #ifdef HAS_GETPRIORITY
4387 const int who = POPi;
4388 const int which = TOPi;
4389 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4392 DIE(aTHX_ PL_no_func, "getpriority()");
4398 #ifdef HAS_SETPRIORITY
4400 const int niceval = POPi;
4401 const int who = POPi;
4402 const int which = TOPi;
4403 TAINT_PROPER("setpriority");
4404 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4407 DIE(aTHX_ PL_no_func, "setpriority()");
4411 #undef PRIORITY_WHICH_T
4419 XPUSHn( time(NULL) );
4421 XPUSHi( time(NULL) );
4433 (void)PerlProc_times(&PL_timesbuf);
4435 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4436 /* struct tms, though same data */
4440 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4441 if (GIMME == G_ARRAY) {
4442 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4443 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4444 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4452 if (GIMME == G_ARRAY) {
4459 DIE(aTHX_ "times not implemented");
4461 #endif /* HAS_TIMES */
4464 /* The 32 bit int year limits the times we can represent to these
4465 boundaries with a few days wiggle room to account for time zone
4468 /* Sat Jan 3 00:00:00 -2147481748 */
4469 #define TIME_LOWER_BOUND -67768100567755200.0
4470 /* Sun Dec 29 12:00:00 2147483647 */
4471 #define TIME_UPPER_BOUND 67767976233316800.0
4480 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4481 static const char * const dayname[] =
4482 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4483 static const char * const monname[] =
4484 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4485 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4487 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4490 when = (Time64_T)now;
4493 NV input = Perl_floor(POPn);
4494 when = (Time64_T)input;
4495 if (when != input) {
4496 /* diag_listed_as: gmtime(%f) too large */
4497 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4498 "%s(%.0" NVff ") too large", opname, input);
4502 if ( TIME_LOWER_BOUND > when ) {
4503 /* diag_listed_as: gmtime(%f) too small */
4504 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4505 "%s(%.0" NVff ") too small", opname, when);
4508 else if( when > TIME_UPPER_BOUND ) {
4509 /* diag_listed_as: gmtime(%f) too small */
4510 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4511 "%s(%.0" NVff ") too large", opname, when);
4515 if (PL_op->op_type == OP_LOCALTIME)
4516 err = S_localtime64_r(&when, &tmbuf);
4518 err = S_gmtime64_r(&when, &tmbuf);
4522 /* XXX %lld broken for quads */
4523 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4524 "%s(%.0" NVff ") failed", opname, when);
4527 if (GIMME != G_ARRAY) { /* scalar context */
4529 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4530 double year = (double)tmbuf.tm_year + 1900;
4537 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4538 dayname[tmbuf.tm_wday],
4539 monname[tmbuf.tm_mon],
4547 else { /* list context */
4553 mPUSHi(tmbuf.tm_sec);
4554 mPUSHi(tmbuf.tm_min);
4555 mPUSHi(tmbuf.tm_hour);
4556 mPUSHi(tmbuf.tm_mday);
4557 mPUSHi(tmbuf.tm_mon);
4558 mPUSHn(tmbuf.tm_year);
4559 mPUSHi(tmbuf.tm_wday);
4560 mPUSHi(tmbuf.tm_yday);
4561 mPUSHi(tmbuf.tm_isdst);
4572 anum = alarm((unsigned int)anum);
4578 DIE(aTHX_ PL_no_func, "alarm");
4589 (void)time(&lasttime);
4590 if (MAXARG < 1 || (!TOPs && !POPs))
4594 PerlProc_sleep((unsigned int)duration);
4597 XPUSHi(when - lasttime);
4601 /* Shared memory. */
4602 /* Merged with some message passing. */
4606 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4607 dVAR; dSP; dMARK; dTARGET;
4608 const int op_type = PL_op->op_type;
4613 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4616 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4619 value = (I32)(do_semop(MARK, SP) >= 0);
4622 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4630 return Perl_pp_semget(aTHX);
4638 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4639 dVAR; dSP; dMARK; dTARGET;
4640 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4647 DIE(aTHX_ "System V IPC is not implemented on this machine");
4653 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4654 dVAR; dSP; dMARK; dTARGET;
4655 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4663 PUSHp(zero_but_true, ZBTLEN);
4667 return Perl_pp_semget(aTHX);
4671 /* I can't const this further without getting warnings about the types of
4672 various arrays passed in from structures. */
4674 S_space_join_names_mortal(pTHX_ char *const *array)
4678 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4680 if (array && *array) {
4681 target = newSVpvs_flags("", SVs_TEMP);
4683 sv_catpv(target, *array);
4686 sv_catpvs(target, " ");
4689 target = sv_mortalcopy(&PL_sv_no);
4694 /* Get system info. */
4698 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4700 I32 which = PL_op->op_type;
4703 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4704 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4705 struct hostent *gethostbyname(Netdb_name_t);
4706 struct hostent *gethostent(void);
4708 struct hostent *hent = NULL;
4712 if (which == OP_GHBYNAME) {
4713 #ifdef HAS_GETHOSTBYNAME
4714 const char* const name = POPpbytex;
4715 hent = PerlSock_gethostbyname(name);
4717 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4720 else if (which == OP_GHBYADDR) {
4721 #ifdef HAS_GETHOSTBYADDR
4722 const int addrtype = POPi;
4723 SV * const addrsv = POPs;
4725 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4727 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4729 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4733 #ifdef HAS_GETHOSTENT
4734 hent = PerlSock_gethostent();
4736 DIE(aTHX_ PL_no_sock_func, "gethostent");
4739 #ifdef HOST_NOT_FOUND
4741 #ifdef USE_REENTRANT_API
4742 # ifdef USE_GETHOSTENT_ERRNO
4743 h_errno = PL_reentrant_buffer->_gethostent_errno;
4746 STATUS_UNIX_SET(h_errno);
4750 if (GIMME != G_ARRAY) {
4751 PUSHs(sv = sv_newmortal());
4753 if (which == OP_GHBYNAME) {
4755 sv_setpvn(sv, hent->h_addr, hent->h_length);
4758 sv_setpv(sv, (char*)hent->h_name);
4764 mPUSHs(newSVpv((char*)hent->h_name, 0));
4765 PUSHs(space_join_names_mortal(hent->h_aliases));
4766 mPUSHi(hent->h_addrtype);
4767 len = hent->h_length;
4770 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4771 mXPUSHp(*elem, len);
4775 mPUSHp(hent->h_addr, len);
4777 PUSHs(sv_mortalcopy(&PL_sv_no));
4782 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4788 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4790 I32 which = PL_op->op_type;
4792 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4793 struct netent *getnetbyaddr(Netdb_net_t, int);
4794 struct netent *getnetbyname(Netdb_name_t);
4795 struct netent *getnetent(void);
4797 struct netent *nent;
4799 if (which == OP_GNBYNAME){
4800 #ifdef HAS_GETNETBYNAME
4801 const char * const name = POPpbytex;
4802 nent = PerlSock_getnetbyname(name);
4804 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4807 else if (which == OP_GNBYADDR) {
4808 #ifdef HAS_GETNETBYADDR
4809 const int addrtype = POPi;
4810 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4811 nent = PerlSock_getnetbyaddr(addr, addrtype);
4813 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4817 #ifdef HAS_GETNETENT
4818 nent = PerlSock_getnetent();
4820 DIE(aTHX_ PL_no_sock_func, "getnetent");
4823 #ifdef HOST_NOT_FOUND
4825 #ifdef USE_REENTRANT_API
4826 # ifdef USE_GETNETENT_ERRNO
4827 h_errno = PL_reentrant_buffer->_getnetent_errno;
4830 STATUS_UNIX_SET(h_errno);
4835 if (GIMME != G_ARRAY) {
4836 PUSHs(sv = sv_newmortal());
4838 if (which == OP_GNBYNAME)
4839 sv_setiv(sv, (IV)nent->n_net);
4841 sv_setpv(sv, nent->n_name);
4847 mPUSHs(newSVpv(nent->n_name, 0));
4848 PUSHs(space_join_names_mortal(nent->n_aliases));
4849 mPUSHi(nent->n_addrtype);
4850 mPUSHi(nent->n_net);
4855 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4861 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4863 I32 which = PL_op->op_type;
4865 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4866 struct protoent *getprotobyname(Netdb_name_t);
4867 struct protoent *getprotobynumber(int);
4868 struct protoent *getprotoent(void);
4870 struct protoent *pent;
4872 if (which == OP_GPBYNAME) {
4873 #ifdef HAS_GETPROTOBYNAME
4874 const char* const name = POPpbytex;
4875 pent = PerlSock_getprotobyname(name);
4877 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4880 else if (which == OP_GPBYNUMBER) {
4881 #ifdef HAS_GETPROTOBYNUMBER
4882 const int number = POPi;
4883 pent = PerlSock_getprotobynumber(number);
4885 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4889 #ifdef HAS_GETPROTOENT
4890 pent = PerlSock_getprotoent();
4892 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4896 if (GIMME != G_ARRAY) {
4897 PUSHs(sv = sv_newmortal());
4899 if (which == OP_GPBYNAME)
4900 sv_setiv(sv, (IV)pent->p_proto);
4902 sv_setpv(sv, pent->p_name);
4908 mPUSHs(newSVpv(pent->p_name, 0));
4909 PUSHs(space_join_names_mortal(pent->p_aliases));
4910 mPUSHi(pent->p_proto);
4915 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4921 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4923 I32 which = PL_op->op_type;
4925 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4926 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4927 struct servent *getservbyport(int, Netdb_name_t);
4928 struct servent *getservent(void);
4930 struct servent *sent;
4932 if (which == OP_GSBYNAME) {
4933 #ifdef HAS_GETSERVBYNAME
4934 const char * const proto = POPpbytex;
4935 const char * const name = POPpbytex;
4936 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4938 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4941 else if (which == OP_GSBYPORT) {
4942 #ifdef HAS_GETSERVBYPORT
4943 const char * const proto = POPpbytex;
4944 unsigned short port = (unsigned short)POPu;
4946 port = PerlSock_htons(port);
4948 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4950 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4954 #ifdef HAS_GETSERVENT
4955 sent = PerlSock_getservent();
4957 DIE(aTHX_ PL_no_sock_func, "getservent");
4961 if (GIMME != G_ARRAY) {
4962 PUSHs(sv = sv_newmortal());
4964 if (which == OP_GSBYNAME) {
4966 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4968 sv_setiv(sv, (IV)(sent->s_port));
4972 sv_setpv(sv, sent->s_name);
4978 mPUSHs(newSVpv(sent->s_name, 0));
4979 PUSHs(space_join_names_mortal(sent->s_aliases));
4981 mPUSHi(PerlSock_ntohs(sent->s_port));
4983 mPUSHi(sent->s_port);
4985 mPUSHs(newSVpv(sent->s_proto, 0));
4990 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4997 const int stayopen = TOPi;
4998 switch(PL_op->op_type) {
5000 #ifdef HAS_SETHOSTENT
5001 PerlSock_sethostent(stayopen);
5003 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5006 #ifdef HAS_SETNETENT
5008 PerlSock_setnetent(stayopen);
5010 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5014 #ifdef HAS_SETPROTOENT
5015 PerlSock_setprotoent(stayopen);
5017 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5021 #ifdef HAS_SETSERVENT
5022 PerlSock_setservent(stayopen);
5024 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5034 switch(PL_op->op_type) {
5036 #ifdef HAS_ENDHOSTENT
5037 PerlSock_endhostent();
5039 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5043 #ifdef HAS_ENDNETENT
5044 PerlSock_endnetent();
5046 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5050 #ifdef HAS_ENDPROTOENT
5051 PerlSock_endprotoent();
5053 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5057 #ifdef HAS_ENDSERVENT
5058 PerlSock_endservent();
5060 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5064 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5067 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5071 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5074 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5078 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5081 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5085 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5088 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5100 I32 which = PL_op->op_type;
5102 struct passwd *pwent = NULL;
5104 * We currently support only the SysV getsp* shadow password interface.
5105 * The interface is declared in <shadow.h> and often one needs to link
5106 * with -lsecurity or some such.
5107 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5110 * AIX getpwnam() is clever enough to return the encrypted password
5111 * only if the caller (euid?) is root.
5113 * There are at least three other shadow password APIs. Many platforms
5114 * seem to contain more than one interface for accessing the shadow
5115 * password databases, possibly for compatibility reasons.
5116 * The getsp*() is by far he simplest one, the other two interfaces
5117 * are much more complicated, but also very similar to each other.
5122 * struct pr_passwd *getprpw*();
5123 * The password is in
5124 * char getprpw*(...).ufld.fd_encrypt[]
5125 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5130 * struct es_passwd *getespw*();
5131 * The password is in
5132 * char *(getespw*(...).ufld.fd_encrypt)
5133 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5136 * struct userpw *getuserpw();
5137 * The password is in
5138 * char *(getuserpw(...)).spw_upw_passwd
5139 * (but the de facto standard getpwnam() should work okay)
5141 * Mention I_PROT here so that Configure probes for it.
5143 * In HP-UX for getprpw*() the manual page claims that one should include
5144 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5145 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5146 * and pp_sys.c already includes <shadow.h> if there is such.
5148 * Note that <sys/security.h> is already probed for, but currently
5149 * it is only included in special cases.
5151 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5152 * be preferred interface, even though also the getprpw*() interface
5153 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5154 * One also needs to call set_auth_parameters() in main() before
5155 * doing anything else, whether one is using getespw*() or getprpw*().
5157 * Note that accessing the shadow databases can be magnitudes
5158 * slower than accessing the standard databases.
5163 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5164 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5165 * the pw_comment is left uninitialized. */
5166 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5172 const char* const name = POPpbytex;
5173 pwent = getpwnam(name);
5179 pwent = getpwuid(uid);
5183 # ifdef HAS_GETPWENT
5185 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5186 if (pwent) pwent = getpwnam(pwent->pw_name);
5189 DIE(aTHX_ PL_no_func, "getpwent");
5195 if (GIMME != G_ARRAY) {
5196 PUSHs(sv = sv_newmortal());
5198 if (which == OP_GPWNAM)
5199 # if Uid_t_sign <= 0
5200 sv_setiv(sv, (IV)pwent->pw_uid);
5202 sv_setuv(sv, (UV)pwent->pw_uid);
5205 sv_setpv(sv, pwent->pw_name);
5211 mPUSHs(newSVpv(pwent->pw_name, 0));
5215 /* If we have getspnam(), we try to dig up the shadow
5216 * password. If we are underprivileged, the shadow
5217 * interface will set the errno to EACCES or similar,
5218 * and return a null pointer. If this happens, we will
5219 * use the dummy password (usually "*" or "x") from the
5220 * standard password database.
5222 * In theory we could skip the shadow call completely
5223 * if euid != 0 but in practice we cannot know which
5224 * security measures are guarding the shadow databases
5225 * on a random platform.
5227 * Resist the urge to use additional shadow interfaces.
5228 * Divert the urge to writing an extension instead.
5231 /* Some AIX setups falsely(?) detect some getspnam(), which
5232 * has a different API than the Solaris/IRIX one. */
5233 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5236 const struct spwd * const spwent = getspnam(pwent->pw_name);
5237 /* Save and restore errno so that
5238 * underprivileged attempts seem
5239 * to have never made the unsuccessful
5240 * attempt to retrieve the shadow password. */
5242 if (spwent && spwent->sp_pwdp)
5243 sv_setpv(sv, spwent->sp_pwdp);
5247 if (!SvPOK(sv)) /* Use the standard password, then. */
5248 sv_setpv(sv, pwent->pw_passwd);
5251 # ifndef INCOMPLETE_TAINTS
5252 /* passwd is tainted because user himself can diddle with it.
5253 * admittedly not much and in a very limited way, but nevertheless. */
5257 # if Uid_t_sign <= 0
5258 mPUSHi(pwent->pw_uid);
5260 mPUSHu(pwent->pw_uid);
5263 # if Uid_t_sign <= 0
5264 mPUSHi(pwent->pw_gid);
5266 mPUSHu(pwent->pw_gid);
5268 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5269 * because of the poor interface of the Perl getpw*(),
5270 * not because there's some standard/convention saying so.
5271 * A better interface would have been to return a hash,
5272 * but we are accursed by our history, alas. --jhi. */
5274 mPUSHi(pwent->pw_change);
5277 mPUSHi(pwent->pw_quota);
5280 mPUSHs(newSVpv(pwent->pw_age, 0));
5282 /* I think that you can never get this compiled, but just in case. */
5283 PUSHs(sv_mortalcopy(&PL_sv_no));
5288 /* pw_class and pw_comment are mutually exclusive--.
5289 * see the above note for pw_change, pw_quota, and pw_age. */
5291 mPUSHs(newSVpv(pwent->pw_class, 0));
5294 mPUSHs(newSVpv(pwent->pw_comment, 0));
5296 /* I think that you can never get this compiled, but just in case. */
5297 PUSHs(sv_mortalcopy(&PL_sv_no));
5302 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5304 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5306 # ifndef INCOMPLETE_TAINTS
5307 /* pw_gecos is tainted because user himself can diddle with it. */
5311 mPUSHs(newSVpv(pwent->pw_dir, 0));
5313 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5314 # ifndef INCOMPLETE_TAINTS
5315 /* pw_shell is tainted because user himself can diddle with it. */
5320 mPUSHi(pwent->pw_expire);
5325 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5333 const I32 which = PL_op->op_type;
5334 const struct group *grent;
5336 if (which == OP_GGRNAM) {
5337 const char* const name = POPpbytex;
5338 grent = (const struct group *)getgrnam(name);
5340 else if (which == OP_GGRGID) {
5341 const Gid_t gid = POPi;
5342 grent = (const struct group *)getgrgid(gid);
5346 grent = (struct group *)getgrent();
5348 DIE(aTHX_ PL_no_func, "getgrent");
5352 if (GIMME != G_ARRAY) {
5353 SV * const sv = sv_newmortal();
5357 if (which == OP_GGRNAM)
5359 sv_setiv(sv, (IV)grent->gr_gid);
5361 sv_setuv(sv, (UV)grent->gr_gid);
5364 sv_setpv(sv, grent->gr_name);
5370 mPUSHs(newSVpv(grent->gr_name, 0));
5373 mPUSHs(newSVpv(grent->gr_passwd, 0));
5375 PUSHs(sv_mortalcopy(&PL_sv_no));
5379 mPUSHi(grent->gr_gid);
5381 mPUSHu(grent->gr_gid);
5384 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5385 /* In UNICOS/mk (_CRAYMPP) the multithreading
5386 * versions (getgrnam_r, getgrgid_r)
5387 * seem to return an illegal pointer
5388 * as the group members list, gr_mem.
5389 * getgrent() doesn't even have a _r version
5390 * but the gr_mem is poisonous anyway.
5391 * So yes, you cannot get the list of group
5392 * members if building multithreaded in UNICOS/mk. */
5393 PUSHs(space_join_names_mortal(grent->gr_mem));
5399 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5409 if (!(tmps = PerlProc_getlogin()))
5411 sv_setpv_mg(TARG, tmps);
5415 DIE(aTHX_ PL_no_func, "getlogin");
5419 /* Miscellaneous. */
5424 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5425 I32 items = SP - MARK;
5426 unsigned long a[20];
5431 while (++MARK <= SP) {
5432 if (SvTAINTED(*MARK)) {
5438 TAINT_PROPER("syscall");
5441 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5442 * or where sizeof(long) != sizeof(char*). But such machines will
5443 * not likely have syscall implemented either, so who cares?
5445 while (++MARK <= SP) {
5446 if (SvNIOK(*MARK) || !i)
5447 a[i++] = SvIV(*MARK);
5448 else if (*MARK == &PL_sv_undef)
5451 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5457 DIE(aTHX_ "Too many args to syscall");
5459 DIE(aTHX_ "Too few args to syscall");
5461 retval = syscall(a[0]);
5464 retval = syscall(a[0],a[1]);
5467 retval = syscall(a[0],a[1],a[2]);
5470 retval = syscall(a[0],a[1],a[2],a[3]);
5473 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5476 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5479 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5482 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5489 DIE(aTHX_ PL_no_func, "syscall");
5493 #ifdef FCNTL_EMULATE_FLOCK
5495 /* XXX Emulate flock() with fcntl().
5496 What's really needed is a good file locking module.
5500 fcntl_emulate_flock(int fd, int operation)
5505 switch (operation & ~LOCK_NB) {
5507 flock.l_type = F_RDLCK;
5510 flock.l_type = F_WRLCK;
5513 flock.l_type = F_UNLCK;
5519 flock.l_whence = SEEK_SET;
5520 flock.l_start = flock.l_len = (Off_t)0;
5522 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5523 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5524 errno = EWOULDBLOCK;
5528 #endif /* FCNTL_EMULATE_FLOCK */
5530 #ifdef LOCKF_EMULATE_FLOCK
5532 /* XXX Emulate flock() with lockf(). This is just to increase
5533 portability of scripts. The calls are not completely
5534 interchangeable. What's really needed is a good file
5538 /* The lockf() constants might have been defined in <unistd.h>.
5539 Unfortunately, <unistd.h> causes troubles on some mixed
5540 (BSD/POSIX) systems, such as SunOS 4.1.3.
5542 Further, the lockf() constants aren't POSIX, so they might not be
5543 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5544 just stick in the SVID values and be done with it. Sigh.
5548 # define F_ULOCK 0 /* Unlock a previously locked region */
5551 # define F_LOCK 1 /* Lock a region for exclusive use */
5554 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5557 # define F_TEST 3 /* Test a region for other processes locks */
5561 lockf_emulate_flock(int fd, int operation)
5567 /* flock locks entire file so for lockf we need to do the same */
5568 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5569 if (pos > 0) /* is seekable and needs to be repositioned */
5570 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5571 pos = -1; /* seek failed, so don't seek back afterwards */
5574 switch (operation) {
5576 /* LOCK_SH - get a shared lock */
5578 /* LOCK_EX - get an exclusive lock */
5580 i = lockf (fd, F_LOCK, 0);
5583 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5584 case LOCK_SH|LOCK_NB:
5585 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5586 case LOCK_EX|LOCK_NB:
5587 i = lockf (fd, F_TLOCK, 0);
5589 if ((errno == EAGAIN) || (errno == EACCES))
5590 errno = EWOULDBLOCK;
5593 /* LOCK_UN - unlock (non-blocking is a no-op) */
5595 case LOCK_UN|LOCK_NB:
5596 i = lockf (fd, F_ULOCK, 0);
5599 /* Default - can't decipher operation */
5606 if (pos > 0) /* need to restore position of the handle */
5607 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5612 #endif /* LOCKF_EMULATE_FLOCK */
5616 * c-indentation-style: bsd
5618 * indent-tabs-mode: nil
5621 * ex: set ts=8 sts=4 sw=4 et: