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_ SV *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_sv(methname, (flags & G_WANT)|G_METHOD_NAMED);
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_ SV_CONST(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(SV_CONST(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(SV_CONST(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_ SV_CONST(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));
902 if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
903 vivify_defelem(varsv);
904 varsv = LvTARG(varsv);
908 methname = "TIESCALAR";
909 how = PERL_MAGIC_tiedscalar;
913 if (sv_isobject(*MARK)) { /* Calls GET magic. */
914 ENTER_with_name("call_TIE");
915 PUSHSTACKi(PERLSI_MAGIC);
917 EXTEND(SP,(I32)items);
921 call_method(methname, G_SCALAR);
924 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
925 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
926 * wrong error message, and worse case, supreme action at a distance.
927 * (Sorry obfuscation writers. You're not going to be given this one.)
929 stash = gv_stashsv(*MARK, 0);
930 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
931 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
932 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
934 ENTER_with_name("call_TIE");
935 PUSHSTACKi(PERLSI_MAGIC);
937 EXTEND(SP,(I32)items);
941 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
947 if (sv_isobject(sv)) {
948 sv_unmagic(varsv, how);
949 /* Croak if a self-tie on an aggregate is attempted. */
950 if (varsv == SvRV(sv) &&
951 (SvTYPE(varsv) == SVt_PVAV ||
952 SvTYPE(varsv) == SVt_PVHV))
954 "Self-ties of arrays and hashes are not supported");
955 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
957 LEAVE_with_name("call_TIE");
958 SP = PL_stack_base + markoff;
968 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
969 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
971 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
974 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
975 !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
977 if ((mg = SvTIED_mg(sv, how))) {
978 SV * const obj = SvRV(SvTIED_obj(sv, mg));
980 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
982 if (gv && isGV(gv) && (cv = GvCV(gv))) {
984 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
985 mXPUSHi(SvREFCNT(obj) - 1);
987 ENTER_with_name("call_UNTIE");
988 call_sv(MUTABLE_SV(cv), G_VOID);
989 LEAVE_with_name("call_UNTIE");
992 else if (mg && SvREFCNT(obj) > 1) {
993 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
994 "untie attempted while %"UVuf" inner references still exist",
995 (UV)SvREFCNT(obj) - 1 ) ;
999 sv_unmagic(sv, how) ;
1009 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1010 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1012 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1015 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1016 !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
1018 if ((mg = SvTIED_mg(sv, how))) {
1019 PUSHs(SvTIED_obj(sv, mg));
1032 HV * const hv = MUTABLE_HV(POPs);
1033 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1034 stash = gv_stashsv(sv, 0);
1035 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1037 require_pv("AnyDBM_File.pm");
1039 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1040 DIE(aTHX_ "No dbm on this machine");
1050 mPUSHu(O_RDWR|O_CREAT);
1054 if (!SvOK(right)) right = &PL_sv_no;
1058 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1061 if (!sv_isobject(TOPs)) {
1069 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1073 if (sv_isobject(TOPs)) {
1074 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1075 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1092 struct timeval timebuf;
1093 struct timeval *tbuf = &timebuf;
1096 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1101 # if BYTEORDER & 0xf0000
1102 # define ORDERBYTE (0x88888888 - BYTEORDER)
1104 # define ORDERBYTE (0x4444 - BYTEORDER)
1110 for (i = 1; i <= 3; i++) {
1111 SV * const sv = SP[i];
1115 if (SvREADONLY(sv)) {
1116 if (!(SvPOK(sv) && SvCUR(sv) == 0))
1117 Perl_croak_no_modify();
1119 else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
1122 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1123 "Non-string passed as bitmask");
1124 SvPV_force_nomg_nolen(sv); /* force string conversion */
1131 /* little endians can use vecs directly */
1132 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1139 masksize = NFDBITS / NBBY;
1141 masksize = sizeof(long); /* documented int, everyone seems to use long */
1143 Zero(&fd_sets[0], 4, char*);
1146 # if SELECT_MIN_BITS == 1
1147 growsize = sizeof(fd_set);
1149 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1150 # undef SELECT_MIN_BITS
1151 # define SELECT_MIN_BITS __FD_SETSIZE
1153 /* If SELECT_MIN_BITS is greater than one we most probably will want
1154 * to align the sizes with SELECT_MIN_BITS/8 because for example
1155 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1156 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1157 * on (sets/tests/clears bits) is 32 bits. */
1158 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1164 value = SvNV_nomg(sv);
1167 timebuf.tv_sec = (long)value;
1168 value -= (NV)timebuf.tv_sec;
1169 timebuf.tv_usec = (long)(value * 1000000.0);
1174 for (i = 1; i <= 3; i++) {
1176 if (!SvOK(sv) || SvCUR(sv) == 0) {
1183 Sv_Grow(sv, growsize);
1187 while (++j <= growsize) {
1191 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1193 Newx(fd_sets[i], growsize, char);
1194 for (offset = 0; offset < growsize; offset += masksize) {
1195 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1196 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1199 fd_sets[i] = SvPVX(sv);
1203 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1204 /* Can't make just the (void*) conditional because that would be
1205 * cpp #if within cpp macro, and not all compilers like that. */
1206 nfound = PerlSock_select(
1208 (Select_fd_set_t) fd_sets[1],
1209 (Select_fd_set_t) fd_sets[2],
1210 (Select_fd_set_t) fd_sets[3],
1211 (void*) tbuf); /* Workaround for compiler bug. */
1213 nfound = PerlSock_select(
1215 (Select_fd_set_t) fd_sets[1],
1216 (Select_fd_set_t) fd_sets[2],
1217 (Select_fd_set_t) fd_sets[3],
1220 for (i = 1; i <= 3; i++) {
1223 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1225 for (offset = 0; offset < growsize; offset += masksize) {
1226 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1227 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1229 Safefree(fd_sets[i]);
1236 if (GIMME == G_ARRAY && tbuf) {
1237 value = (NV)(timebuf.tv_sec) +
1238 (NV)(timebuf.tv_usec) / 1000000.0;
1243 DIE(aTHX_ "select not implemented");
1248 =for apidoc setdefout
1250 Sets PL_defoutgv, the default file handle for output, to the passed in
1251 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1252 count of the passed in typeglob is increased by one, and the reference count
1253 of the typeglob that PL_defoutgv points to is decreased by one.
1259 Perl_setdefout(pTHX_ GV *gv)
1262 PERL_ARGS_ASSERT_SETDEFOUT;
1263 SvREFCNT_inc_simple_void_NN(gv);
1264 SvREFCNT_dec(PL_defoutgv);
1272 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1273 GV * egv = GvEGVx(PL_defoutgv);
1278 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1279 gvp = hv && HvENAME(hv)
1280 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1282 if (gvp && *gvp == egv) {
1283 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1287 mXPUSHs(newRV(MUTABLE_SV(egv)));
1291 if (!GvIO(newdefout))
1292 gv_IOadd(newdefout);
1293 setdefout(newdefout);
1303 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1304 IO *const io = GvIO(gv);
1310 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1312 const U32 gimme = GIMME_V;
1313 Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1314 if (gimme == G_SCALAR) {
1316 SvSetMagicSV_nosteal(TARG, TOPs);
1321 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1322 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1324 SETERRNO(EBADF,RMS_IFI);
1328 sv_setpvs(TARG, " ");
1329 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1330 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1331 /* Find out how many bytes the char needs */
1332 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1335 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1336 SvCUR_set(TARG,1+len);
1345 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1349 const I32 gimme = GIMME_V;
1351 PERL_ARGS_ASSERT_DOFORM;
1353 if (cv && CvCLONE(cv))
1354 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1359 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1360 PUSHFORMAT(cx, retop);
1361 if (CvDEPTH(cv) >= 2) {
1362 PERL_STACK_OVERFLOW_CHECK();
1363 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1366 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1368 setdefout(gv); /* locally select filehandle so $% et al work */
1387 gv = MUTABLE_GV(POPs);
1404 tmpsv = sv_newmortal();
1405 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1406 DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
1408 IoFLAGS(io) &= ~IOf_DIDTOP;
1409 RETURNOP(doform(cv,gv,PL_op->op_next));
1415 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1416 IO * const io = GvIOp(gv);
1424 if (!io || !(ofp = IoOFP(io)))
1427 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1428 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1430 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1431 PL_formtarget != PL_toptarget)
1435 if (!IoTOP_GV(io)) {
1438 if (!IoTOP_NAME(io)) {
1440 if (!IoFMT_NAME(io))
1441 IoFMT_NAME(io) = savepv(GvNAME(gv));
1442 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1443 HEKfARG(GvNAME_HEK(gv))));
1444 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1445 if ((topgv && GvFORM(topgv)) ||
1446 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1447 IoTOP_NAME(io) = savesvpv(topname);
1449 IoTOP_NAME(io) = savepvs("top");
1451 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1452 if (!topgv || !GvFORM(topgv)) {
1453 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1456 IoTOP_GV(io) = topgv;
1458 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1459 I32 lines = IoLINES_LEFT(io);
1460 const char *s = SvPVX_const(PL_formtarget);
1461 if (lines <= 0) /* Yow, header didn't even fit!!! */
1463 while (lines-- > 0) {
1464 s = strchr(s, '\n');
1470 const STRLEN save = SvCUR(PL_formtarget);
1471 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1472 do_print(PL_formtarget, ofp);
1473 SvCUR_set(PL_formtarget, save);
1474 sv_chop(PL_formtarget, s);
1475 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1478 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1479 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1480 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1482 PL_formtarget = PL_toptarget;
1483 IoFLAGS(io) |= IOf_DIDTOP;
1485 assert(fgv); /* IoTOP_GV(io) should have been set above */
1488 SV * const sv = sv_newmortal();
1489 gv_efullname4(sv, fgv, NULL, FALSE);
1490 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1492 return doform(cv, gv, PL_op);
1496 POPBLOCK(cx,PL_curpm);
1497 retop = cx->blk_sub.retop;
1499 SP = newsp; /* ignore retval of formline */
1502 if (!io || !(fp = IoOFP(io))) {
1503 if (io && IoIFP(io))
1504 report_wrongway_fh(gv, '<');
1510 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1511 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1513 if (!do_print(PL_formtarget, fp))
1516 FmLINES(PL_formtarget) = 0;
1517 SvCUR_set(PL_formtarget, 0);
1518 *SvEND(PL_formtarget) = '\0';
1519 if (IoFLAGS(io) & IOf_FLUSH)
1520 (void)PerlIO_flush(fp);
1524 PL_formtarget = PL_bodytarget;
1525 PERL_UNUSED_VAR(gimme);
1531 dVAR; dSP; dMARK; dORIGMARK;
1535 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1536 IO *const io = GvIO(gv);
1538 /* Treat empty list as "" */
1539 if (MARK == SP) XPUSHs(&PL_sv_no);
1542 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1544 if (MARK == ORIGMARK) {
1547 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1550 return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1552 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1559 SETERRNO(EBADF,RMS_IFI);
1562 else if (!(fp = IoOFP(io))) {
1564 report_wrongway_fh(gv, '<');
1565 else if (ckWARN(WARN_CLOSED))
1567 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1571 SV *sv = sv_newmortal();
1572 do_sprintf(sv, SP - MARK, MARK + 1);
1573 if (!do_print(sv, fp))
1576 if (IoFLAGS(io) & IOf_FLUSH)
1577 if (PerlIO_flush(fp) == EOF)
1586 PUSHs(&PL_sv_undef);
1594 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1595 const int mode = POPi;
1596 SV * const sv = POPs;
1597 GV * const gv = MUTABLE_GV(POPs);
1600 /* Need TIEHANDLE method ? */
1601 const char * const tmps = SvPV_const(sv, len);
1602 /* FIXME? do_open should do const */
1603 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1604 IoLINES(GvIOp(gv)) = 0;
1608 PUSHs(&PL_sv_undef);
1615 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1629 bool charstart = FALSE;
1630 STRLEN charskip = 0;
1633 GV * const gv = MUTABLE_GV(*++MARK);
1634 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1635 && gv && (io = GvIO(gv)) )
1637 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1639 return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1640 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1649 sv_setpvs(bufsv, "");
1650 length = SvIVx(*++MARK);
1652 DIE(aTHX_ "Negative length");
1655 offset = SvIVx(*++MARK);
1659 if (!io || !IoIFP(io)) {
1661 SETERRNO(EBADF,RMS_IFI);
1664 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1665 buffer = SvPVutf8_force(bufsv, blen);
1666 /* UTF-8 may not have been set if they are all low bytes */
1671 buffer = SvPV_force(bufsv, blen);
1672 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1674 if (DO_UTF8(bufsv)) {
1675 blen = sv_len_utf8_nomg(bufsv);
1684 if (PL_op->op_type == OP_RECV) {
1685 Sock_size_t bufsize;
1686 char namebuf[MAXPATHLEN];
1687 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1688 bufsize = sizeof (struct sockaddr_in);
1690 bufsize = sizeof namebuf;
1692 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1696 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1697 /* 'offset' means 'flags' here */
1698 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1699 (struct sockaddr *)namebuf, &bufsize);
1702 /* MSG_TRUNC can give oversized count; quietly lose it */
1705 SvCUR_set(bufsv, count);
1706 *SvEND(bufsv) = '\0';
1707 (void)SvPOK_only(bufsv);
1711 /* This should not be marked tainted if the fp is marked clean */
1712 if (!(IoFLAGS(io) & IOf_UNTAINT))
1713 SvTAINTED_on(bufsv);
1715 sv_setpvn(TARG, namebuf, bufsize);
1721 if (-offset > (SSize_t)blen)
1722 DIE(aTHX_ "Offset outside string");
1725 if (DO_UTF8(bufsv)) {
1726 /* convert offset-as-chars to offset-as-bytes */
1727 if (offset >= (SSize_t)blen)
1728 offset += SvCUR(bufsv) - blen;
1730 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1733 orig_size = SvCUR(bufsv);
1734 /* Allocating length + offset + 1 isn't perfect in the case of reading
1735 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1737 (should be 2 * length + offset + 1, or possibly something longer if
1738 PL_encoding is true) */
1739 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1740 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1741 Zero(buffer+orig_size, offset-orig_size, char);
1743 buffer = buffer + offset;
1745 read_target = bufsv;
1747 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1748 concatenate it to the current buffer. */
1750 /* Truncate the existing buffer to the start of where we will be
1752 SvCUR_set(bufsv, offset);
1754 read_target = sv_newmortal();
1755 SvUPGRADE(read_target, SVt_PV);
1756 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1759 if (PL_op->op_type == OP_SYSREAD) {
1760 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1761 if (IoTYPE(io) == IoTYPE_SOCKET) {
1762 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1768 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1774 count = PerlIO_read(IoIFP(io), buffer, length);
1775 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1776 if (count == 0 && PerlIO_error(IoIFP(io)))
1780 if (IoTYPE(io) == IoTYPE_WRONLY)
1781 report_wrongway_fh(gv, '>');
1784 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1785 *SvEND(read_target) = '\0';
1786 (void)SvPOK_only(read_target);
1787 if (fp_utf8 && !IN_BYTES) {
1788 /* Look at utf8 we got back and count the characters */
1789 const char *bend = buffer + count;
1790 while (buffer < bend) {
1792 skip = UTF8SKIP(buffer);
1795 if (buffer - charskip + skip > bend) {
1796 /* partial character - try for rest of it */
1797 length = skip - (bend-buffer);
1798 offset = bend - SvPVX_const(bufsv);
1810 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1811 provided amount read (count) was what was requested (length)
1813 if (got < wanted && count == length) {
1814 length = wanted - got;
1815 offset = bend - SvPVX_const(bufsv);
1818 /* return value is character count */
1822 else if (buffer_utf8) {
1823 /* Let svcatsv upgrade the bytes we read in to utf8.
1824 The buffer is a mortal so will be freed soon. */
1825 sv_catsv_nomg(bufsv, read_target);
1828 /* This should not be marked tainted if the fp is marked clean */
1829 if (!(IoFLAGS(io) & IOf_UNTAINT))
1830 SvTAINTED_on(bufsv);
1842 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1847 STRLEN orig_blen_bytes;
1848 const int op_type = PL_op->op_type;
1851 GV *const gv = MUTABLE_GV(*++MARK);
1852 IO *const io = GvIO(gv);
1854 if (op_type == OP_SYSWRITE && io) {
1855 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1857 if (MARK == SP - 1) {
1859 mXPUSHi(sv_len(sv));
1863 return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1864 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1874 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1876 if (io && IoIFP(io))
1877 report_wrongway_fh(gv, '<');
1880 SETERRNO(EBADF,RMS_IFI);
1884 /* Do this first to trigger any overloading. */
1885 buffer = SvPV_const(bufsv, blen);
1886 orig_blen_bytes = blen;
1887 doing_utf8 = DO_UTF8(bufsv);
1889 if (PerlIO_isutf8(IoIFP(io))) {
1890 if (!SvUTF8(bufsv)) {
1891 /* We don't modify the original scalar. */
1892 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1893 buffer = (char *) tmpbuf;
1897 else if (doing_utf8) {
1898 STRLEN tmplen = blen;
1899 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1902 buffer = (char *) tmpbuf;
1906 assert((char *)result == buffer);
1907 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1912 if (op_type == OP_SEND) {
1913 const int flags = SvIVx(*++MARK);
1916 char * const sockbuf = SvPVx(*++MARK, mlen);
1917 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1918 flags, (struct sockaddr *)sockbuf, mlen);
1922 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1928 Size_t length = 0; /* This length is in characters. */
1934 /* The SV is bytes, and we've had to upgrade it. */
1935 blen_chars = orig_blen_bytes;
1937 /* The SV really is UTF-8. */
1938 /* Don't call sv_len_utf8 on a magical or overloaded
1939 scalar, as we might get back a different result. */
1940 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
1947 length = blen_chars;
1949 #if Size_t_size > IVSIZE
1950 length = (Size_t)SvNVx(*++MARK);
1952 length = (Size_t)SvIVx(*++MARK);
1954 if ((SSize_t)length < 0) {
1956 DIE(aTHX_ "Negative length");
1961 offset = SvIVx(*++MARK);
1963 if (-offset > (IV)blen_chars) {
1965 DIE(aTHX_ "Offset outside string");
1967 offset += blen_chars;
1968 } else if (offset > (IV)blen_chars) {
1970 DIE(aTHX_ "Offset outside string");
1974 if (length > blen_chars - offset)
1975 length = blen_chars - offset;
1977 /* Here we convert length from characters to bytes. */
1978 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1979 /* Either we had to convert the SV, or the SV is magical, or
1980 the SV has overloading, in which case we can't or mustn't
1981 or mustn't call it again. */
1983 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1984 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1986 /* It's a real UTF-8 SV, and it's not going to change under
1987 us. Take advantage of any cache. */
1989 I32 len_I32 = length;
1991 /* Convert the start and end character positions to bytes.
1992 Remember that the second argument to sv_pos_u2b is relative
1994 sv_pos_u2b(bufsv, &start, &len_I32);
2001 buffer = buffer+offset;
2003 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2004 if (IoTYPE(io) == IoTYPE_SOCKET) {
2005 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
2011 /* See the note at doio.c:do_print about filesize limits. --jhi */
2012 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2021 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2024 #if Size_t_size > IVSIZE
2044 * in Perl 5.12 and later, the additional parameter is a bitmask:
2047 * 2 = eof() <- ARGV magic
2049 * I'll rely on the compiler's trace flow analysis to decide whether to
2050 * actually assign this out here, or punt it into the only block where it is
2051 * used. Doing it out here is DRY on the condition logic.
2056 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2062 if (PL_op->op_flags & OPf_SPECIAL) {
2063 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2067 gv = PL_last_in_gv; /* eof */
2075 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2076 return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2079 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2080 if (io && !IoIFP(io)) {
2081 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2083 IoFLAGS(io) &= ~IOf_START;
2084 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2086 sv_setpvs(GvSV(gv), "-");
2088 GvSV(gv) = newSVpvs("-");
2089 SvSETMAGIC(GvSV(gv));
2091 else if (!nextargv(gv))
2096 PUSHs(boolSV(do_eof(gv)));
2106 if (MAXARG != 0 && (TOPs || POPs))
2107 PL_last_in_gv = MUTABLE_GV(POPs);
2114 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2116 return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2121 SETERRNO(EBADF,RMS_IFI);
2126 #if LSEEKSIZE > IVSIZE
2127 PUSHn( do_tell(gv) );
2129 PUSHi( do_tell(gv) );
2137 const int whence = POPi;
2138 #if LSEEKSIZE > IVSIZE
2139 const Off_t offset = (Off_t)SvNVx(POPs);
2141 const Off_t offset = (Off_t)SvIVx(POPs);
2144 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2145 IO *const io = GvIO(gv);
2148 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2150 #if LSEEKSIZE > IVSIZE
2151 SV *const offset_sv = newSVnv((NV) offset);
2153 SV *const offset_sv = newSViv(offset);
2156 return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2161 if (PL_op->op_type == OP_SEEK)
2162 PUSHs(boolSV(do_seek(gv, offset, whence)));
2164 const Off_t sought = do_sysseek(gv, offset, whence);
2166 PUSHs(&PL_sv_undef);
2168 SV* const sv = sought ?
2169 #if LSEEKSIZE > IVSIZE
2174 : newSVpvn(zero_but_true, ZBTLEN);
2185 /* There seems to be no consensus on the length type of truncate()
2186 * and ftruncate(), both off_t and size_t have supporters. In
2187 * general one would think that when using large files, off_t is
2188 * at least as wide as size_t, so using an off_t should be okay. */
2189 /* XXX Configure probe for the length type of *truncate() needed XXX */
2192 #if Off_t_size > IVSIZE
2197 /* Checking for length < 0 is problematic as the type might or
2198 * might not be signed: if it is not, clever compilers will moan. */
2199 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2202 SV * const sv = POPs;
2207 if (PL_op->op_flags & OPf_SPECIAL
2208 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2209 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2216 TAINT_PROPER("truncate");
2217 if (!(fp = IoIFP(io))) {
2223 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2225 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2231 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2232 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2233 goto do_ftruncate_io;
2236 const char * const name = SvPV_nomg_const_nolen(sv);
2237 TAINT_PROPER("truncate");
2239 if (truncate(name, len) < 0)
2243 const int tmpfd = PerlLIO_open(name, O_RDWR);
2248 if (my_chsize(tmpfd, len) < 0)
2250 PerlLIO_close(tmpfd);
2259 SETERRNO(EBADF,RMS_IFI);
2267 SV * const argsv = POPs;
2268 const unsigned int func = POPu;
2269 const int optype = PL_op->op_type;
2270 GV * const gv = MUTABLE_GV(POPs);
2271 IO * const io = gv ? GvIOn(gv) : NULL;
2275 if (!io || !argsv || !IoIFP(io)) {
2277 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2281 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2284 s = SvPV_force(argsv, len);
2285 need = IOCPARM_LEN(func);
2287 s = Sv_Grow(argsv, need + 1);
2288 SvCUR_set(argsv, need);
2291 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2294 retval = SvIV(argsv);
2295 s = INT2PTR(char*,retval); /* ouch */
2298 TAINT_PROPER(PL_op_desc[optype]);
2300 if (optype == OP_IOCTL)
2302 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2304 DIE(aTHX_ "ioctl is not implemented");
2308 DIE(aTHX_ "fcntl is not implemented");
2310 #if defined(OS2) && defined(__EMX__)
2311 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2313 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2317 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2319 if (s[SvCUR(argsv)] != 17)
2320 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2322 s[SvCUR(argsv)] = 0; /* put our null back */
2323 SvSETMAGIC(argsv); /* Assume it has changed */
2332 PUSHp(zero_but_true, ZBTLEN);
2343 const int argtype = POPi;
2344 GV * const gv = MUTABLE_GV(POPs);
2345 IO *const io = GvIO(gv);
2346 PerlIO *const fp = io ? IoIFP(io) : NULL;
2348 /* XXX Looks to me like io is always NULL at this point */
2350 (void)PerlIO_flush(fp);
2351 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2356 SETERRNO(EBADF,RMS_IFI);
2361 DIE(aTHX_ PL_no_func, "flock()");
2372 const int protocol = POPi;
2373 const int type = POPi;
2374 const int domain = POPi;
2375 GV * const gv = MUTABLE_GV(POPs);
2376 IO * const io = gv ? GvIOn(gv) : NULL;
2381 if (io && IoIFP(io))
2382 do_close(gv, FALSE);
2383 SETERRNO(EBADF,LIB_INVARG);
2388 do_close(gv, FALSE);
2390 TAINT_PROPER("socket");
2391 fd = PerlSock_socket(domain, type, protocol);
2394 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2395 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2396 IoTYPE(io) = IoTYPE_SOCKET;
2397 if (!IoIFP(io) || !IoOFP(io)) {
2398 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2399 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2400 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2403 #if defined(HAS_FCNTL) && defined(F_SETFD)
2404 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2413 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2415 const int protocol = POPi;
2416 const int type = POPi;
2417 const int domain = POPi;
2418 GV * const gv2 = MUTABLE_GV(POPs);
2419 GV * const gv1 = MUTABLE_GV(POPs);
2420 IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2421 IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2425 report_evil_fh(gv1);
2427 report_evil_fh(gv2);
2429 if (io1 && IoIFP(io1))
2430 do_close(gv1, FALSE);
2431 if (io2 && IoIFP(io2))
2432 do_close(gv2, FALSE);
2437 TAINT_PROPER("socketpair");
2438 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2440 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2441 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2442 IoTYPE(io1) = IoTYPE_SOCKET;
2443 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2444 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2445 IoTYPE(io2) = IoTYPE_SOCKET;
2446 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2447 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2448 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2449 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2450 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2451 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2452 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2455 #if defined(HAS_FCNTL) && defined(F_SETFD)
2456 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2457 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2462 DIE(aTHX_ PL_no_sock_func, "socketpair");
2471 SV * const addrsv = POPs;
2472 /* OK, so on what platform does bind modify addr? */
2474 GV * const gv = MUTABLE_GV(POPs);
2475 IO * const io = GvIOn(gv);
2477 const int op_type = PL_op->op_type;
2479 if (!io || !IoIFP(io))
2482 addr = SvPV_const(addrsv, len);
2483 TAINT_PROPER(PL_op_desc[op_type]);
2484 if ((op_type == OP_BIND
2485 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2486 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2494 SETERRNO(EBADF,SS_IVCHAN);
2501 const int backlog = POPi;
2502 GV * const gv = MUTABLE_GV(POPs);
2503 IO * const io = gv ? GvIOn(gv) : NULL;
2505 if (!io || !IoIFP(io))
2508 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2515 SETERRNO(EBADF,SS_IVCHAN);
2524 char namebuf[MAXPATHLEN];
2525 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2526 Sock_size_t len = sizeof (struct sockaddr_in);
2528 Sock_size_t len = sizeof namebuf;
2530 GV * const ggv = MUTABLE_GV(POPs);
2531 GV * const ngv = MUTABLE_GV(POPs);
2540 if (!gstio || !IoIFP(gstio))
2544 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2547 /* Some platforms indicate zero length when an AF_UNIX client is
2548 * not bound. Simulate a non-zero-length sockaddr structure in
2550 namebuf[0] = 0; /* sun_len */
2551 namebuf[1] = AF_UNIX; /* sun_family */
2559 do_close(ngv, FALSE);
2560 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2561 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2562 IoTYPE(nstio) = IoTYPE_SOCKET;
2563 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2564 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2565 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2566 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2569 #if defined(HAS_FCNTL) && defined(F_SETFD)
2570 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2573 #ifdef __SCO_VERSION__
2574 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2577 PUSHp(namebuf, len);
2581 report_evil_fh(ggv);
2582 SETERRNO(EBADF,SS_IVCHAN);
2592 const int how = POPi;
2593 GV * const gv = MUTABLE_GV(POPs);
2594 IO * const io = GvIOn(gv);
2596 if (!io || !IoIFP(io))
2599 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2604 SETERRNO(EBADF,SS_IVCHAN);
2611 const int optype = PL_op->op_type;
2612 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2613 const unsigned int optname = (unsigned int) POPi;
2614 const unsigned int lvl = (unsigned int) POPi;
2615 GV * const gv = MUTABLE_GV(POPs);
2616 IO * const io = GvIOn(gv);
2620 if (!io || !IoIFP(io))
2623 fd = PerlIO_fileno(IoIFP(io));
2627 (void)SvPOK_only(sv);
2631 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2638 #if defined(__SYMBIAN32__)
2639 # define SETSOCKOPT_OPTION_VALUE_T void *
2641 # define SETSOCKOPT_OPTION_VALUE_T const char *
2643 /* XXX TODO: We need to have a proper type (a Configure probe,
2644 * etc.) for what the C headers think of the third argument of
2645 * setsockopt(), the option_value read-only buffer: is it
2646 * a "char *", or a "void *", const or not. Some compilers
2647 * don't take kindly to e.g. assuming that "char *" implicitly
2648 * promotes to a "void *", or to explicitly promoting/demoting
2649 * consts to non/vice versa. The "const void *" is the SUS
2650 * definition, but that does not fly everywhere for the above
2652 SETSOCKOPT_OPTION_VALUE_T buf;
2656 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2660 aint = (int)SvIV(sv);
2661 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2664 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2674 SETERRNO(EBADF,SS_IVCHAN);
2683 const int optype = PL_op->op_type;
2684 GV * const gv = MUTABLE_GV(POPs);
2685 IO * const io = GvIOn(gv);
2690 if (!io || !IoIFP(io))
2693 sv = sv_2mortal(newSV(257));
2694 (void)SvPOK_only(sv);
2698 fd = PerlIO_fileno(IoIFP(io));
2700 case OP_GETSOCKNAME:
2701 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2704 case OP_GETPEERNAME:
2705 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2707 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2709 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";
2710 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2711 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2712 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2713 sizeof(u_short) + sizeof(struct in_addr))) {
2720 #ifdef BOGUS_GETNAME_RETURN
2721 /* Interactive Unix, getpeername() and getsockname()
2722 does not return valid namelen */
2723 if (len == BOGUS_GETNAME_RETURN)
2724 len = sizeof(struct sockaddr);
2733 SETERRNO(EBADF,SS_IVCHAN);
2752 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2753 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2754 if (PL_op->op_type == OP_LSTAT) {
2755 if (gv != PL_defgv) {
2756 do_fstat_warning_check:
2757 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2758 "lstat() on filehandle%s%"SVf,
2761 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2763 } else if (PL_laststype != OP_LSTAT)
2764 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2765 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2768 if (gv != PL_defgv) {
2772 PL_laststype = OP_STAT;
2773 PL_statgv = gv ? gv : (GV *)io;
2774 sv_setpvs(PL_statname, "");
2781 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2783 } else if (IoDIRP(io)) {
2785 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2788 PL_laststatval = -1;
2791 else PL_laststatval = -1;
2792 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2795 if (PL_laststatval < 0) {
2800 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2801 io = MUTABLE_IO(SvRV(sv));
2802 if (PL_op->op_type == OP_LSTAT)
2803 goto do_fstat_warning_check;
2804 goto do_fstat_have_io;
2807 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2808 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2810 PL_laststype = PL_op->op_type;
2811 if (PL_op->op_type == OP_LSTAT)
2812 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2814 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2815 if (PL_laststatval < 0) {
2816 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2817 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2823 if (gimme != G_ARRAY) {
2824 if (gimme != G_VOID)
2825 XPUSHs(boolSV(max));
2831 mPUSHi(PL_statcache.st_dev);
2832 #if ST_INO_SIZE > IVSIZE
2833 mPUSHn(PL_statcache.st_ino);
2835 # if ST_INO_SIGN <= 0
2836 mPUSHi(PL_statcache.st_ino);
2838 mPUSHu(PL_statcache.st_ino);
2841 mPUSHu(PL_statcache.st_mode);
2842 mPUSHu(PL_statcache.st_nlink);
2844 sv_setuid(PUSHmortal, PL_statcache.st_uid);
2845 sv_setgid(PUSHmortal, PL_statcache.st_gid);
2847 #ifdef USE_STAT_RDEV
2848 mPUSHi(PL_statcache.st_rdev);
2850 PUSHs(newSVpvs_flags("", SVs_TEMP));
2852 #if Off_t_size > IVSIZE
2853 mPUSHn(PL_statcache.st_size);
2855 mPUSHi(PL_statcache.st_size);
2858 mPUSHn(PL_statcache.st_atime);
2859 mPUSHn(PL_statcache.st_mtime);
2860 mPUSHn(PL_statcache.st_ctime);
2862 mPUSHi(PL_statcache.st_atime);
2863 mPUSHi(PL_statcache.st_mtime);
2864 mPUSHi(PL_statcache.st_ctime);
2866 #ifdef USE_STAT_BLOCKS
2867 mPUSHu(PL_statcache.st_blksize);
2868 mPUSHu(PL_statcache.st_blocks);
2870 PUSHs(newSVpvs_flags("", SVs_TEMP));
2871 PUSHs(newSVpvs_flags("", SVs_TEMP));
2877 /* All filetest ops avoid manipulating the perl stack pointer in their main
2878 bodies (since commit d2c4d2d1e22d3125), and return using either
2879 S_ft_return_false() or S_ft_return_true(). These two helper functions are
2880 the only two which manipulate the perl stack. To ensure that no stack
2881 manipulation macros are used, the filetest ops avoid defining a local copy
2882 of the stack pointer with dSP. */
2884 /* If the next filetest is stacked up with this one
2885 (PL_op->op_private & OPpFT_STACKING), we leave
2886 the original argument on the stack for success,
2887 and skip the stacked operators on failure.
2888 The next few macros/functions take care of this.
2892 S_ft_return_false(pTHX_ SV *ret) {
2896 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
2900 if (PL_op->op_private & OPpFT_STACKING) {
2901 while (OP_IS_FILETEST(next->op_type)
2902 && next->op_private & OPpFT_STACKED)
2903 next = next->op_next;
2908 PERL_STATIC_INLINE OP *
2909 S_ft_return_true(pTHX_ SV *ret) {
2911 if (PL_op->op_flags & OPf_REF)
2912 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
2913 else if (!(PL_op->op_private & OPpFT_STACKING))
2919 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
2920 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
2921 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
2923 #define tryAMAGICftest_MG(chr) STMT_START { \
2924 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
2925 && PL_op->op_flags & OPf_KIDS) { \
2926 OP *next = S_try_amagic_ftest(aTHX_ chr); \
2927 if (next) return next; \
2932 S_try_amagic_ftest(pTHX_ char chr) {
2934 SV *const arg = *PL_stack_sp;
2937 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
2941 const char tmpchr = chr;
2942 SV * const tmpsv = amagic_call(arg,
2943 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2944 ftest_amg, AMGf_unary);
2949 return SvTRUE(tmpsv)
2950 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
2960 /* Not const, because things tweak this below. Not bool, because there's
2961 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2962 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2963 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2964 /* Giving some sort of initial value silences compilers. */
2966 int access_mode = R_OK;
2968 int access_mode = 0;
2971 /* access_mode is never used, but leaving use_access in makes the
2972 conditional compiling below much clearer. */
2975 Mode_t stat_mode = S_IRUSR;
2977 bool effective = FALSE;
2980 switch (PL_op->op_type) {
2981 case OP_FTRREAD: opchar = 'R'; break;
2982 case OP_FTRWRITE: opchar = 'W'; break;
2983 case OP_FTREXEC: opchar = 'X'; break;
2984 case OP_FTEREAD: opchar = 'r'; break;
2985 case OP_FTEWRITE: opchar = 'w'; break;
2986 case OP_FTEEXEC: opchar = 'x'; break;
2988 tryAMAGICftest_MG(opchar);
2990 switch (PL_op->op_type) {
2992 #if !(defined(HAS_ACCESS) && defined(R_OK))
2998 #if defined(HAS_ACCESS) && defined(W_OK)
3003 stat_mode = S_IWUSR;
3007 #if defined(HAS_ACCESS) && defined(X_OK)
3012 stat_mode = S_IXUSR;
3016 #ifdef PERL_EFF_ACCESS
3019 stat_mode = S_IWUSR;
3023 #ifndef PERL_EFF_ACCESS
3030 #ifdef PERL_EFF_ACCESS
3035 stat_mode = S_IXUSR;
3041 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3042 const char *name = SvPV_nolen(*PL_stack_sp);
3044 # ifdef PERL_EFF_ACCESS
3045 result = PERL_EFF_ACCESS(name, access_mode);
3047 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3053 result = access(name, access_mode);
3055 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3066 result = my_stat_flags(0);
3069 if (cando(stat_mode, effective, &PL_statcache))
3078 const int op_type = PL_op->op_type;
3082 case OP_FTIS: opchar = 'e'; break;
3083 case OP_FTSIZE: opchar = 's'; break;
3084 case OP_FTMTIME: opchar = 'M'; break;
3085 case OP_FTCTIME: opchar = 'C'; break;
3086 case OP_FTATIME: opchar = 'A'; break;
3088 tryAMAGICftest_MG(opchar);
3090 result = my_stat_flags(0);
3093 if (op_type == OP_FTIS)
3096 /* You can't dTARGET inside OP_FTIS, because you'll get
3097 "panic: pad_sv po" - the op is not flagged to have a target. */
3101 #if Off_t_size > IVSIZE
3102 sv_setnv(TARG, (NV)PL_statcache.st_size);
3104 sv_setiv(TARG, (IV)PL_statcache.st_size);
3109 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3113 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3117 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3121 return SvTRUE_nomg(TARG)
3122 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3132 switch (PL_op->op_type) {
3133 case OP_FTROWNED: opchar = 'O'; break;
3134 case OP_FTEOWNED: opchar = 'o'; break;
3135 case OP_FTZERO: opchar = 'z'; break;
3136 case OP_FTSOCK: opchar = 'S'; break;
3137 case OP_FTCHR: opchar = 'c'; break;
3138 case OP_FTBLK: opchar = 'b'; break;
3139 case OP_FTFILE: opchar = 'f'; break;
3140 case OP_FTDIR: opchar = 'd'; break;
3141 case OP_FTPIPE: opchar = 'p'; break;
3142 case OP_FTSUID: opchar = 'u'; break;
3143 case OP_FTSGID: opchar = 'g'; break;
3144 case OP_FTSVTX: opchar = 'k'; break;
3146 tryAMAGICftest_MG(opchar);
3148 /* I believe that all these three are likely to be defined on most every
3149 system these days. */
3151 if(PL_op->op_type == OP_FTSUID) {
3156 if(PL_op->op_type == OP_FTSGID) {
3161 if(PL_op->op_type == OP_FTSVTX) {
3166 result = my_stat_flags(0);
3169 switch (PL_op->op_type) {
3171 if (PL_statcache.st_uid == PerlProc_getuid())
3175 if (PL_statcache.st_uid == PerlProc_geteuid())
3179 if (PL_statcache.st_size == 0)
3183 if (S_ISSOCK(PL_statcache.st_mode))
3187 if (S_ISCHR(PL_statcache.st_mode))
3191 if (S_ISBLK(PL_statcache.st_mode))
3195 if (S_ISREG(PL_statcache.st_mode))
3199 if (S_ISDIR(PL_statcache.st_mode))
3203 if (S_ISFIFO(PL_statcache.st_mode))
3208 if (PL_statcache.st_mode & S_ISUID)
3214 if (PL_statcache.st_mode & S_ISGID)
3220 if (PL_statcache.st_mode & S_ISVTX)
3233 tryAMAGICftest_MG('l');
3234 result = my_lstat_flags(0);
3238 if (S_ISLNK(PL_statcache.st_mode))
3251 tryAMAGICftest_MG('t');
3253 if (PL_op->op_flags & OPf_REF)
3256 SV *tmpsv = *PL_stack_sp;
3257 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3258 name = SvPV_nomg(tmpsv, namelen);
3259 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3263 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3264 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3265 else if (name && isDIGIT(*name))
3269 if (PerlLIO_isatty(fd))
3287 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3289 if (PL_op->op_flags & OPf_REF)
3291 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3296 gv = MAYBE_DEREF_GV_nomg(sv);
3300 if (gv == PL_defgv) {
3302 io = SvTYPE(PL_statgv) == SVt_PVIO
3306 goto really_filename;
3311 sv_setpvs(PL_statname, "");
3312 io = GvIO(PL_statgv);
3314 PL_laststatval = -1;
3315 PL_laststype = OP_STAT;
3316 if (io && IoIFP(io)) {
3317 if (! PerlIO_has_base(IoIFP(io)))
3318 DIE(aTHX_ "-T and -B not implemented on filehandles");
3319 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3320 if (PL_laststatval < 0)
3322 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3323 if (PL_op->op_type == OP_FTTEXT)
3328 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3329 i = PerlIO_getc(IoIFP(io));
3331 (void)PerlIO_ungetc(IoIFP(io),i);
3333 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3335 len = PerlIO_get_bufsiz(IoIFP(io));
3336 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3337 /* sfio can have large buffers - limit to 512 */
3342 SETERRNO(EBADF,RMS_IFI);
3344 SETERRNO(EBADF,RMS_IFI);
3349 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3352 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3354 PL_laststatval = -1;
3355 PL_laststype = OP_STAT;
3357 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3359 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3362 PL_laststype = OP_STAT;
3363 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3364 if (PL_laststatval < 0) {
3365 (void)PerlIO_close(fp);
3368 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3369 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3370 (void)PerlIO_close(fp);
3372 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3373 FT_RETURNNO; /* special case NFS directories */
3374 FT_RETURNYES; /* null file is anything */
3379 /* now scan s to look for textiness */
3380 /* XXX ASCII dependent code */
3382 #if defined(DOSISH) || defined(USEMYBINMODE)
3383 /* ignore trailing ^Z on short files */
3384 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3388 for (i = 0; i < len; i++, s++) {
3389 if (!*s) { /* null never allowed in text */
3394 else if (!(isPRINT(*s) || isSPACE(*s)))
3397 else if (*s & 128) {
3399 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3402 /* utf8 characters don't count as odd */
3403 if (UTF8_IS_START(*s)) {
3404 int ulen = UTF8SKIP(s);
3405 if (ulen < len - i) {
3407 for (j = 1; j < ulen; j++) {
3408 if (!UTF8_IS_CONTINUATION(s[j]))
3411 --ulen; /* loop does extra increment */
3421 *s != '\n' && *s != '\r' && *s != '\b' &&
3422 *s != '\t' && *s != '\f' && *s != 27)
3427 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3438 const char *tmps = NULL;
3442 SV * const sv = POPs;
3443 if (PL_op->op_flags & OPf_SPECIAL) {
3444 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3446 else if (!(gv = MAYBE_DEREF_GV(sv)))
3447 tmps = SvPV_nomg_const_nolen(sv);
3450 if( !gv && (!tmps || !*tmps) ) {
3451 HV * const table = GvHVn(PL_envgv);
3454 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3455 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3457 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3462 deprecate("chdir('') or chdir(undef) as chdir()");
3463 tmps = SvPV_nolen_const(*svp);
3467 TAINT_PROPER("chdir");
3472 TAINT_PROPER("chdir");
3475 IO* const io = GvIO(gv);
3478 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3479 } else if (IoIFP(io)) {
3480 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3484 SETERRNO(EBADF, RMS_IFI);
3490 SETERRNO(EBADF,RMS_IFI);
3494 DIE(aTHX_ PL_no_func, "fchdir");
3498 PUSHi( PerlDir_chdir(tmps) >= 0 );
3500 /* Clear the DEFAULT element of ENV so we'll get the new value
3502 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3509 dVAR; dSP; dMARK; dTARGET;
3510 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3521 char * const tmps = POPpx;
3522 TAINT_PROPER("chroot");
3523 PUSHi( chroot(tmps) >= 0 );
3526 DIE(aTHX_ PL_no_func, "chroot");
3534 const char * const tmps2 = POPpconstx;
3535 const char * const tmps = SvPV_nolen_const(TOPs);
3536 TAINT_PROPER("rename");
3538 anum = PerlLIO_rename(tmps, tmps2);
3540 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3541 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3544 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3545 (void)UNLINK(tmps2);
3546 if (!(anum = link(tmps, tmps2)))
3547 anum = UNLINK(tmps);
3555 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3559 const int op_type = PL_op->op_type;
3563 if (op_type == OP_LINK)
3564 DIE(aTHX_ PL_no_func, "link");
3566 # ifndef HAS_SYMLINK
3567 if (op_type == OP_SYMLINK)
3568 DIE(aTHX_ PL_no_func, "symlink");
3572 const char * const tmps2 = POPpconstx;
3573 const char * const tmps = SvPV_nolen_const(TOPs);
3574 TAINT_PROPER(PL_op_desc[op_type]);
3576 # if defined(HAS_LINK)
3577 # if defined(HAS_SYMLINK)
3578 /* Both present - need to choose which. */
3579 (op_type == OP_LINK) ?
3580 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3582 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3583 PerlLIO_link(tmps, tmps2);
3586 # if defined(HAS_SYMLINK)
3587 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3588 symlink(tmps, tmps2);
3593 SETi( result >= 0 );
3600 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3611 char buf[MAXPATHLEN];
3616 len = readlink(tmps, buf, sizeof(buf) - 1);
3623 RETSETUNDEF; /* just pretend it's a normal file */
3627 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3629 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3631 char * const save_filename = filename;
3636 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3638 PERL_ARGS_ASSERT_DOONELINER;
3640 Newx(cmdline, size, char);
3641 my_strlcpy(cmdline, cmd, size);
3642 my_strlcat(cmdline, " ", size);
3643 for (s = cmdline + strlen(cmdline); *filename; ) {
3647 if (s - cmdline < size)
3648 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3649 myfp = PerlProc_popen(cmdline, "r");
3653 SV * const tmpsv = sv_newmortal();
3654 /* Need to save/restore 'PL_rs' ?? */
3655 s = sv_gets(tmpsv, myfp, 0);
3656 (void)PerlProc_pclose(myfp);
3660 #ifdef HAS_SYS_ERRLIST
3665 /* you don't see this */
3666 const char * const errmsg = Strerror(e) ;
3669 if (instr(s, errmsg)) {
3676 #define EACCES EPERM
3678 if (instr(s, "cannot make"))
3679 SETERRNO(EEXIST,RMS_FEX);
3680 else if (instr(s, "existing file"))
3681 SETERRNO(EEXIST,RMS_FEX);
3682 else if (instr(s, "ile exists"))
3683 SETERRNO(EEXIST,RMS_FEX);
3684 else if (instr(s, "non-exist"))
3685 SETERRNO(ENOENT,RMS_FNF);
3686 else if (instr(s, "does not exist"))
3687 SETERRNO(ENOENT,RMS_FNF);
3688 else if (instr(s, "not empty"))
3689 SETERRNO(EBUSY,SS_DEVOFFLINE);
3690 else if (instr(s, "cannot access"))
3691 SETERRNO(EACCES,RMS_PRV);
3693 SETERRNO(EPERM,RMS_PRV);
3696 else { /* some mkdirs return no failure indication */
3697 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3698 if (PL_op->op_type == OP_RMDIR)
3703 SETERRNO(EACCES,RMS_PRV); /* a guess */
3712 /* This macro removes trailing slashes from a directory name.
3713 * Different operating and file systems take differently to
3714 * trailing slashes. According to POSIX 1003.1 1996 Edition
3715 * any number of trailing slashes should be allowed.
3716 * Thusly we snip them away so that even non-conforming
3717 * systems are happy.
3718 * We should probably do this "filtering" for all
3719 * the functions that expect (potentially) directory names:
3720 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3721 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3723 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3724 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3727 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3728 (tmps) = savepvn((tmps), (len)); \
3738 const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3740 TRIMSLASHES(tmps,len,copy);
3742 TAINT_PROPER("mkdir");
3744 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3748 SETi( dooneliner("mkdir", tmps) );
3749 oldumask = PerlLIO_umask(0);
3750 PerlLIO_umask(oldumask);
3751 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3766 TRIMSLASHES(tmps,len,copy);
3767 TAINT_PROPER("rmdir");
3769 SETi( PerlDir_rmdir(tmps) >= 0 );
3771 SETi( dooneliner("rmdir", tmps) );
3778 /* Directory calls. */
3782 #if defined(Direntry_t) && defined(HAS_READDIR)
3784 const char * const dirname = POPpconstx;
3785 GV * const gv = MUTABLE_GV(POPs);
3786 IO * const io = GvIOn(gv);
3791 if ((IoIFP(io) || IoOFP(io)))
3792 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3793 "Opening filehandle %"HEKf" also as a directory",
3794 HEKfARG(GvENAME_HEK(gv)) );
3796 PerlDir_close(IoDIRP(io));
3797 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3803 SETERRNO(EBADF,RMS_DIR);
3806 DIE(aTHX_ PL_no_dir_func, "opendir");
3812 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3813 DIE(aTHX_ PL_no_dir_func, "readdir");
3815 #if !defined(I_DIRENT) && !defined(VMS)
3816 Direntry_t *readdir (DIR *);
3822 const I32 gimme = GIMME;
3823 GV * const gv = MUTABLE_GV(POPs);
3824 const Direntry_t *dp;
3825 IO * const io = GvIOn(gv);
3827 if (!io || !IoDIRP(io)) {
3828 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3829 "readdir() attempted on invalid dirhandle %"HEKf,
3830 HEKfARG(GvENAME_HEK(gv)));
3835 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3839 sv = newSVpvn(dp->d_name, dp->d_namlen);
3841 sv = newSVpv(dp->d_name, 0);
3843 if (!(IoFLAGS(io) & IOf_UNTAINT))
3846 } while (gimme == G_ARRAY);
3848 if (!dp && gimme != G_ARRAY)
3855 SETERRNO(EBADF,RMS_ISI);
3856 if (GIMME == G_ARRAY)
3865 #if defined(HAS_TELLDIR) || defined(telldir)
3867 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3868 /* XXX netbsd still seemed to.
3869 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3870 --JHI 1999-Feb-02 */
3871 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3872 long telldir (DIR *);
3874 GV * const gv = MUTABLE_GV(POPs);
3875 IO * const io = GvIOn(gv);
3877 if (!io || !IoDIRP(io)) {
3878 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3879 "telldir() attempted on invalid dirhandle %"HEKf,
3880 HEKfARG(GvENAME_HEK(gv)));
3884 PUSHi( PerlDir_tell(IoDIRP(io)) );
3888 SETERRNO(EBADF,RMS_ISI);
3891 DIE(aTHX_ PL_no_dir_func, "telldir");
3897 #if defined(HAS_SEEKDIR) || defined(seekdir)
3899 const long along = POPl;
3900 GV * const gv = MUTABLE_GV(POPs);
3901 IO * const io = GvIOn(gv);
3903 if (!io || !IoDIRP(io)) {
3904 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3905 "seekdir() attempted on invalid dirhandle %"HEKf,
3906 HEKfARG(GvENAME_HEK(gv)));
3909 (void)PerlDir_seek(IoDIRP(io), along);
3914 SETERRNO(EBADF,RMS_ISI);
3917 DIE(aTHX_ PL_no_dir_func, "seekdir");
3923 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3925 GV * const gv = MUTABLE_GV(POPs);
3926 IO * const io = GvIOn(gv);
3928 if (!io || !IoDIRP(io)) {
3929 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3930 "rewinddir() attempted on invalid dirhandle %"HEKf,
3931 HEKfARG(GvENAME_HEK(gv)));
3934 (void)PerlDir_rewind(IoDIRP(io));
3938 SETERRNO(EBADF,RMS_ISI);
3941 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3947 #if defined(Direntry_t) && defined(HAS_READDIR)
3949 GV * const gv = MUTABLE_GV(POPs);
3950 IO * const io = GvIOn(gv);
3952 if (!io || !IoDIRP(io)) {
3953 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3954 "closedir() attempted on invalid dirhandle %"HEKf,
3955 HEKfARG(GvENAME_HEK(gv)));
3958 #ifdef VOID_CLOSEDIR
3959 PerlDir_close(IoDIRP(io));
3961 if (PerlDir_close(IoDIRP(io)) < 0) {
3962 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3971 SETERRNO(EBADF,RMS_IFI);
3974 DIE(aTHX_ PL_no_dir_func, "closedir");
3978 /* Process control. */
3985 #ifdef HAS_SIGPROCMASK
3986 sigset_t oldmask, newmask;
3990 PERL_FLUSHALL_FOR_CHILD;
3991 #ifdef HAS_SIGPROCMASK
3992 sigfillset(&newmask);
3993 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
3995 childpid = PerlProc_fork();
3996 if (childpid == 0) {
4000 for (sig = 1; sig < SIG_SIZE; sig++)
4001 PL_psig_pend[sig] = 0;
4003 #ifdef HAS_SIGPROCMASK
4006 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4013 #ifdef PERL_USES_PL_PIDSTATUS
4014 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4020 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4025 PERL_FLUSHALL_FOR_CHILD;
4026 childpid = PerlProc_fork();
4032 DIE(aTHX_ PL_no_func, "fork");
4039 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4044 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4045 childpid = wait4pid(-1, &argflags, 0);
4047 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4052 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4053 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4054 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4056 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4061 DIE(aTHX_ PL_no_func, "wait");
4067 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4069 const int optype = POPi;
4070 const Pid_t pid = TOPi;
4074 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4075 result = wait4pid(pid, &argflags, optype);
4077 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4082 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4083 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4084 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4086 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4091 DIE(aTHX_ PL_no_func, "waitpid");
4097 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4098 #if defined(__LIBCATAMOUNT__)
4099 PL_statusvalue = -1;
4108 while (++MARK <= SP) {
4109 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4114 TAINT_PROPER("system");
4116 PERL_FLUSHALL_FOR_CHILD;
4117 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4122 #ifdef HAS_SIGPROCMASK
4123 sigset_t newset, oldset;
4126 if (PerlProc_pipe(pp) >= 0)
4128 #ifdef HAS_SIGPROCMASK
4129 sigemptyset(&newset);
4130 sigaddset(&newset, SIGCHLD);
4131 sigprocmask(SIG_BLOCK, &newset, &oldset);
4133 while ((childpid = PerlProc_fork()) == -1) {
4134 if (errno != EAGAIN) {
4139 PerlLIO_close(pp[0]);
4140 PerlLIO_close(pp[1]);
4142 #ifdef HAS_SIGPROCMASK
4143 sigprocmask(SIG_SETMASK, &oldset, NULL);
4150 Sigsave_t ihand,qhand; /* place to save signals during system() */
4154 PerlLIO_close(pp[1]);
4156 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4157 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4160 result = wait4pid(childpid, &status, 0);
4161 } while (result == -1 && errno == EINTR);
4163 #ifdef HAS_SIGPROCMASK
4164 sigprocmask(SIG_SETMASK, &oldset, NULL);
4166 (void)rsignal_restore(SIGINT, &ihand);
4167 (void)rsignal_restore(SIGQUIT, &qhand);
4169 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4170 do_execfree(); /* free any memory child malloced on fork */
4177 while (n < sizeof(int)) {
4178 n1 = PerlLIO_read(pp[0],
4179 (void*)(((char*)&errkid)+n),
4185 PerlLIO_close(pp[0]);
4186 if (n) { /* Error */
4187 if (n != sizeof(int))
4188 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4189 errno = errkid; /* Propagate errno from kid */
4190 STATUS_NATIVE_CHILD_SET(-1);
4193 XPUSHi(STATUS_CURRENT);
4196 #ifdef HAS_SIGPROCMASK
4197 sigprocmask(SIG_SETMASK, &oldset, NULL);
4200 PerlLIO_close(pp[0]);
4201 #if defined(HAS_FCNTL) && defined(F_SETFD)
4202 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4205 if (PL_op->op_flags & OPf_STACKED) {
4206 SV * const really = *++MARK;
4207 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4209 else if (SP - MARK != 1)
4210 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4212 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4216 #else /* ! FORK or VMS or OS/2 */
4219 if (PL_op->op_flags & OPf_STACKED) {
4220 SV * const really = *++MARK;
4221 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4222 value = (I32)do_aspawn(really, MARK, SP);
4224 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4227 else if (SP - MARK != 1) {
4228 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4229 value = (I32)do_aspawn(NULL, MARK, SP);
4231 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4235 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4237 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4239 STATUS_NATIVE_CHILD_SET(value);
4242 XPUSHi(result ? value : STATUS_CURRENT);
4243 #endif /* !FORK or VMS or OS/2 */
4250 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4255 while (++MARK <= SP) {
4256 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4261 TAINT_PROPER("exec");
4263 PERL_FLUSHALL_FOR_CHILD;
4264 if (PL_op->op_flags & OPf_STACKED) {
4265 SV * const really = *++MARK;
4266 value = (I32)do_aexec(really, MARK, SP);
4268 else if (SP - MARK != 1)
4270 value = (I32)vms_do_aexec(NULL, MARK, SP);
4272 value = (I32)do_aexec(NULL, MARK, SP);
4276 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4278 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4291 XPUSHi( getppid() );
4294 DIE(aTHX_ PL_no_func, "getppid");
4304 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4307 pgrp = (I32)BSD_GETPGRP(pid);
4309 if (pid != 0 && pid != PerlProc_getpid())
4310 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4316 DIE(aTHX_ PL_no_func, "getpgrp()");
4326 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4327 if (MAXARG > 0) pid = TOPs && TOPi;
4333 TAINT_PROPER("setpgrp");
4335 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4337 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4338 || (pid != 0 && pid != PerlProc_getpid()))
4340 DIE(aTHX_ "setpgrp can't take arguments");
4342 SETi( setpgrp() >= 0 );
4343 #endif /* USE_BSDPGRP */
4346 DIE(aTHX_ PL_no_func, "setpgrp()");
4350 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4351 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4353 # define PRIORITY_WHICH_T(which) which
4358 #ifdef HAS_GETPRIORITY
4360 const int who = POPi;
4361 const int which = TOPi;
4362 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4365 DIE(aTHX_ PL_no_func, "getpriority()");
4371 #ifdef HAS_SETPRIORITY
4373 const int niceval = POPi;
4374 const int who = POPi;
4375 const int which = TOPi;
4376 TAINT_PROPER("setpriority");
4377 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4380 DIE(aTHX_ PL_no_func, "setpriority()");
4384 #undef PRIORITY_WHICH_T
4392 XPUSHn( time(NULL) );
4394 XPUSHi( time(NULL) );
4406 (void)PerlProc_times(&PL_timesbuf);
4408 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4409 /* struct tms, though same data */
4413 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4414 if (GIMME == G_ARRAY) {
4415 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4416 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4417 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4425 if (GIMME == G_ARRAY) {
4432 DIE(aTHX_ "times not implemented");
4434 #endif /* HAS_TIMES */
4437 /* The 32 bit int year limits the times we can represent to these
4438 boundaries with a few days wiggle room to account for time zone
4441 /* Sat Jan 3 00:00:00 -2147481748 */
4442 #define TIME_LOWER_BOUND -67768100567755200.0
4443 /* Sun Dec 29 12:00:00 2147483647 */
4444 #define TIME_UPPER_BOUND 67767976233316800.0
4453 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4454 static const char * const dayname[] =
4455 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4456 static const char * const monname[] =
4457 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4458 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4460 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4463 when = (Time64_T)now;
4466 NV input = Perl_floor(POPn);
4467 when = (Time64_T)input;
4468 if (when != input) {
4469 /* diag_listed_as: gmtime(%f) too large */
4470 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4471 "%s(%.0" NVff ") too large", opname, input);
4475 if ( TIME_LOWER_BOUND > when ) {
4476 /* diag_listed_as: gmtime(%f) too small */
4477 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4478 "%s(%.0" NVff ") too small", opname, when);
4481 else if( when > TIME_UPPER_BOUND ) {
4482 /* diag_listed_as: gmtime(%f) too small */
4483 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4484 "%s(%.0" NVff ") too large", opname, when);
4488 if (PL_op->op_type == OP_LOCALTIME)
4489 err = S_localtime64_r(&when, &tmbuf);
4491 err = S_gmtime64_r(&when, &tmbuf);
4495 /* XXX %lld broken for quads */
4496 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4497 "%s(%.0" NVff ") failed", opname, when);
4500 if (GIMME != G_ARRAY) { /* scalar context */
4502 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4503 double year = (double)tmbuf.tm_year + 1900;
4510 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4511 dayname[tmbuf.tm_wday],
4512 monname[tmbuf.tm_mon],
4520 else { /* list context */
4526 mPUSHi(tmbuf.tm_sec);
4527 mPUSHi(tmbuf.tm_min);
4528 mPUSHi(tmbuf.tm_hour);
4529 mPUSHi(tmbuf.tm_mday);
4530 mPUSHi(tmbuf.tm_mon);
4531 mPUSHn(tmbuf.tm_year);
4532 mPUSHi(tmbuf.tm_wday);
4533 mPUSHi(tmbuf.tm_yday);
4534 mPUSHi(tmbuf.tm_isdst);
4545 anum = alarm((unsigned int)anum);
4551 DIE(aTHX_ PL_no_func, "alarm");
4562 (void)time(&lasttime);
4563 if (MAXARG < 1 || (!TOPs && !POPs))
4567 PerlProc_sleep((unsigned int)duration);
4570 XPUSHi(when - lasttime);
4574 /* Shared memory. */
4575 /* Merged with some message passing. */
4579 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4580 dVAR; dSP; dMARK; dTARGET;
4581 const int op_type = PL_op->op_type;
4586 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4589 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4592 value = (I32)(do_semop(MARK, SP) >= 0);
4595 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4603 return Perl_pp_semget(aTHX);
4611 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4612 dVAR; dSP; dMARK; dTARGET;
4613 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4620 DIE(aTHX_ "System V IPC is not implemented on this machine");
4626 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4627 dVAR; dSP; dMARK; dTARGET;
4628 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4636 PUSHp(zero_but_true, ZBTLEN);
4640 return Perl_pp_semget(aTHX);
4644 /* I can't const this further without getting warnings about the types of
4645 various arrays passed in from structures. */
4647 S_space_join_names_mortal(pTHX_ char *const *array)
4651 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4653 if (array && *array) {
4654 target = newSVpvs_flags("", SVs_TEMP);
4656 sv_catpv(target, *array);
4659 sv_catpvs(target, " ");
4662 target = sv_mortalcopy(&PL_sv_no);
4667 /* Get system info. */
4671 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4673 I32 which = PL_op->op_type;
4676 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4677 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4678 struct hostent *gethostbyname(Netdb_name_t);
4679 struct hostent *gethostent(void);
4681 struct hostent *hent = NULL;
4685 if (which == OP_GHBYNAME) {
4686 #ifdef HAS_GETHOSTBYNAME
4687 const char* const name = POPpbytex;
4688 hent = PerlSock_gethostbyname(name);
4690 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4693 else if (which == OP_GHBYADDR) {
4694 #ifdef HAS_GETHOSTBYADDR
4695 const int addrtype = POPi;
4696 SV * const addrsv = POPs;
4698 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4700 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4702 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4706 #ifdef HAS_GETHOSTENT
4707 hent = PerlSock_gethostent();
4709 DIE(aTHX_ PL_no_sock_func, "gethostent");
4712 #ifdef HOST_NOT_FOUND
4714 #ifdef USE_REENTRANT_API
4715 # ifdef USE_GETHOSTENT_ERRNO
4716 h_errno = PL_reentrant_buffer->_gethostent_errno;
4719 STATUS_UNIX_SET(h_errno);
4723 if (GIMME != G_ARRAY) {
4724 PUSHs(sv = sv_newmortal());
4726 if (which == OP_GHBYNAME) {
4728 sv_setpvn(sv, hent->h_addr, hent->h_length);
4731 sv_setpv(sv, (char*)hent->h_name);
4737 mPUSHs(newSVpv((char*)hent->h_name, 0));
4738 PUSHs(space_join_names_mortal(hent->h_aliases));
4739 mPUSHi(hent->h_addrtype);
4740 len = hent->h_length;
4743 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4744 mXPUSHp(*elem, len);
4748 mPUSHp(hent->h_addr, len);
4750 PUSHs(sv_mortalcopy(&PL_sv_no));
4755 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4761 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4763 I32 which = PL_op->op_type;
4765 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4766 struct netent *getnetbyaddr(Netdb_net_t, int);
4767 struct netent *getnetbyname(Netdb_name_t);
4768 struct netent *getnetent(void);
4770 struct netent *nent;
4772 if (which == OP_GNBYNAME){
4773 #ifdef HAS_GETNETBYNAME
4774 const char * const name = POPpbytex;
4775 nent = PerlSock_getnetbyname(name);
4777 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4780 else if (which == OP_GNBYADDR) {
4781 #ifdef HAS_GETNETBYADDR
4782 const int addrtype = POPi;
4783 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4784 nent = PerlSock_getnetbyaddr(addr, addrtype);
4786 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4790 #ifdef HAS_GETNETENT
4791 nent = PerlSock_getnetent();
4793 DIE(aTHX_ PL_no_sock_func, "getnetent");
4796 #ifdef HOST_NOT_FOUND
4798 #ifdef USE_REENTRANT_API
4799 # ifdef USE_GETNETENT_ERRNO
4800 h_errno = PL_reentrant_buffer->_getnetent_errno;
4803 STATUS_UNIX_SET(h_errno);
4808 if (GIMME != G_ARRAY) {
4809 PUSHs(sv = sv_newmortal());
4811 if (which == OP_GNBYNAME)
4812 sv_setiv(sv, (IV)nent->n_net);
4814 sv_setpv(sv, nent->n_name);
4820 mPUSHs(newSVpv(nent->n_name, 0));
4821 PUSHs(space_join_names_mortal(nent->n_aliases));
4822 mPUSHi(nent->n_addrtype);
4823 mPUSHi(nent->n_net);
4828 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4834 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4836 I32 which = PL_op->op_type;
4838 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4839 struct protoent *getprotobyname(Netdb_name_t);
4840 struct protoent *getprotobynumber(int);
4841 struct protoent *getprotoent(void);
4843 struct protoent *pent;
4845 if (which == OP_GPBYNAME) {
4846 #ifdef HAS_GETPROTOBYNAME
4847 const char* const name = POPpbytex;
4848 pent = PerlSock_getprotobyname(name);
4850 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4853 else if (which == OP_GPBYNUMBER) {
4854 #ifdef HAS_GETPROTOBYNUMBER
4855 const int number = POPi;
4856 pent = PerlSock_getprotobynumber(number);
4858 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4862 #ifdef HAS_GETPROTOENT
4863 pent = PerlSock_getprotoent();
4865 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4869 if (GIMME != G_ARRAY) {
4870 PUSHs(sv = sv_newmortal());
4872 if (which == OP_GPBYNAME)
4873 sv_setiv(sv, (IV)pent->p_proto);
4875 sv_setpv(sv, pent->p_name);
4881 mPUSHs(newSVpv(pent->p_name, 0));
4882 PUSHs(space_join_names_mortal(pent->p_aliases));
4883 mPUSHi(pent->p_proto);
4888 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4894 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4896 I32 which = PL_op->op_type;
4898 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4899 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4900 struct servent *getservbyport(int, Netdb_name_t);
4901 struct servent *getservent(void);
4903 struct servent *sent;
4905 if (which == OP_GSBYNAME) {
4906 #ifdef HAS_GETSERVBYNAME
4907 const char * const proto = POPpbytex;
4908 const char * const name = POPpbytex;
4909 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4911 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4914 else if (which == OP_GSBYPORT) {
4915 #ifdef HAS_GETSERVBYPORT
4916 const char * const proto = POPpbytex;
4917 unsigned short port = (unsigned short)POPu;
4918 port = PerlSock_htons(port);
4919 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4921 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4925 #ifdef HAS_GETSERVENT
4926 sent = PerlSock_getservent();
4928 DIE(aTHX_ PL_no_sock_func, "getservent");
4932 if (GIMME != G_ARRAY) {
4933 PUSHs(sv = sv_newmortal());
4935 if (which == OP_GSBYNAME) {
4936 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4939 sv_setpv(sv, sent->s_name);
4945 mPUSHs(newSVpv(sent->s_name, 0));
4946 PUSHs(space_join_names_mortal(sent->s_aliases));
4947 mPUSHi(PerlSock_ntohs(sent->s_port));
4948 mPUSHs(newSVpv(sent->s_proto, 0));
4953 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4960 const int stayopen = TOPi;
4961 switch(PL_op->op_type) {
4963 #ifdef HAS_SETHOSTENT
4964 PerlSock_sethostent(stayopen);
4966 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4969 #ifdef HAS_SETNETENT
4971 PerlSock_setnetent(stayopen);
4973 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4977 #ifdef HAS_SETPROTOENT
4978 PerlSock_setprotoent(stayopen);
4980 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4984 #ifdef HAS_SETSERVENT
4985 PerlSock_setservent(stayopen);
4987 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4997 switch(PL_op->op_type) {
4999 #ifdef HAS_ENDHOSTENT
5000 PerlSock_endhostent();
5002 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5006 #ifdef HAS_ENDNETENT
5007 PerlSock_endnetent();
5009 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5013 #ifdef HAS_ENDPROTOENT
5014 PerlSock_endprotoent();
5016 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5020 #ifdef HAS_ENDSERVENT
5021 PerlSock_endservent();
5023 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5027 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5030 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5034 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5037 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5041 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5044 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5048 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5051 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5063 I32 which = PL_op->op_type;
5065 struct passwd *pwent = NULL;
5067 * We currently support only the SysV getsp* shadow password interface.
5068 * The interface is declared in <shadow.h> and often one needs to link
5069 * with -lsecurity or some such.
5070 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5073 * AIX getpwnam() is clever enough to return the encrypted password
5074 * only if the caller (euid?) is root.
5076 * There are at least three other shadow password APIs. Many platforms
5077 * seem to contain more than one interface for accessing the shadow
5078 * password databases, possibly for compatibility reasons.
5079 * The getsp*() is by far he simplest one, the other two interfaces
5080 * are much more complicated, but also very similar to each other.
5085 * struct pr_passwd *getprpw*();
5086 * The password is in
5087 * char getprpw*(...).ufld.fd_encrypt[]
5088 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5093 * struct es_passwd *getespw*();
5094 * The password is in
5095 * char *(getespw*(...).ufld.fd_encrypt)
5096 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5099 * struct userpw *getuserpw();
5100 * The password is in
5101 * char *(getuserpw(...)).spw_upw_passwd
5102 * (but the de facto standard getpwnam() should work okay)
5104 * Mention I_PROT here so that Configure probes for it.
5106 * In HP-UX for getprpw*() the manual page claims that one should include
5107 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5108 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5109 * and pp_sys.c already includes <shadow.h> if there is such.
5111 * Note that <sys/security.h> is already probed for, but currently
5112 * it is only included in special cases.
5114 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5115 * be preferred interface, even though also the getprpw*() interface
5116 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5117 * One also needs to call set_auth_parameters() in main() before
5118 * doing anything else, whether one is using getespw*() or getprpw*().
5120 * Note that accessing the shadow databases can be magnitudes
5121 * slower than accessing the standard databases.
5126 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5127 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5128 * the pw_comment is left uninitialized. */
5129 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5135 const char* const name = POPpbytex;
5136 pwent = getpwnam(name);
5142 pwent = getpwuid(uid);
5146 # ifdef HAS_GETPWENT
5148 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5149 if (pwent) pwent = getpwnam(pwent->pw_name);
5152 DIE(aTHX_ PL_no_func, "getpwent");
5158 if (GIMME != G_ARRAY) {
5159 PUSHs(sv = sv_newmortal());
5161 if (which == OP_GPWNAM)
5162 sv_setuid(sv, pwent->pw_uid);
5164 sv_setpv(sv, pwent->pw_name);
5170 mPUSHs(newSVpv(pwent->pw_name, 0));
5174 /* If we have getspnam(), we try to dig up the shadow
5175 * password. If we are underprivileged, the shadow
5176 * interface will set the errno to EACCES or similar,
5177 * and return a null pointer. If this happens, we will
5178 * use the dummy password (usually "*" or "x") from the
5179 * standard password database.
5181 * In theory we could skip the shadow call completely
5182 * if euid != 0 but in practice we cannot know which
5183 * security measures are guarding the shadow databases
5184 * on a random platform.
5186 * Resist the urge to use additional shadow interfaces.
5187 * Divert the urge to writing an extension instead.
5190 /* Some AIX setups falsely(?) detect some getspnam(), which
5191 * has a different API than the Solaris/IRIX one. */
5192 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5195 const struct spwd * const spwent = getspnam(pwent->pw_name);
5196 /* Save and restore errno so that
5197 * underprivileged attempts seem
5198 * to have never made the unsuccessful
5199 * attempt to retrieve the shadow password. */
5201 if (spwent && spwent->sp_pwdp)
5202 sv_setpv(sv, spwent->sp_pwdp);
5206 if (!SvPOK(sv)) /* Use the standard password, then. */
5207 sv_setpv(sv, pwent->pw_passwd);
5210 /* passwd is tainted because user himself can diddle with it.
5211 * admittedly not much and in a very limited way, but nevertheless. */
5214 sv_setuid(PUSHmortal, pwent->pw_uid);
5215 sv_setgid(PUSHmortal, pwent->pw_gid);
5217 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5218 * because of the poor interface of the Perl getpw*(),
5219 * not because there's some standard/convention saying so.
5220 * A better interface would have been to return a hash,
5221 * but we are accursed by our history, alas. --jhi. */
5223 mPUSHi(pwent->pw_change);
5226 mPUSHi(pwent->pw_quota);
5229 mPUSHs(newSVpv(pwent->pw_age, 0));
5231 /* I think that you can never get this compiled, but just in case. */
5232 PUSHs(sv_mortalcopy(&PL_sv_no));
5237 /* pw_class and pw_comment are mutually exclusive--.
5238 * see the above note for pw_change, pw_quota, and pw_age. */
5240 mPUSHs(newSVpv(pwent->pw_class, 0));
5243 mPUSHs(newSVpv(pwent->pw_comment, 0));
5245 /* I think that you can never get this compiled, but just in case. */
5246 PUSHs(sv_mortalcopy(&PL_sv_no));
5251 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5253 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5255 /* pw_gecos is tainted because user himself can diddle with it. */
5258 mPUSHs(newSVpv(pwent->pw_dir, 0));
5260 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5261 /* pw_shell is tainted because user himself can diddle with it. */
5265 mPUSHi(pwent->pw_expire);
5270 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5278 const I32 which = PL_op->op_type;
5279 const struct group *grent;
5281 if (which == OP_GGRNAM) {
5282 const char* const name = POPpbytex;
5283 grent = (const struct group *)getgrnam(name);
5285 else if (which == OP_GGRGID) {
5286 const Gid_t gid = POPi;
5287 grent = (const struct group *)getgrgid(gid);
5291 grent = (struct group *)getgrent();
5293 DIE(aTHX_ PL_no_func, "getgrent");
5297 if (GIMME != G_ARRAY) {
5298 SV * const sv = sv_newmortal();
5302 if (which == OP_GGRNAM)
5303 sv_setgid(sv, grent->gr_gid);
5305 sv_setpv(sv, grent->gr_name);
5311 mPUSHs(newSVpv(grent->gr_name, 0));
5314 mPUSHs(newSVpv(grent->gr_passwd, 0));
5316 PUSHs(sv_mortalcopy(&PL_sv_no));
5319 sv_setgid(PUSHmortal, grent->gr_gid);
5321 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5322 /* In UNICOS/mk (_CRAYMPP) the multithreading
5323 * versions (getgrnam_r, getgrgid_r)
5324 * seem to return an illegal pointer
5325 * as the group members list, gr_mem.
5326 * getgrent() doesn't even have a _r version
5327 * but the gr_mem is poisonous anyway.
5328 * So yes, you cannot get the list of group
5329 * members if building multithreaded in UNICOS/mk. */
5330 PUSHs(space_join_names_mortal(grent->gr_mem));
5336 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5346 if (!(tmps = PerlProc_getlogin()))
5348 sv_setpv_mg(TARG, tmps);
5352 DIE(aTHX_ PL_no_func, "getlogin");
5356 /* Miscellaneous. */
5361 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5362 I32 items = SP - MARK;
5363 unsigned long a[20];
5368 while (++MARK <= SP) {
5369 if (SvTAINTED(*MARK)) {
5375 TAINT_PROPER("syscall");
5378 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5379 * or where sizeof(long) != sizeof(char*). But such machines will
5380 * not likely have syscall implemented either, so who cares?
5382 while (++MARK <= SP) {
5383 if (SvNIOK(*MARK) || !i)
5384 a[i++] = SvIV(*MARK);
5385 else if (*MARK == &PL_sv_undef)
5388 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5394 DIE(aTHX_ "Too many args to syscall");
5396 DIE(aTHX_ "Too few args to syscall");
5398 retval = syscall(a[0]);
5401 retval = syscall(a[0],a[1]);
5404 retval = syscall(a[0],a[1],a[2]);
5407 retval = syscall(a[0],a[1],a[2],a[3]);
5410 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5413 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5416 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5419 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5426 DIE(aTHX_ PL_no_func, "syscall");
5430 #ifdef FCNTL_EMULATE_FLOCK
5432 /* XXX Emulate flock() with fcntl().
5433 What's really needed is a good file locking module.
5437 fcntl_emulate_flock(int fd, int operation)
5442 switch (operation & ~LOCK_NB) {
5444 flock.l_type = F_RDLCK;
5447 flock.l_type = F_WRLCK;
5450 flock.l_type = F_UNLCK;
5456 flock.l_whence = SEEK_SET;
5457 flock.l_start = flock.l_len = (Off_t)0;
5459 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5460 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5461 errno = EWOULDBLOCK;
5465 #endif /* FCNTL_EMULATE_FLOCK */
5467 #ifdef LOCKF_EMULATE_FLOCK
5469 /* XXX Emulate flock() with lockf(). This is just to increase
5470 portability of scripts. The calls are not completely
5471 interchangeable. What's really needed is a good file
5475 /* The lockf() constants might have been defined in <unistd.h>.
5476 Unfortunately, <unistd.h> causes troubles on some mixed
5477 (BSD/POSIX) systems, such as SunOS 4.1.3.
5479 Further, the lockf() constants aren't POSIX, so they might not be
5480 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5481 just stick in the SVID values and be done with it. Sigh.
5485 # define F_ULOCK 0 /* Unlock a previously locked region */
5488 # define F_LOCK 1 /* Lock a region for exclusive use */
5491 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5494 # define F_TEST 3 /* Test a region for other processes locks */
5498 lockf_emulate_flock(int fd, int operation)
5504 /* flock locks entire file so for lockf we need to do the same */
5505 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5506 if (pos > 0) /* is seekable and needs to be repositioned */
5507 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5508 pos = -1; /* seek failed, so don't seek back afterwards */
5511 switch (operation) {
5513 /* LOCK_SH - get a shared lock */
5515 /* LOCK_EX - get an exclusive lock */
5517 i = lockf (fd, F_LOCK, 0);
5520 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5521 case LOCK_SH|LOCK_NB:
5522 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5523 case LOCK_EX|LOCK_NB:
5524 i = lockf (fd, F_TLOCK, 0);
5526 if ((errno == EAGAIN) || (errno == EACCES))
5527 errno = EWOULDBLOCK;
5530 /* LOCK_UN - unlock (non-blocking is a no-op) */
5532 case LOCK_UN|LOCK_NB:
5533 i = lockf (fd, F_ULOCK, 0);
5536 /* Default - can't decipher operation */
5543 if (pos > 0) /* need to restore position of the handle */
5544 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5549 #endif /* LOCKF_EMULATE_FLOCK */
5553 * c-indentation-style: bsd
5555 * indent-tabs-mode: nil
5558 * ex: set ts=8 sts=4 sw=4 et: