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];
1116 sv_force_normal_flags(sv, 0);
1117 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1118 Perl_croak_no_modify();
1121 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1122 "Non-string passed as bitmask");
1123 SvPV_force_nomg_nolen(sv); /* force string conversion */
1130 /* little endians can use vecs directly */
1131 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1138 masksize = NFDBITS / NBBY;
1140 masksize = sizeof(long); /* documented int, everyone seems to use long */
1142 Zero(&fd_sets[0], 4, char*);
1145 # if SELECT_MIN_BITS == 1
1146 growsize = sizeof(fd_set);
1148 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1149 # undef SELECT_MIN_BITS
1150 # define SELECT_MIN_BITS __FD_SETSIZE
1152 /* If SELECT_MIN_BITS is greater than one we most probably will want
1153 * to align the sizes with SELECT_MIN_BITS/8 because for example
1154 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1155 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1156 * on (sets/tests/clears bits) is 32 bits. */
1157 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1165 timebuf.tv_sec = (long)value;
1166 value -= (NV)timebuf.tv_sec;
1167 timebuf.tv_usec = (long)(value * 1000000.0);
1172 for (i = 1; i <= 3; i++) {
1174 if (!SvOK(sv) || SvCUR(sv) == 0) {
1181 Sv_Grow(sv, growsize);
1185 while (++j <= growsize) {
1189 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1191 Newx(fd_sets[i], growsize, char);
1192 for (offset = 0; offset < growsize; offset += masksize) {
1193 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1194 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1197 fd_sets[i] = SvPVX(sv);
1201 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1202 /* Can't make just the (void*) conditional because that would be
1203 * cpp #if within cpp macro, and not all compilers like that. */
1204 nfound = PerlSock_select(
1206 (Select_fd_set_t) fd_sets[1],
1207 (Select_fd_set_t) fd_sets[2],
1208 (Select_fd_set_t) fd_sets[3],
1209 (void*) tbuf); /* Workaround for compiler bug. */
1211 nfound = PerlSock_select(
1213 (Select_fd_set_t) fd_sets[1],
1214 (Select_fd_set_t) fd_sets[2],
1215 (Select_fd_set_t) fd_sets[3],
1218 for (i = 1; i <= 3; i++) {
1221 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1223 for (offset = 0; offset < growsize; offset += masksize) {
1224 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1225 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1227 Safefree(fd_sets[i]);
1234 if (GIMME == G_ARRAY && tbuf) {
1235 value = (NV)(timebuf.tv_sec) +
1236 (NV)(timebuf.tv_usec) / 1000000.0;
1241 DIE(aTHX_ "select not implemented");
1246 =for apidoc setdefout
1248 Sets PL_defoutgv, the default file handle for output, to the passed in
1249 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1250 count of the passed in typeglob is increased by one, and the reference count
1251 of the typeglob that PL_defoutgv points to is decreased by one.
1257 Perl_setdefout(pTHX_ GV *gv)
1260 PERL_ARGS_ASSERT_SETDEFOUT;
1261 SvREFCNT_inc_simple_void_NN(gv);
1262 SvREFCNT_dec(PL_defoutgv);
1270 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1271 GV * egv = GvEGVx(PL_defoutgv);
1276 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1277 gvp = hv && HvENAME(hv)
1278 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1280 if (gvp && *gvp == egv) {
1281 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1285 mXPUSHs(newRV(MUTABLE_SV(egv)));
1289 if (!GvIO(newdefout))
1290 gv_IOadd(newdefout);
1291 setdefout(newdefout);
1301 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1302 IO *const io = GvIO(gv);
1308 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1310 const U32 gimme = GIMME_V;
1311 Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1312 if (gimme == G_SCALAR) {
1314 SvSetMagicSV_nosteal(TARG, TOPs);
1319 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1320 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1322 SETERRNO(EBADF,RMS_IFI);
1326 sv_setpvs(TARG, " ");
1327 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1328 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1329 /* Find out how many bytes the char needs */
1330 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1333 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1334 SvCUR_set(TARG,1+len);
1343 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1347 const I32 gimme = GIMME_V;
1349 PERL_ARGS_ASSERT_DOFORM;
1351 if (cv && CvCLONE(cv))
1352 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1357 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1358 PUSHFORMAT(cx, retop);
1359 if (CvDEPTH(cv) >= 2) {
1360 PERL_STACK_OVERFLOW_CHECK();
1361 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1364 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1366 setdefout(gv); /* locally select filehandle so $% et al work */
1385 gv = MUTABLE_GV(POPs);
1402 tmpsv = sv_newmortal();
1403 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1404 DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
1406 IoFLAGS(io) &= ~IOf_DIDTOP;
1407 RETURNOP(doform(cv,gv,PL_op->op_next));
1413 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1414 IO * const io = GvIOp(gv);
1422 if (!io || !(ofp = IoOFP(io)))
1425 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1426 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1428 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1429 PL_formtarget != PL_toptarget)
1433 if (!IoTOP_GV(io)) {
1436 if (!IoTOP_NAME(io)) {
1438 if (!IoFMT_NAME(io))
1439 IoFMT_NAME(io) = savepv(GvNAME(gv));
1440 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1441 HEKfARG(GvNAME_HEK(gv))));
1442 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1443 if ((topgv && GvFORM(topgv)) ||
1444 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1445 IoTOP_NAME(io) = savesvpv(topname);
1447 IoTOP_NAME(io) = savepvs("top");
1449 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1450 if (!topgv || !GvFORM(topgv)) {
1451 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1454 IoTOP_GV(io) = topgv;
1456 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1457 I32 lines = IoLINES_LEFT(io);
1458 const char *s = SvPVX_const(PL_formtarget);
1459 if (lines <= 0) /* Yow, header didn't even fit!!! */
1461 while (lines-- > 0) {
1462 s = strchr(s, '\n');
1468 const STRLEN save = SvCUR(PL_formtarget);
1469 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1470 do_print(PL_formtarget, ofp);
1471 SvCUR_set(PL_formtarget, save);
1472 sv_chop(PL_formtarget, s);
1473 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1476 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1477 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1478 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1480 PL_formtarget = PL_toptarget;
1481 IoFLAGS(io) |= IOf_DIDTOP;
1483 assert(fgv); /* IoTOP_GV(io) should have been set above */
1486 SV * const sv = sv_newmortal();
1487 gv_efullname4(sv, fgv, NULL, FALSE);
1488 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1490 return doform(cv, gv, PL_op);
1494 POPBLOCK(cx,PL_curpm);
1496 retop = cx->blk_sub.retop;
1497 SP = newsp; /* ignore retval of formline */
1500 if (!io || !(fp = IoOFP(io))) {
1501 if (io && IoIFP(io))
1502 report_wrongway_fh(gv, '<');
1508 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1509 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1511 if (!do_print(PL_formtarget, fp))
1514 FmLINES(PL_formtarget) = 0;
1515 SvCUR_set(PL_formtarget, 0);
1516 *SvEND(PL_formtarget) = '\0';
1517 if (IoFLAGS(io) & IOf_FLUSH)
1518 (void)PerlIO_flush(fp);
1522 PL_formtarget = PL_bodytarget;
1523 PERL_UNUSED_VAR(gimme);
1529 dVAR; dSP; dMARK; dORIGMARK;
1533 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1534 IO *const io = GvIO(gv);
1536 /* Treat empty list as "" */
1537 if (MARK == SP) XPUSHs(&PL_sv_no);
1540 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1542 if (MARK == ORIGMARK) {
1545 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1548 return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1550 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1557 SETERRNO(EBADF,RMS_IFI);
1560 else if (!(fp = IoOFP(io))) {
1562 report_wrongway_fh(gv, '<');
1563 else if (ckWARN(WARN_CLOSED))
1565 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1569 SV *sv = sv_newmortal();
1570 do_sprintf(sv, SP - MARK, MARK + 1);
1571 if (!do_print(sv, fp))
1574 if (IoFLAGS(io) & IOf_FLUSH)
1575 if (PerlIO_flush(fp) == EOF)
1584 PUSHs(&PL_sv_undef);
1592 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1593 const int mode = POPi;
1594 SV * const sv = POPs;
1595 GV * const gv = MUTABLE_GV(POPs);
1598 /* Need TIEHANDLE method ? */
1599 const char * const tmps = SvPV_const(sv, len);
1600 /* FIXME? do_open should do const */
1601 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1602 IoLINES(GvIOp(gv)) = 0;
1606 PUSHs(&PL_sv_undef);
1613 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1627 bool charstart = FALSE;
1628 STRLEN charskip = 0;
1631 GV * const gv = MUTABLE_GV(*++MARK);
1632 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1633 && gv && (io = GvIO(gv)) )
1635 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1637 return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1638 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1647 sv_setpvs(bufsv, "");
1648 length = SvIVx(*++MARK);
1650 DIE(aTHX_ "Negative length");
1653 offset = SvIVx(*++MARK);
1657 if (!io || !IoIFP(io)) {
1659 SETERRNO(EBADF,RMS_IFI);
1662 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1663 buffer = SvPVutf8_force(bufsv, blen);
1664 /* UTF-8 may not have been set if they are all low bytes */
1669 buffer = SvPV_force(bufsv, blen);
1670 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1672 if (DO_UTF8(bufsv)) {
1673 blen = sv_len_utf8_nomg(bufsv);
1682 if (PL_op->op_type == OP_RECV) {
1683 Sock_size_t bufsize;
1684 char namebuf[MAXPATHLEN];
1685 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1686 bufsize = sizeof (struct sockaddr_in);
1688 bufsize = sizeof namebuf;
1690 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1694 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1695 /* 'offset' means 'flags' here */
1696 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1697 (struct sockaddr *)namebuf, &bufsize);
1700 /* MSG_TRUNC can give oversized count; quietly lose it */
1703 SvCUR_set(bufsv, count);
1704 *SvEND(bufsv) = '\0';
1705 (void)SvPOK_only(bufsv);
1709 /* This should not be marked tainted if the fp is marked clean */
1710 if (!(IoFLAGS(io) & IOf_UNTAINT))
1711 SvTAINTED_on(bufsv);
1713 sv_setpvn(TARG, namebuf, bufsize);
1719 if (-offset > (SSize_t)blen)
1720 DIE(aTHX_ "Offset outside string");
1723 if (DO_UTF8(bufsv)) {
1724 /* convert offset-as-chars to offset-as-bytes */
1725 if (offset >= (SSize_t)blen)
1726 offset += SvCUR(bufsv) - blen;
1728 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1731 orig_size = SvCUR(bufsv);
1732 /* Allocating length + offset + 1 isn't perfect in the case of reading
1733 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1735 (should be 2 * length + offset + 1, or possibly something longer if
1736 PL_encoding is true) */
1737 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1738 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1739 Zero(buffer+orig_size, offset-orig_size, char);
1741 buffer = buffer + offset;
1743 read_target = bufsv;
1745 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1746 concatenate it to the current buffer. */
1748 /* Truncate the existing buffer to the start of where we will be
1750 SvCUR_set(bufsv, offset);
1752 read_target = sv_newmortal();
1753 SvUPGRADE(read_target, SVt_PV);
1754 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1757 if (PL_op->op_type == OP_SYSREAD) {
1758 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1759 if (IoTYPE(io) == IoTYPE_SOCKET) {
1760 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1766 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1771 #ifdef HAS_SOCKET__bad_code_maybe
1772 if (IoTYPE(io) == IoTYPE_SOCKET) {
1773 Sock_size_t bufsize;
1774 char namebuf[MAXPATHLEN];
1775 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1776 bufsize = sizeof (struct sockaddr_in);
1778 bufsize = sizeof namebuf;
1780 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1781 (struct sockaddr *)namebuf, &bufsize);
1786 count = PerlIO_read(IoIFP(io), buffer, length);
1787 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1788 if (count == 0 && PerlIO_error(IoIFP(io)))
1792 if (IoTYPE(io) == IoTYPE_WRONLY)
1793 report_wrongway_fh(gv, '>');
1796 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1797 *SvEND(read_target) = '\0';
1798 (void)SvPOK_only(read_target);
1799 if (fp_utf8 && !IN_BYTES) {
1800 /* Look at utf8 we got back and count the characters */
1801 const char *bend = buffer + count;
1802 while (buffer < bend) {
1804 skip = UTF8SKIP(buffer);
1807 if (buffer - charskip + skip > bend) {
1808 /* partial character - try for rest of it */
1809 length = skip - (bend-buffer);
1810 offset = bend - SvPVX_const(bufsv);
1822 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1823 provided amount read (count) was what was requested (length)
1825 if (got < wanted && count == length) {
1826 length = wanted - got;
1827 offset = bend - SvPVX_const(bufsv);
1830 /* return value is character count */
1834 else if (buffer_utf8) {
1835 /* Let svcatsv upgrade the bytes we read in to utf8.
1836 The buffer is a mortal so will be freed soon. */
1837 sv_catsv_nomg(bufsv, read_target);
1840 /* This should not be marked tainted if the fp is marked clean */
1841 if (!(IoFLAGS(io) & IOf_UNTAINT))
1842 SvTAINTED_on(bufsv);
1854 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1859 STRLEN orig_blen_bytes;
1860 const int op_type = PL_op->op_type;
1863 GV *const gv = MUTABLE_GV(*++MARK);
1864 IO *const io = GvIO(gv);
1866 if (op_type == OP_SYSWRITE && io) {
1867 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1869 if (MARK == SP - 1) {
1871 mXPUSHi(sv_len(sv));
1875 return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1876 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1886 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1888 if (io && IoIFP(io))
1889 report_wrongway_fh(gv, '<');
1892 SETERRNO(EBADF,RMS_IFI);
1896 /* Do this first to trigger any overloading. */
1897 buffer = SvPV_const(bufsv, blen);
1898 orig_blen_bytes = blen;
1899 doing_utf8 = DO_UTF8(bufsv);
1901 if (PerlIO_isutf8(IoIFP(io))) {
1902 if (!SvUTF8(bufsv)) {
1903 /* We don't modify the original scalar. */
1904 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1905 buffer = (char *) tmpbuf;
1909 else if (doing_utf8) {
1910 STRLEN tmplen = blen;
1911 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1914 buffer = (char *) tmpbuf;
1918 assert((char *)result == buffer);
1919 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1924 if (op_type == OP_SEND) {
1925 const int flags = SvIVx(*++MARK);
1928 char * const sockbuf = SvPVx(*++MARK, mlen);
1929 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1930 flags, (struct sockaddr *)sockbuf, mlen);
1934 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1940 Size_t length = 0; /* This length is in characters. */
1946 /* The SV is bytes, and we've had to upgrade it. */
1947 blen_chars = orig_blen_bytes;
1949 /* The SV really is UTF-8. */
1950 /* Don't call sv_len_utf8 on a magical or overloaded
1951 scalar, as we might get back a different result. */
1952 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
1959 length = blen_chars;
1961 #if Size_t_size > IVSIZE
1962 length = (Size_t)SvNVx(*++MARK);
1964 length = (Size_t)SvIVx(*++MARK);
1966 if ((SSize_t)length < 0) {
1968 DIE(aTHX_ "Negative length");
1973 offset = SvIVx(*++MARK);
1975 if (-offset > (IV)blen_chars) {
1977 DIE(aTHX_ "Offset outside string");
1979 offset += blen_chars;
1980 } else if (offset > (IV)blen_chars) {
1982 DIE(aTHX_ "Offset outside string");
1986 if (length > blen_chars - offset)
1987 length = blen_chars - offset;
1989 /* Here we convert length from characters to bytes. */
1990 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1991 /* Either we had to convert the SV, or the SV is magical, or
1992 the SV has overloading, in which case we can't or mustn't
1993 or mustn't call it again. */
1995 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1996 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1998 /* It's a real UTF-8 SV, and it's not going to change under
1999 us. Take advantage of any cache. */
2001 I32 len_I32 = length;
2003 /* Convert the start and end character positions to bytes.
2004 Remember that the second argument to sv_pos_u2b is relative
2006 sv_pos_u2b(bufsv, &start, &len_I32);
2013 buffer = buffer+offset;
2015 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2016 if (IoTYPE(io) == IoTYPE_SOCKET) {
2017 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
2023 /* See the note at doio.c:do_print about filesize limits. --jhi */
2024 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2033 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2036 #if Size_t_size > IVSIZE
2056 * in Perl 5.12 and later, the additional parameter is a bitmask:
2059 * 2 = eof() <- ARGV magic
2061 * I'll rely on the compiler's trace flow analysis to decide whether to
2062 * actually assign this out here, or punt it into the only block where it is
2063 * used. Doing it out here is DRY on the condition logic.
2068 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2074 if (PL_op->op_flags & OPf_SPECIAL) {
2075 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2079 gv = PL_last_in_gv; /* eof */
2087 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2088 return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2091 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2092 if (io && !IoIFP(io)) {
2093 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2095 IoFLAGS(io) &= ~IOf_START;
2096 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2098 sv_setpvs(GvSV(gv), "-");
2100 GvSV(gv) = newSVpvs("-");
2101 SvSETMAGIC(GvSV(gv));
2103 else if (!nextargv(gv))
2108 PUSHs(boolSV(do_eof(gv)));
2118 if (MAXARG != 0 && (TOPs || POPs))
2119 PL_last_in_gv = MUTABLE_GV(POPs);
2126 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2128 return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2133 SETERRNO(EBADF,RMS_IFI);
2138 #if LSEEKSIZE > IVSIZE
2139 PUSHn( do_tell(gv) );
2141 PUSHi( do_tell(gv) );
2149 const int whence = POPi;
2150 #if LSEEKSIZE > IVSIZE
2151 const Off_t offset = (Off_t)SvNVx(POPs);
2153 const Off_t offset = (Off_t)SvIVx(POPs);
2156 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2157 IO *const io = GvIO(gv);
2160 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2162 #if LSEEKSIZE > IVSIZE
2163 SV *const offset_sv = newSVnv((NV) offset);
2165 SV *const offset_sv = newSViv(offset);
2168 return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2173 if (PL_op->op_type == OP_SEEK)
2174 PUSHs(boolSV(do_seek(gv, offset, whence)));
2176 const Off_t sought = do_sysseek(gv, offset, whence);
2178 PUSHs(&PL_sv_undef);
2180 SV* const sv = sought ?
2181 #if LSEEKSIZE > IVSIZE
2186 : newSVpvn(zero_but_true, ZBTLEN);
2197 /* There seems to be no consensus on the length type of truncate()
2198 * and ftruncate(), both off_t and size_t have supporters. In
2199 * general one would think that when using large files, off_t is
2200 * at least as wide as size_t, so using an off_t should be okay. */
2201 /* XXX Configure probe for the length type of *truncate() needed XXX */
2204 #if Off_t_size > IVSIZE
2209 /* Checking for length < 0 is problematic as the type might or
2210 * might not be signed: if it is not, clever compilers will moan. */
2211 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2214 SV * const sv = POPs;
2219 if (PL_op->op_flags & OPf_SPECIAL
2220 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2221 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2228 TAINT_PROPER("truncate");
2229 if (!(fp = IoIFP(io))) {
2235 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2237 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2243 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2244 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2245 goto do_ftruncate_io;
2248 const char * const name = SvPV_nomg_const_nolen(sv);
2249 TAINT_PROPER("truncate");
2251 if (truncate(name, len) < 0)
2255 const int tmpfd = PerlLIO_open(name, O_RDWR);
2260 if (my_chsize(tmpfd, len) < 0)
2262 PerlLIO_close(tmpfd);
2271 SETERRNO(EBADF,RMS_IFI);
2279 SV * const argsv = POPs;
2280 const unsigned int func = POPu;
2281 const int optype = PL_op->op_type;
2282 GV * const gv = MUTABLE_GV(POPs);
2283 IO * const io = gv ? GvIOn(gv) : NULL;
2287 if (!io || !argsv || !IoIFP(io)) {
2289 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2293 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2296 s = SvPV_force(argsv, len);
2297 need = IOCPARM_LEN(func);
2299 s = Sv_Grow(argsv, need + 1);
2300 SvCUR_set(argsv, need);
2303 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2306 retval = SvIV(argsv);
2307 s = INT2PTR(char*,retval); /* ouch */
2310 TAINT_PROPER(PL_op_desc[optype]);
2312 if (optype == OP_IOCTL)
2314 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2316 DIE(aTHX_ "ioctl is not implemented");
2320 DIE(aTHX_ "fcntl is not implemented");
2322 #if defined(OS2) && defined(__EMX__)
2323 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2325 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2329 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2331 if (s[SvCUR(argsv)] != 17)
2332 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2334 s[SvCUR(argsv)] = 0; /* put our null back */
2335 SvSETMAGIC(argsv); /* Assume it has changed */
2344 PUSHp(zero_but_true, ZBTLEN);
2355 const int argtype = POPi;
2356 GV * const gv = MUTABLE_GV(POPs);
2357 IO *const io = GvIO(gv);
2358 PerlIO *const fp = io ? IoIFP(io) : NULL;
2360 /* XXX Looks to me like io is always NULL at this point */
2362 (void)PerlIO_flush(fp);
2363 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2368 SETERRNO(EBADF,RMS_IFI);
2373 DIE(aTHX_ PL_no_func, "flock()");
2384 const int protocol = POPi;
2385 const int type = POPi;
2386 const int domain = POPi;
2387 GV * const gv = MUTABLE_GV(POPs);
2388 IO * const io = gv ? GvIOn(gv) : NULL;
2393 if (io && IoIFP(io))
2394 do_close(gv, FALSE);
2395 SETERRNO(EBADF,LIB_INVARG);
2400 do_close(gv, FALSE);
2402 TAINT_PROPER("socket");
2403 fd = PerlSock_socket(domain, type, protocol);
2406 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2407 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2408 IoTYPE(io) = IoTYPE_SOCKET;
2409 if (!IoIFP(io) || !IoOFP(io)) {
2410 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2411 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2412 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2415 #if defined(HAS_FCNTL) && defined(F_SETFD)
2416 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2425 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2427 const int protocol = POPi;
2428 const int type = POPi;
2429 const int domain = POPi;
2430 GV * const gv2 = MUTABLE_GV(POPs);
2431 GV * const gv1 = MUTABLE_GV(POPs);
2432 IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2433 IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2437 report_evil_fh(gv1);
2439 report_evil_fh(gv2);
2441 if (io1 && IoIFP(io1))
2442 do_close(gv1, FALSE);
2443 if (io2 && IoIFP(io2))
2444 do_close(gv2, FALSE);
2449 TAINT_PROPER("socketpair");
2450 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2452 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2453 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2454 IoTYPE(io1) = IoTYPE_SOCKET;
2455 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2456 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2457 IoTYPE(io2) = IoTYPE_SOCKET;
2458 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2459 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2460 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2461 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2462 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2463 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2464 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2467 #if defined(HAS_FCNTL) && defined(F_SETFD)
2468 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2469 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2474 DIE(aTHX_ PL_no_sock_func, "socketpair");
2483 SV * const addrsv = POPs;
2484 /* OK, so on what platform does bind modify addr? */
2486 GV * const gv = MUTABLE_GV(POPs);
2487 IO * const io = GvIOn(gv);
2489 const int op_type = PL_op->op_type;
2491 if (!io || !IoIFP(io))
2494 addr = SvPV_const(addrsv, len);
2495 TAINT_PROPER(PL_op_desc[op_type]);
2496 if ((op_type == OP_BIND
2497 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2498 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2506 SETERRNO(EBADF,SS_IVCHAN);
2513 const int backlog = POPi;
2514 GV * const gv = MUTABLE_GV(POPs);
2515 IO * const io = gv ? GvIOn(gv) : NULL;
2517 if (!io || !IoIFP(io))
2520 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2527 SETERRNO(EBADF,SS_IVCHAN);
2536 char namebuf[MAXPATHLEN];
2537 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2538 Sock_size_t len = sizeof (struct sockaddr_in);
2540 Sock_size_t len = sizeof namebuf;
2542 GV * const ggv = MUTABLE_GV(POPs);
2543 GV * const ngv = MUTABLE_GV(POPs);
2552 if (!gstio || !IoIFP(gstio))
2556 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2559 /* Some platforms indicate zero length when an AF_UNIX client is
2560 * not bound. Simulate a non-zero-length sockaddr structure in
2562 namebuf[0] = 0; /* sun_len */
2563 namebuf[1] = AF_UNIX; /* sun_family */
2571 do_close(ngv, FALSE);
2572 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2573 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2574 IoTYPE(nstio) = IoTYPE_SOCKET;
2575 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2576 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2577 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2578 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2581 #if defined(HAS_FCNTL) && defined(F_SETFD)
2582 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2585 #ifdef __SCO_VERSION__
2586 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2589 PUSHp(namebuf, len);
2593 report_evil_fh(ggv);
2594 SETERRNO(EBADF,SS_IVCHAN);
2604 const int how = POPi;
2605 GV * const gv = MUTABLE_GV(POPs);
2606 IO * const io = GvIOn(gv);
2608 if (!io || !IoIFP(io))
2611 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2616 SETERRNO(EBADF,SS_IVCHAN);
2623 const int optype = PL_op->op_type;
2624 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2625 const unsigned int optname = (unsigned int) POPi;
2626 const unsigned int lvl = (unsigned int) POPi;
2627 GV * const gv = MUTABLE_GV(POPs);
2628 IO * const io = GvIOn(gv);
2632 if (!io || !IoIFP(io))
2635 fd = PerlIO_fileno(IoIFP(io));
2639 (void)SvPOK_only(sv);
2643 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2650 #if defined(__SYMBIAN32__)
2651 # define SETSOCKOPT_OPTION_VALUE_T void *
2653 # define SETSOCKOPT_OPTION_VALUE_T const char *
2655 /* XXX TODO: We need to have a proper type (a Configure probe,
2656 * etc.) for what the C headers think of the third argument of
2657 * setsockopt(), the option_value read-only buffer: is it
2658 * a "char *", or a "void *", const or not. Some compilers
2659 * don't take kindly to e.g. assuming that "char *" implicitly
2660 * promotes to a "void *", or to explicitly promoting/demoting
2661 * consts to non/vice versa. The "const void *" is the SUS
2662 * definition, but that does not fly everywhere for the above
2664 SETSOCKOPT_OPTION_VALUE_T buf;
2668 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2672 aint = (int)SvIV(sv);
2673 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2676 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2686 SETERRNO(EBADF,SS_IVCHAN);
2695 const int optype = PL_op->op_type;
2696 GV * const gv = MUTABLE_GV(POPs);
2697 IO * const io = GvIOn(gv);
2702 if (!io || !IoIFP(io))
2705 sv = sv_2mortal(newSV(257));
2706 (void)SvPOK_only(sv);
2710 fd = PerlIO_fileno(IoIFP(io));
2712 case OP_GETSOCKNAME:
2713 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2716 case OP_GETPEERNAME:
2717 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2719 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2721 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";
2722 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2723 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2724 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2725 sizeof(u_short) + sizeof(struct in_addr))) {
2732 #ifdef BOGUS_GETNAME_RETURN
2733 /* Interactive Unix, getpeername() and getsockname()
2734 does not return valid namelen */
2735 if (len == BOGUS_GETNAME_RETURN)
2736 len = sizeof(struct sockaddr);
2745 SETERRNO(EBADF,SS_IVCHAN);
2764 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2765 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2766 if (PL_op->op_type == OP_LSTAT) {
2767 if (gv != PL_defgv) {
2768 do_fstat_warning_check:
2769 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2770 "lstat() on filehandle%s%"SVf,
2773 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2775 } else if (PL_laststype != OP_LSTAT)
2776 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2777 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2780 if (gv != PL_defgv) {
2784 PL_laststype = OP_STAT;
2785 PL_statgv = gv ? gv : (GV *)io;
2786 sv_setpvs(PL_statname, "");
2793 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2795 } else if (IoDIRP(io)) {
2797 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2800 PL_laststatval = -1;
2803 else PL_laststatval = -1;
2804 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2807 if (PL_laststatval < 0) {
2812 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2813 io = MUTABLE_IO(SvRV(sv));
2814 if (PL_op->op_type == OP_LSTAT)
2815 goto do_fstat_warning_check;
2816 goto do_fstat_have_io;
2819 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2820 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2822 PL_laststype = PL_op->op_type;
2823 if (PL_op->op_type == OP_LSTAT)
2824 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2826 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2827 if (PL_laststatval < 0) {
2828 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2829 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2835 if (gimme != G_ARRAY) {
2836 if (gimme != G_VOID)
2837 XPUSHs(boolSV(max));
2843 mPUSHi(PL_statcache.st_dev);
2844 #if ST_INO_SIZE > IVSIZE
2845 mPUSHn(PL_statcache.st_ino);
2847 # if ST_INO_SIGN <= 0
2848 mPUSHi(PL_statcache.st_ino);
2850 mPUSHu(PL_statcache.st_ino);
2853 mPUSHu(PL_statcache.st_mode);
2854 mPUSHu(PL_statcache.st_nlink);
2856 sv_setuid(PUSHmortal, PL_statcache.st_uid);
2857 sv_setgid(PUSHmortal, PL_statcache.st_gid);
2859 #ifdef USE_STAT_RDEV
2860 mPUSHi(PL_statcache.st_rdev);
2862 PUSHs(newSVpvs_flags("", SVs_TEMP));
2864 #if Off_t_size > IVSIZE
2865 mPUSHn(PL_statcache.st_size);
2867 mPUSHi(PL_statcache.st_size);
2870 mPUSHn(PL_statcache.st_atime);
2871 mPUSHn(PL_statcache.st_mtime);
2872 mPUSHn(PL_statcache.st_ctime);
2874 mPUSHi(PL_statcache.st_atime);
2875 mPUSHi(PL_statcache.st_mtime);
2876 mPUSHi(PL_statcache.st_ctime);
2878 #ifdef USE_STAT_BLOCKS
2879 mPUSHu(PL_statcache.st_blksize);
2880 mPUSHu(PL_statcache.st_blocks);
2882 PUSHs(newSVpvs_flags("", SVs_TEMP));
2883 PUSHs(newSVpvs_flags("", SVs_TEMP));
2889 /* All filetest ops avoid manipulating the perl stack pointer in their main
2890 bodies (since commit d2c4d2d1e22d3125), and return using either
2891 S_ft_return_false() or S_ft_return_true(). These two helper functions are
2892 the only two which manipulate the perl stack. To ensure that no stack
2893 manipulation macros are used, the filetest ops avoid defining a local copy
2894 of the stack pointer with dSP. */
2896 /* If the next filetest is stacked up with this one
2897 (PL_op->op_private & OPpFT_STACKING), we leave
2898 the original argument on the stack for success,
2899 and skip the stacked operators on failure.
2900 The next few macros/functions take care of this.
2904 S_ft_return_false(pTHX_ SV *ret) {
2908 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
2912 if (PL_op->op_private & OPpFT_STACKING) {
2913 while (OP_IS_FILETEST(next->op_type)
2914 && next->op_private & OPpFT_STACKED)
2915 next = next->op_next;
2920 PERL_STATIC_INLINE OP *
2921 S_ft_return_true(pTHX_ SV *ret) {
2923 if (PL_op->op_flags & OPf_REF)
2924 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
2925 else if (!(PL_op->op_private & OPpFT_STACKING))
2931 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
2932 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
2933 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
2935 #define tryAMAGICftest_MG(chr) STMT_START { \
2936 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
2937 && PL_op->op_flags & OPf_KIDS) { \
2938 OP *next = S_try_amagic_ftest(aTHX_ chr); \
2939 if (next) return next; \
2944 S_try_amagic_ftest(pTHX_ char chr) {
2946 SV *const arg = *PL_stack_sp;
2949 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
2953 const char tmpchr = chr;
2954 SV * const tmpsv = amagic_call(arg,
2955 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2956 ftest_amg, AMGf_unary);
2961 return SvTRUE(tmpsv)
2962 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
2972 /* Not const, because things tweak this below. Not bool, because there's
2973 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2974 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2975 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2976 /* Giving some sort of initial value silences compilers. */
2978 int access_mode = R_OK;
2980 int access_mode = 0;
2983 /* access_mode is never used, but leaving use_access in makes the
2984 conditional compiling below much clearer. */
2987 Mode_t stat_mode = S_IRUSR;
2989 bool effective = FALSE;
2992 switch (PL_op->op_type) {
2993 case OP_FTRREAD: opchar = 'R'; break;
2994 case OP_FTRWRITE: opchar = 'W'; break;
2995 case OP_FTREXEC: opchar = 'X'; break;
2996 case OP_FTEREAD: opchar = 'r'; break;
2997 case OP_FTEWRITE: opchar = 'w'; break;
2998 case OP_FTEEXEC: opchar = 'x'; break;
3000 tryAMAGICftest_MG(opchar);
3002 switch (PL_op->op_type) {
3004 #if !(defined(HAS_ACCESS) && defined(R_OK))
3010 #if defined(HAS_ACCESS) && defined(W_OK)
3015 stat_mode = S_IWUSR;
3019 #if defined(HAS_ACCESS) && defined(X_OK)
3024 stat_mode = S_IXUSR;
3028 #ifdef PERL_EFF_ACCESS
3031 stat_mode = S_IWUSR;
3035 #ifndef PERL_EFF_ACCESS
3042 #ifdef PERL_EFF_ACCESS
3047 stat_mode = S_IXUSR;
3053 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3054 const char *name = SvPV_nolen(*PL_stack_sp);
3056 # ifdef PERL_EFF_ACCESS
3057 result = PERL_EFF_ACCESS(name, access_mode);
3059 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3065 result = access(name, access_mode);
3067 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3078 result = my_stat_flags(0);
3081 if (cando(stat_mode, effective, &PL_statcache))
3090 const int op_type = PL_op->op_type;
3094 case OP_FTIS: opchar = 'e'; break;
3095 case OP_FTSIZE: opchar = 's'; break;
3096 case OP_FTMTIME: opchar = 'M'; break;
3097 case OP_FTCTIME: opchar = 'C'; break;
3098 case OP_FTATIME: opchar = 'A'; break;
3100 tryAMAGICftest_MG(opchar);
3102 result = my_stat_flags(0);
3105 if (op_type == OP_FTIS)
3108 /* You can't dTARGET inside OP_FTIS, because you'll get
3109 "panic: pad_sv po" - the op is not flagged to have a target. */
3113 #if Off_t_size > IVSIZE
3114 sv_setnv(TARG, (NV)PL_statcache.st_size);
3116 sv_setiv(TARG, (IV)PL_statcache.st_size);
3121 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3125 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3129 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3133 return SvTRUE_nomg(TARG)
3134 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3144 switch (PL_op->op_type) {
3145 case OP_FTROWNED: opchar = 'O'; break;
3146 case OP_FTEOWNED: opchar = 'o'; break;
3147 case OP_FTZERO: opchar = 'z'; break;
3148 case OP_FTSOCK: opchar = 'S'; break;
3149 case OP_FTCHR: opchar = 'c'; break;
3150 case OP_FTBLK: opchar = 'b'; break;
3151 case OP_FTFILE: opchar = 'f'; break;
3152 case OP_FTDIR: opchar = 'd'; break;
3153 case OP_FTPIPE: opchar = 'p'; break;
3154 case OP_FTSUID: opchar = 'u'; break;
3155 case OP_FTSGID: opchar = 'g'; break;
3156 case OP_FTSVTX: opchar = 'k'; break;
3158 tryAMAGICftest_MG(opchar);
3160 /* I believe that all these three are likely to be defined on most every
3161 system these days. */
3163 if(PL_op->op_type == OP_FTSUID) {
3168 if(PL_op->op_type == OP_FTSGID) {
3173 if(PL_op->op_type == OP_FTSVTX) {
3178 result = my_stat_flags(0);
3181 switch (PL_op->op_type) {
3183 if (PL_statcache.st_uid == PerlProc_getuid())
3187 if (PL_statcache.st_uid == PerlProc_geteuid())
3191 if (PL_statcache.st_size == 0)
3195 if (S_ISSOCK(PL_statcache.st_mode))
3199 if (S_ISCHR(PL_statcache.st_mode))
3203 if (S_ISBLK(PL_statcache.st_mode))
3207 if (S_ISREG(PL_statcache.st_mode))
3211 if (S_ISDIR(PL_statcache.st_mode))
3215 if (S_ISFIFO(PL_statcache.st_mode))
3220 if (PL_statcache.st_mode & S_ISUID)
3226 if (PL_statcache.st_mode & S_ISGID)
3232 if (PL_statcache.st_mode & S_ISVTX)
3245 tryAMAGICftest_MG('l');
3246 result = my_lstat_flags(0);
3250 if (S_ISLNK(PL_statcache.st_mode))
3263 tryAMAGICftest_MG('t');
3265 if (PL_op->op_flags & OPf_REF)
3268 SV *tmpsv = *PL_stack_sp;
3269 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3270 name = SvPV_nomg(tmpsv, namelen);
3271 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3275 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3276 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3277 else if (name && isDIGIT(*name))
3281 if (PerlLIO_isatty(fd))
3299 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3301 if (PL_op->op_flags & OPf_REF)
3303 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3308 gv = MAYBE_DEREF_GV_nomg(sv);
3312 if (gv == PL_defgv) {
3314 io = SvTYPE(PL_statgv) == SVt_PVIO
3318 goto really_filename;
3323 sv_setpvs(PL_statname, "");
3324 io = GvIO(PL_statgv);
3326 PL_laststatval = -1;
3327 PL_laststype = OP_STAT;
3328 if (io && IoIFP(io)) {
3329 if (! PerlIO_has_base(IoIFP(io)))
3330 DIE(aTHX_ "-T and -B not implemented on filehandles");
3331 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3332 if (PL_laststatval < 0)
3334 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3335 if (PL_op->op_type == OP_FTTEXT)
3340 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3341 i = PerlIO_getc(IoIFP(io));
3343 (void)PerlIO_ungetc(IoIFP(io),i);
3345 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3347 len = PerlIO_get_bufsiz(IoIFP(io));
3348 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3349 /* sfio can have large buffers - limit to 512 */
3354 SETERRNO(EBADF,RMS_IFI);
3356 SETERRNO(EBADF,RMS_IFI);
3361 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3364 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3366 PL_laststatval = -1;
3367 PL_laststype = OP_STAT;
3369 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3371 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3374 PL_laststype = OP_STAT;
3375 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3376 if (PL_laststatval < 0) {
3377 (void)PerlIO_close(fp);
3380 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3381 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3382 (void)PerlIO_close(fp);
3384 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3385 FT_RETURNNO; /* special case NFS directories */
3386 FT_RETURNYES; /* null file is anything */
3391 /* now scan s to look for textiness */
3392 /* XXX ASCII dependent code */
3394 #if defined(DOSISH) || defined(USEMYBINMODE)
3395 /* ignore trailing ^Z on short files */
3396 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3400 for (i = 0; i < len; i++, s++) {
3401 if (!*s) { /* null never allowed in text */
3406 else if (!(isPRINT(*s) || isSPACE(*s)))
3409 else if (*s & 128) {
3411 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3414 /* utf8 characters don't count as odd */
3415 if (UTF8_IS_START(*s)) {
3416 int ulen = UTF8SKIP(s);
3417 if (ulen < len - i) {
3419 for (j = 1; j < ulen; j++) {
3420 if (!UTF8_IS_CONTINUATION(s[j]))
3423 --ulen; /* loop does extra increment */
3433 *s != '\n' && *s != '\r' && *s != '\b' &&
3434 *s != '\t' && *s != '\f' && *s != 27)
3439 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3450 const char *tmps = NULL;
3454 SV * const sv = POPs;
3455 if (PL_op->op_flags & OPf_SPECIAL) {
3456 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3458 else if (!(gv = MAYBE_DEREF_GV(sv)))
3459 tmps = SvPV_nomg_const_nolen(sv);
3462 if( !gv && (!tmps || !*tmps) ) {
3463 HV * const table = GvHVn(PL_envgv);
3466 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3467 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3469 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3474 deprecate("chdir('') or chdir(undef) as chdir()");
3475 tmps = SvPV_nolen_const(*svp);
3479 TAINT_PROPER("chdir");
3484 TAINT_PROPER("chdir");
3487 IO* const io = GvIO(gv);
3490 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3491 } else if (IoIFP(io)) {
3492 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3496 SETERRNO(EBADF, RMS_IFI);
3502 SETERRNO(EBADF,RMS_IFI);
3506 DIE(aTHX_ PL_no_func, "fchdir");
3510 PUSHi( PerlDir_chdir(tmps) >= 0 );
3512 /* Clear the DEFAULT element of ENV so we'll get the new value
3514 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3521 dVAR; dSP; dMARK; dTARGET;
3522 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3533 char * const tmps = POPpx;
3534 TAINT_PROPER("chroot");
3535 PUSHi( chroot(tmps) >= 0 );
3538 DIE(aTHX_ PL_no_func, "chroot");
3546 const char * const tmps2 = POPpconstx;
3547 const char * const tmps = SvPV_nolen_const(TOPs);
3548 TAINT_PROPER("rename");
3550 anum = PerlLIO_rename(tmps, tmps2);
3552 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3553 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3556 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3557 (void)UNLINK(tmps2);
3558 if (!(anum = link(tmps, tmps2)))
3559 anum = UNLINK(tmps);
3567 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3571 const int op_type = PL_op->op_type;
3575 if (op_type == OP_LINK)
3576 DIE(aTHX_ PL_no_func, "link");
3578 # ifndef HAS_SYMLINK
3579 if (op_type == OP_SYMLINK)
3580 DIE(aTHX_ PL_no_func, "symlink");
3584 const char * const tmps2 = POPpconstx;
3585 const char * const tmps = SvPV_nolen_const(TOPs);
3586 TAINT_PROPER(PL_op_desc[op_type]);
3588 # if defined(HAS_LINK)
3589 # if defined(HAS_SYMLINK)
3590 /* Both present - need to choose which. */
3591 (op_type == OP_LINK) ?
3592 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3594 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3595 PerlLIO_link(tmps, tmps2);
3598 # if defined(HAS_SYMLINK)
3599 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3600 symlink(tmps, tmps2);
3605 SETi( result >= 0 );
3612 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3623 char buf[MAXPATHLEN];
3626 #ifndef INCOMPLETE_TAINTS
3630 len = readlink(tmps, buf, sizeof(buf) - 1);
3637 RETSETUNDEF; /* just pretend it's a normal file */
3641 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3643 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3645 char * const save_filename = filename;
3650 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3652 PERL_ARGS_ASSERT_DOONELINER;
3654 Newx(cmdline, size, char);
3655 my_strlcpy(cmdline, cmd, size);
3656 my_strlcat(cmdline, " ", size);
3657 for (s = cmdline + strlen(cmdline); *filename; ) {
3661 if (s - cmdline < size)
3662 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3663 myfp = PerlProc_popen(cmdline, "r");
3667 SV * const tmpsv = sv_newmortal();
3668 /* Need to save/restore 'PL_rs' ?? */
3669 s = sv_gets(tmpsv, myfp, 0);
3670 (void)PerlProc_pclose(myfp);
3674 #ifdef HAS_SYS_ERRLIST
3679 /* you don't see this */
3680 const char * const errmsg = Strerror(e) ;
3683 if (instr(s, errmsg)) {
3690 #define EACCES EPERM
3692 if (instr(s, "cannot make"))
3693 SETERRNO(EEXIST,RMS_FEX);
3694 else if (instr(s, "existing file"))
3695 SETERRNO(EEXIST,RMS_FEX);
3696 else if (instr(s, "ile exists"))
3697 SETERRNO(EEXIST,RMS_FEX);
3698 else if (instr(s, "non-exist"))
3699 SETERRNO(ENOENT,RMS_FNF);
3700 else if (instr(s, "does not exist"))
3701 SETERRNO(ENOENT,RMS_FNF);
3702 else if (instr(s, "not empty"))
3703 SETERRNO(EBUSY,SS_DEVOFFLINE);
3704 else if (instr(s, "cannot access"))
3705 SETERRNO(EACCES,RMS_PRV);
3707 SETERRNO(EPERM,RMS_PRV);
3710 else { /* some mkdirs return no failure indication */
3711 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3712 if (PL_op->op_type == OP_RMDIR)
3717 SETERRNO(EACCES,RMS_PRV); /* a guess */
3726 /* This macro removes trailing slashes from a directory name.
3727 * Different operating and file systems take differently to
3728 * trailing slashes. According to POSIX 1003.1 1996 Edition
3729 * any number of trailing slashes should be allowed.
3730 * Thusly we snip them away so that even non-conforming
3731 * systems are happy.
3732 * We should probably do this "filtering" for all
3733 * the functions that expect (potentially) directory names:
3734 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3735 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3737 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3738 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3741 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3742 (tmps) = savepvn((tmps), (len)); \
3752 const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3754 TRIMSLASHES(tmps,len,copy);
3756 TAINT_PROPER("mkdir");
3758 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3762 SETi( dooneliner("mkdir", tmps) );
3763 oldumask = PerlLIO_umask(0);
3764 PerlLIO_umask(oldumask);
3765 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3780 TRIMSLASHES(tmps,len,copy);
3781 TAINT_PROPER("rmdir");
3783 SETi( PerlDir_rmdir(tmps) >= 0 );
3785 SETi( dooneliner("rmdir", tmps) );
3792 /* Directory calls. */
3796 #if defined(Direntry_t) && defined(HAS_READDIR)
3798 const char * const dirname = POPpconstx;
3799 GV * const gv = MUTABLE_GV(POPs);
3800 IO * const io = GvIOn(gv);
3805 if ((IoIFP(io) || IoOFP(io)))
3806 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3807 "Opening filehandle %"HEKf" also as a directory",
3808 HEKfARG(GvENAME_HEK(gv)) );
3810 PerlDir_close(IoDIRP(io));
3811 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3817 SETERRNO(EBADF,RMS_DIR);
3820 DIE(aTHX_ PL_no_dir_func, "opendir");
3826 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3827 DIE(aTHX_ PL_no_dir_func, "readdir");
3829 #if !defined(I_DIRENT) && !defined(VMS)
3830 Direntry_t *readdir (DIR *);
3836 const I32 gimme = GIMME;
3837 GV * const gv = MUTABLE_GV(POPs);
3838 const Direntry_t *dp;
3839 IO * const io = GvIOn(gv);
3841 if (!io || !IoDIRP(io)) {
3842 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3843 "readdir() attempted on invalid dirhandle %"HEKf,
3844 HEKfARG(GvENAME_HEK(gv)));
3849 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3853 sv = newSVpvn(dp->d_name, dp->d_namlen);
3855 sv = newSVpv(dp->d_name, 0);
3857 #ifndef INCOMPLETE_TAINTS
3858 if (!(IoFLAGS(io) & IOf_UNTAINT))
3862 } while (gimme == G_ARRAY);
3864 if (!dp && gimme != G_ARRAY)
3871 SETERRNO(EBADF,RMS_ISI);
3872 if (GIMME == G_ARRAY)
3881 #if defined(HAS_TELLDIR) || defined(telldir)
3883 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3884 /* XXX netbsd still seemed to.
3885 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3886 --JHI 1999-Feb-02 */
3887 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3888 long telldir (DIR *);
3890 GV * const gv = MUTABLE_GV(POPs);
3891 IO * const io = GvIOn(gv);
3893 if (!io || !IoDIRP(io)) {
3894 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3895 "telldir() attempted on invalid dirhandle %"HEKf,
3896 HEKfARG(GvENAME_HEK(gv)));
3900 PUSHi( PerlDir_tell(IoDIRP(io)) );
3904 SETERRNO(EBADF,RMS_ISI);
3907 DIE(aTHX_ PL_no_dir_func, "telldir");
3913 #if defined(HAS_SEEKDIR) || defined(seekdir)
3915 const long along = POPl;
3916 GV * const gv = MUTABLE_GV(POPs);
3917 IO * const io = GvIOn(gv);
3919 if (!io || !IoDIRP(io)) {
3920 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3921 "seekdir() attempted on invalid dirhandle %"HEKf,
3922 HEKfARG(GvENAME_HEK(gv)));
3925 (void)PerlDir_seek(IoDIRP(io), along);
3930 SETERRNO(EBADF,RMS_ISI);
3933 DIE(aTHX_ PL_no_dir_func, "seekdir");
3939 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3941 GV * const gv = MUTABLE_GV(POPs);
3942 IO * const io = GvIOn(gv);
3944 if (!io || !IoDIRP(io)) {
3945 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3946 "rewinddir() attempted on invalid dirhandle %"HEKf,
3947 HEKfARG(GvENAME_HEK(gv)));
3950 (void)PerlDir_rewind(IoDIRP(io));
3954 SETERRNO(EBADF,RMS_ISI);
3957 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3963 #if defined(Direntry_t) && defined(HAS_READDIR)
3965 GV * const gv = MUTABLE_GV(POPs);
3966 IO * const io = GvIOn(gv);
3968 if (!io || !IoDIRP(io)) {
3969 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3970 "closedir() attempted on invalid dirhandle %"HEKf,
3971 HEKfARG(GvENAME_HEK(gv)));
3974 #ifdef VOID_CLOSEDIR
3975 PerlDir_close(IoDIRP(io));
3977 if (PerlDir_close(IoDIRP(io)) < 0) {
3978 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3987 SETERRNO(EBADF,RMS_IFI);
3990 DIE(aTHX_ PL_no_dir_func, "closedir");
3994 /* Process control. */
4001 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4002 sigset_t oldmask, newmask;
4006 PERL_FLUSHALL_FOR_CHILD;
4007 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4008 sigfillset(&newmask);
4009 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4011 childpid = PerlProc_fork();
4012 if (childpid == 0) {
4016 for (sig = 1; sig < SIG_SIZE; sig++)
4017 PL_psig_pend[sig] = 0;
4019 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4022 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4029 #ifdef PERL_USES_PL_PIDSTATUS
4030 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4036 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4041 PERL_FLUSHALL_FOR_CHILD;
4042 childpid = PerlProc_fork();
4048 DIE(aTHX_ PL_no_func, "fork");
4055 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4060 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4061 childpid = wait4pid(-1, &argflags, 0);
4063 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4068 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4069 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4070 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4072 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4077 DIE(aTHX_ PL_no_func, "wait");
4083 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4085 const int optype = POPi;
4086 const Pid_t pid = TOPi;
4090 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4091 result = wait4pid(pid, &argflags, optype);
4093 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4098 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4099 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4100 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4102 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4107 DIE(aTHX_ PL_no_func, "waitpid");
4113 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4114 #if defined(__LIBCATAMOUNT__)
4115 PL_statusvalue = -1;
4124 while (++MARK <= SP) {
4125 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4130 TAINT_PROPER("system");
4132 PERL_FLUSHALL_FOR_CHILD;
4133 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4138 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4139 sigset_t newset, oldset;
4142 if (PerlProc_pipe(pp) >= 0)
4144 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4145 sigemptyset(&newset);
4146 sigaddset(&newset, SIGCHLD);
4147 sigprocmask(SIG_BLOCK, &newset, &oldset);
4149 while ((childpid = PerlProc_fork()) == -1) {
4150 if (errno != EAGAIN) {
4155 PerlLIO_close(pp[0]);
4156 PerlLIO_close(pp[1]);
4158 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4159 sigprocmask(SIG_SETMASK, &oldset, NULL);
4166 Sigsave_t ihand,qhand; /* place to save signals during system() */
4170 PerlLIO_close(pp[1]);
4172 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4173 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4176 result = wait4pid(childpid, &status, 0);
4177 } while (result == -1 && errno == EINTR);
4179 #ifdef HAS_SIGPROCMASK
4180 sigprocmask(SIG_SETMASK, &oldset, NULL);
4182 (void)rsignal_restore(SIGINT, &ihand);
4183 (void)rsignal_restore(SIGQUIT, &qhand);
4185 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4186 do_execfree(); /* free any memory child malloced on fork */
4193 while (n < sizeof(int)) {
4194 n1 = PerlLIO_read(pp[0],
4195 (void*)(((char*)&errkid)+n),
4201 PerlLIO_close(pp[0]);
4202 if (n) { /* Error */
4203 if (n != sizeof(int))
4204 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4205 errno = errkid; /* Propagate errno from kid */
4206 STATUS_NATIVE_CHILD_SET(-1);
4209 XPUSHi(STATUS_CURRENT);
4212 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4213 sigprocmask(SIG_SETMASK, &oldset, NULL);
4216 PerlLIO_close(pp[0]);
4217 #if defined(HAS_FCNTL) && defined(F_SETFD)
4218 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4221 if (PL_op->op_flags & OPf_STACKED) {
4222 SV * const really = *++MARK;
4223 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4225 else if (SP - MARK != 1)
4226 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4228 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4232 #else /* ! FORK or VMS or OS/2 */
4235 if (PL_op->op_flags & OPf_STACKED) {
4236 SV * const really = *++MARK;
4237 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4238 value = (I32)do_aspawn(really, MARK, SP);
4240 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4243 else if (SP - MARK != 1) {
4244 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4245 value = (I32)do_aspawn(NULL, MARK, SP);
4247 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4251 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4253 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4255 STATUS_NATIVE_CHILD_SET(value);
4258 XPUSHi(result ? value : STATUS_CURRENT);
4259 #endif /* !FORK or VMS or OS/2 */
4266 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4271 while (++MARK <= SP) {
4272 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4277 TAINT_PROPER("exec");
4279 PERL_FLUSHALL_FOR_CHILD;
4280 if (PL_op->op_flags & OPf_STACKED) {
4281 SV * const really = *++MARK;
4282 value = (I32)do_aexec(really, MARK, SP);
4284 else if (SP - MARK != 1)
4286 value = (I32)vms_do_aexec(NULL, MARK, SP);
4288 value = (I32)do_aexec(NULL, MARK, SP);
4292 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4294 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4307 XPUSHi( getppid() );
4310 DIE(aTHX_ PL_no_func, "getppid");
4320 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4323 pgrp = (I32)BSD_GETPGRP(pid);
4325 if (pid != 0 && pid != PerlProc_getpid())
4326 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4332 DIE(aTHX_ PL_no_func, "getpgrp()");
4342 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4343 if (MAXARG > 0) pid = TOPs && TOPi;
4349 TAINT_PROPER("setpgrp");
4351 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4353 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4354 || (pid != 0 && pid != PerlProc_getpid()))
4356 DIE(aTHX_ "setpgrp can't take arguments");
4358 SETi( setpgrp() >= 0 );
4359 #endif /* USE_BSDPGRP */
4362 DIE(aTHX_ PL_no_func, "setpgrp()");
4366 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4367 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4369 # define PRIORITY_WHICH_T(which) which
4374 #ifdef HAS_GETPRIORITY
4376 const int who = POPi;
4377 const int which = TOPi;
4378 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4381 DIE(aTHX_ PL_no_func, "getpriority()");
4387 #ifdef HAS_SETPRIORITY
4389 const int niceval = POPi;
4390 const int who = POPi;
4391 const int which = TOPi;
4392 TAINT_PROPER("setpriority");
4393 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4396 DIE(aTHX_ PL_no_func, "setpriority()");
4400 #undef PRIORITY_WHICH_T
4408 XPUSHn( time(NULL) );
4410 XPUSHi( time(NULL) );
4422 (void)PerlProc_times(&PL_timesbuf);
4424 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4425 /* struct tms, though same data */
4429 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4430 if (GIMME == G_ARRAY) {
4431 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4432 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4433 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4441 if (GIMME == G_ARRAY) {
4448 DIE(aTHX_ "times not implemented");
4450 #endif /* HAS_TIMES */
4453 /* The 32 bit int year limits the times we can represent to these
4454 boundaries with a few days wiggle room to account for time zone
4457 /* Sat Jan 3 00:00:00 -2147481748 */
4458 #define TIME_LOWER_BOUND -67768100567755200.0
4459 /* Sun Dec 29 12:00:00 2147483647 */
4460 #define TIME_UPPER_BOUND 67767976233316800.0
4469 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4470 static const char * const dayname[] =
4471 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4472 static const char * const monname[] =
4473 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4474 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4476 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4479 when = (Time64_T)now;
4482 NV input = Perl_floor(POPn);
4483 when = (Time64_T)input;
4484 if (when != input) {
4485 /* diag_listed_as: gmtime(%f) too large */
4486 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4487 "%s(%.0" NVff ") too large", opname, input);
4491 if ( TIME_LOWER_BOUND > when ) {
4492 /* diag_listed_as: gmtime(%f) too small */
4493 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4494 "%s(%.0" NVff ") too small", opname, when);
4497 else if( when > TIME_UPPER_BOUND ) {
4498 /* diag_listed_as: gmtime(%f) too small */
4499 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4500 "%s(%.0" NVff ") too large", opname, when);
4504 if (PL_op->op_type == OP_LOCALTIME)
4505 err = S_localtime64_r(&when, &tmbuf);
4507 err = S_gmtime64_r(&when, &tmbuf);
4511 /* XXX %lld broken for quads */
4512 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4513 "%s(%.0" NVff ") failed", opname, when);
4516 if (GIMME != G_ARRAY) { /* scalar context */
4518 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4519 double year = (double)tmbuf.tm_year + 1900;
4526 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4527 dayname[tmbuf.tm_wday],
4528 monname[tmbuf.tm_mon],
4536 else { /* list context */
4542 mPUSHi(tmbuf.tm_sec);
4543 mPUSHi(tmbuf.tm_min);
4544 mPUSHi(tmbuf.tm_hour);
4545 mPUSHi(tmbuf.tm_mday);
4546 mPUSHi(tmbuf.tm_mon);
4547 mPUSHn(tmbuf.tm_year);
4548 mPUSHi(tmbuf.tm_wday);
4549 mPUSHi(tmbuf.tm_yday);
4550 mPUSHi(tmbuf.tm_isdst);
4561 anum = alarm((unsigned int)anum);
4567 DIE(aTHX_ PL_no_func, "alarm");
4578 (void)time(&lasttime);
4579 if (MAXARG < 1 || (!TOPs && !POPs))
4583 PerlProc_sleep((unsigned int)duration);
4586 XPUSHi(when - lasttime);
4590 /* Shared memory. */
4591 /* Merged with some message passing. */
4595 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4596 dVAR; dSP; dMARK; dTARGET;
4597 const int op_type = PL_op->op_type;
4602 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4605 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4608 value = (I32)(do_semop(MARK, SP) >= 0);
4611 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4619 return Perl_pp_semget(aTHX);
4627 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4628 dVAR; dSP; dMARK; dTARGET;
4629 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4636 DIE(aTHX_ "System V IPC is not implemented on this machine");
4642 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4643 dVAR; dSP; dMARK; dTARGET;
4644 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4652 PUSHp(zero_but_true, ZBTLEN);
4656 return Perl_pp_semget(aTHX);
4660 /* I can't const this further without getting warnings about the types of
4661 various arrays passed in from structures. */
4663 S_space_join_names_mortal(pTHX_ char *const *array)
4667 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4669 if (array && *array) {
4670 target = newSVpvs_flags("", SVs_TEMP);
4672 sv_catpv(target, *array);
4675 sv_catpvs(target, " ");
4678 target = sv_mortalcopy(&PL_sv_no);
4683 /* Get system info. */
4687 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4689 I32 which = PL_op->op_type;
4692 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4693 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4694 struct hostent *gethostbyname(Netdb_name_t);
4695 struct hostent *gethostent(void);
4697 struct hostent *hent = NULL;
4701 if (which == OP_GHBYNAME) {
4702 #ifdef HAS_GETHOSTBYNAME
4703 const char* const name = POPpbytex;
4704 hent = PerlSock_gethostbyname(name);
4706 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4709 else if (which == OP_GHBYADDR) {
4710 #ifdef HAS_GETHOSTBYADDR
4711 const int addrtype = POPi;
4712 SV * const addrsv = POPs;
4714 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4716 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4718 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4722 #ifdef HAS_GETHOSTENT
4723 hent = PerlSock_gethostent();
4725 DIE(aTHX_ PL_no_sock_func, "gethostent");
4728 #ifdef HOST_NOT_FOUND
4730 #ifdef USE_REENTRANT_API
4731 # ifdef USE_GETHOSTENT_ERRNO
4732 h_errno = PL_reentrant_buffer->_gethostent_errno;
4735 STATUS_UNIX_SET(h_errno);
4739 if (GIMME != G_ARRAY) {
4740 PUSHs(sv = sv_newmortal());
4742 if (which == OP_GHBYNAME) {
4744 sv_setpvn(sv, hent->h_addr, hent->h_length);
4747 sv_setpv(sv, (char*)hent->h_name);
4753 mPUSHs(newSVpv((char*)hent->h_name, 0));
4754 PUSHs(space_join_names_mortal(hent->h_aliases));
4755 mPUSHi(hent->h_addrtype);
4756 len = hent->h_length;
4759 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4760 mXPUSHp(*elem, len);
4764 mPUSHp(hent->h_addr, len);
4766 PUSHs(sv_mortalcopy(&PL_sv_no));
4771 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4777 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4779 I32 which = PL_op->op_type;
4781 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4782 struct netent *getnetbyaddr(Netdb_net_t, int);
4783 struct netent *getnetbyname(Netdb_name_t);
4784 struct netent *getnetent(void);
4786 struct netent *nent;
4788 if (which == OP_GNBYNAME){
4789 #ifdef HAS_GETNETBYNAME
4790 const char * const name = POPpbytex;
4791 nent = PerlSock_getnetbyname(name);
4793 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4796 else if (which == OP_GNBYADDR) {
4797 #ifdef HAS_GETNETBYADDR
4798 const int addrtype = POPi;
4799 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4800 nent = PerlSock_getnetbyaddr(addr, addrtype);
4802 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4806 #ifdef HAS_GETNETENT
4807 nent = PerlSock_getnetent();
4809 DIE(aTHX_ PL_no_sock_func, "getnetent");
4812 #ifdef HOST_NOT_FOUND
4814 #ifdef USE_REENTRANT_API
4815 # ifdef USE_GETNETENT_ERRNO
4816 h_errno = PL_reentrant_buffer->_getnetent_errno;
4819 STATUS_UNIX_SET(h_errno);
4824 if (GIMME != G_ARRAY) {
4825 PUSHs(sv = sv_newmortal());
4827 if (which == OP_GNBYNAME)
4828 sv_setiv(sv, (IV)nent->n_net);
4830 sv_setpv(sv, nent->n_name);
4836 mPUSHs(newSVpv(nent->n_name, 0));
4837 PUSHs(space_join_names_mortal(nent->n_aliases));
4838 mPUSHi(nent->n_addrtype);
4839 mPUSHi(nent->n_net);
4844 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4850 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4852 I32 which = PL_op->op_type;
4854 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4855 struct protoent *getprotobyname(Netdb_name_t);
4856 struct protoent *getprotobynumber(int);
4857 struct protoent *getprotoent(void);
4859 struct protoent *pent;
4861 if (which == OP_GPBYNAME) {
4862 #ifdef HAS_GETPROTOBYNAME
4863 const char* const name = POPpbytex;
4864 pent = PerlSock_getprotobyname(name);
4866 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4869 else if (which == OP_GPBYNUMBER) {
4870 #ifdef HAS_GETPROTOBYNUMBER
4871 const int number = POPi;
4872 pent = PerlSock_getprotobynumber(number);
4874 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4878 #ifdef HAS_GETPROTOENT
4879 pent = PerlSock_getprotoent();
4881 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4885 if (GIMME != G_ARRAY) {
4886 PUSHs(sv = sv_newmortal());
4888 if (which == OP_GPBYNAME)
4889 sv_setiv(sv, (IV)pent->p_proto);
4891 sv_setpv(sv, pent->p_name);
4897 mPUSHs(newSVpv(pent->p_name, 0));
4898 PUSHs(space_join_names_mortal(pent->p_aliases));
4899 mPUSHi(pent->p_proto);
4904 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4910 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4912 I32 which = PL_op->op_type;
4914 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4915 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4916 struct servent *getservbyport(int, Netdb_name_t);
4917 struct servent *getservent(void);
4919 struct servent *sent;
4921 if (which == OP_GSBYNAME) {
4922 #ifdef HAS_GETSERVBYNAME
4923 const char * const proto = POPpbytex;
4924 const char * const name = POPpbytex;
4925 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4927 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4930 else if (which == OP_GSBYPORT) {
4931 #ifdef HAS_GETSERVBYPORT
4932 const char * const proto = POPpbytex;
4933 unsigned short port = (unsigned short)POPu;
4934 port = PerlSock_htons(port);
4935 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4937 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4941 #ifdef HAS_GETSERVENT
4942 sent = PerlSock_getservent();
4944 DIE(aTHX_ PL_no_sock_func, "getservent");
4948 if (GIMME != G_ARRAY) {
4949 PUSHs(sv = sv_newmortal());
4951 if (which == OP_GSBYNAME) {
4952 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4955 sv_setpv(sv, sent->s_name);
4961 mPUSHs(newSVpv(sent->s_name, 0));
4962 PUSHs(space_join_names_mortal(sent->s_aliases));
4963 mPUSHi(PerlSock_ntohs(sent->s_port));
4964 mPUSHs(newSVpv(sent->s_proto, 0));
4969 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4976 const int stayopen = TOPi;
4977 switch(PL_op->op_type) {
4979 #ifdef HAS_SETHOSTENT
4980 PerlSock_sethostent(stayopen);
4982 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4985 #ifdef HAS_SETNETENT
4987 PerlSock_setnetent(stayopen);
4989 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4993 #ifdef HAS_SETPROTOENT
4994 PerlSock_setprotoent(stayopen);
4996 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5000 #ifdef HAS_SETSERVENT
5001 PerlSock_setservent(stayopen);
5003 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5013 switch(PL_op->op_type) {
5015 #ifdef HAS_ENDHOSTENT
5016 PerlSock_endhostent();
5018 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5022 #ifdef HAS_ENDNETENT
5023 PerlSock_endnetent();
5025 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5029 #ifdef HAS_ENDPROTOENT
5030 PerlSock_endprotoent();
5032 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5036 #ifdef HAS_ENDSERVENT
5037 PerlSock_endservent();
5039 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5043 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5046 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5050 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5053 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5057 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5060 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5064 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5067 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5079 I32 which = PL_op->op_type;
5081 struct passwd *pwent = NULL;
5083 * We currently support only the SysV getsp* shadow password interface.
5084 * The interface is declared in <shadow.h> and often one needs to link
5085 * with -lsecurity or some such.
5086 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5089 * AIX getpwnam() is clever enough to return the encrypted password
5090 * only if the caller (euid?) is root.
5092 * There are at least three other shadow password APIs. Many platforms
5093 * seem to contain more than one interface for accessing the shadow
5094 * password databases, possibly for compatibility reasons.
5095 * The getsp*() is by far he simplest one, the other two interfaces
5096 * are much more complicated, but also very similar to each other.
5101 * struct pr_passwd *getprpw*();
5102 * The password is in
5103 * char getprpw*(...).ufld.fd_encrypt[]
5104 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5109 * struct es_passwd *getespw*();
5110 * The password is in
5111 * char *(getespw*(...).ufld.fd_encrypt)
5112 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5115 * struct userpw *getuserpw();
5116 * The password is in
5117 * char *(getuserpw(...)).spw_upw_passwd
5118 * (but the de facto standard getpwnam() should work okay)
5120 * Mention I_PROT here so that Configure probes for it.
5122 * In HP-UX for getprpw*() the manual page claims that one should include
5123 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5124 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5125 * and pp_sys.c already includes <shadow.h> if there is such.
5127 * Note that <sys/security.h> is already probed for, but currently
5128 * it is only included in special cases.
5130 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5131 * be preferred interface, even though also the getprpw*() interface
5132 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5133 * One also needs to call set_auth_parameters() in main() before
5134 * doing anything else, whether one is using getespw*() or getprpw*().
5136 * Note that accessing the shadow databases can be magnitudes
5137 * slower than accessing the standard databases.
5142 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5143 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5144 * the pw_comment is left uninitialized. */
5145 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5151 const char* const name = POPpbytex;
5152 pwent = getpwnam(name);
5158 pwent = getpwuid(uid);
5162 # ifdef HAS_GETPWENT
5164 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5165 if (pwent) pwent = getpwnam(pwent->pw_name);
5168 DIE(aTHX_ PL_no_func, "getpwent");
5174 if (GIMME != G_ARRAY) {
5175 PUSHs(sv = sv_newmortal());
5177 if (which == OP_GPWNAM)
5178 sv_setuid(sv, pwent->pw_uid);
5180 sv_setpv(sv, pwent->pw_name);
5186 mPUSHs(newSVpv(pwent->pw_name, 0));
5190 /* If we have getspnam(), we try to dig up the shadow
5191 * password. If we are underprivileged, the shadow
5192 * interface will set the errno to EACCES or similar,
5193 * and return a null pointer. If this happens, we will
5194 * use the dummy password (usually "*" or "x") from the
5195 * standard password database.
5197 * In theory we could skip the shadow call completely
5198 * if euid != 0 but in practice we cannot know which
5199 * security measures are guarding the shadow databases
5200 * on a random platform.
5202 * Resist the urge to use additional shadow interfaces.
5203 * Divert the urge to writing an extension instead.
5206 /* Some AIX setups falsely(?) detect some getspnam(), which
5207 * has a different API than the Solaris/IRIX one. */
5208 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5211 const struct spwd * const spwent = getspnam(pwent->pw_name);
5212 /* Save and restore errno so that
5213 * underprivileged attempts seem
5214 * to have never made the unsuccessful
5215 * attempt to retrieve the shadow password. */
5217 if (spwent && spwent->sp_pwdp)
5218 sv_setpv(sv, spwent->sp_pwdp);
5222 if (!SvPOK(sv)) /* Use the standard password, then. */
5223 sv_setpv(sv, pwent->pw_passwd);
5226 # ifndef INCOMPLETE_TAINTS
5227 /* passwd is tainted because user himself can diddle with it.
5228 * admittedly not much and in a very limited way, but nevertheless. */
5232 sv_setuid(PUSHmortal, pwent->pw_uid);
5233 sv_setgid(PUSHmortal, pwent->pw_gid);
5235 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5236 * because of the poor interface of the Perl getpw*(),
5237 * not because there's some standard/convention saying so.
5238 * A better interface would have been to return a hash,
5239 * but we are accursed by our history, alas. --jhi. */
5241 mPUSHi(pwent->pw_change);
5244 mPUSHi(pwent->pw_quota);
5247 mPUSHs(newSVpv(pwent->pw_age, 0));
5249 /* I think that you can never get this compiled, but just in case. */
5250 PUSHs(sv_mortalcopy(&PL_sv_no));
5255 /* pw_class and pw_comment are mutually exclusive--.
5256 * see the above note for pw_change, pw_quota, and pw_age. */
5258 mPUSHs(newSVpv(pwent->pw_class, 0));
5261 mPUSHs(newSVpv(pwent->pw_comment, 0));
5263 /* I think that you can never get this compiled, but just in case. */
5264 PUSHs(sv_mortalcopy(&PL_sv_no));
5269 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5271 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5273 # ifndef INCOMPLETE_TAINTS
5274 /* pw_gecos is tainted because user himself can diddle with it. */
5278 mPUSHs(newSVpv(pwent->pw_dir, 0));
5280 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5281 # ifndef INCOMPLETE_TAINTS
5282 /* pw_shell is tainted because user himself can diddle with it. */
5287 mPUSHi(pwent->pw_expire);
5292 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5300 const I32 which = PL_op->op_type;
5301 const struct group *grent;
5303 if (which == OP_GGRNAM) {
5304 const char* const name = POPpbytex;
5305 grent = (const struct group *)getgrnam(name);
5307 else if (which == OP_GGRGID) {
5308 const Gid_t gid = POPi;
5309 grent = (const struct group *)getgrgid(gid);
5313 grent = (struct group *)getgrent();
5315 DIE(aTHX_ PL_no_func, "getgrent");
5319 if (GIMME != G_ARRAY) {
5320 SV * const sv = sv_newmortal();
5324 if (which == OP_GGRNAM)
5325 sv_setgid(sv, grent->gr_gid);
5327 sv_setpv(sv, grent->gr_name);
5333 mPUSHs(newSVpv(grent->gr_name, 0));
5336 mPUSHs(newSVpv(grent->gr_passwd, 0));
5338 PUSHs(sv_mortalcopy(&PL_sv_no));
5341 sv_setgid(PUSHmortal, grent->gr_gid);
5343 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5344 /* In UNICOS/mk (_CRAYMPP) the multithreading
5345 * versions (getgrnam_r, getgrgid_r)
5346 * seem to return an illegal pointer
5347 * as the group members list, gr_mem.
5348 * getgrent() doesn't even have a _r version
5349 * but the gr_mem is poisonous anyway.
5350 * So yes, you cannot get the list of group
5351 * members if building multithreaded in UNICOS/mk. */
5352 PUSHs(space_join_names_mortal(grent->gr_mem));
5358 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5368 if (!(tmps = PerlProc_getlogin()))
5370 sv_setpv_mg(TARG, tmps);
5374 DIE(aTHX_ PL_no_func, "getlogin");
5378 /* Miscellaneous. */
5383 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5384 I32 items = SP - MARK;
5385 unsigned long a[20];
5390 while (++MARK <= SP) {
5391 if (SvTAINTED(*MARK)) {
5397 TAINT_PROPER("syscall");
5400 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5401 * or where sizeof(long) != sizeof(char*). But such machines will
5402 * not likely have syscall implemented either, so who cares?
5404 while (++MARK <= SP) {
5405 if (SvNIOK(*MARK) || !i)
5406 a[i++] = SvIV(*MARK);
5407 else if (*MARK == &PL_sv_undef)
5410 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5416 DIE(aTHX_ "Too many args to syscall");
5418 DIE(aTHX_ "Too few args to syscall");
5420 retval = syscall(a[0]);
5423 retval = syscall(a[0],a[1]);
5426 retval = syscall(a[0],a[1],a[2]);
5429 retval = syscall(a[0],a[1],a[2],a[3]);
5432 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5435 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5438 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5441 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5448 DIE(aTHX_ PL_no_func, "syscall");
5452 #ifdef FCNTL_EMULATE_FLOCK
5454 /* XXX Emulate flock() with fcntl().
5455 What's really needed is a good file locking module.
5459 fcntl_emulate_flock(int fd, int operation)
5464 switch (operation & ~LOCK_NB) {
5466 flock.l_type = F_RDLCK;
5469 flock.l_type = F_WRLCK;
5472 flock.l_type = F_UNLCK;
5478 flock.l_whence = SEEK_SET;
5479 flock.l_start = flock.l_len = (Off_t)0;
5481 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5482 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5483 errno = EWOULDBLOCK;
5487 #endif /* FCNTL_EMULATE_FLOCK */
5489 #ifdef LOCKF_EMULATE_FLOCK
5491 /* XXX Emulate flock() with lockf(). This is just to increase
5492 portability of scripts. The calls are not completely
5493 interchangeable. What's really needed is a good file
5497 /* The lockf() constants might have been defined in <unistd.h>.
5498 Unfortunately, <unistd.h> causes troubles on some mixed
5499 (BSD/POSIX) systems, such as SunOS 4.1.3.
5501 Further, the lockf() constants aren't POSIX, so they might not be
5502 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5503 just stick in the SVID values and be done with it. Sigh.
5507 # define F_ULOCK 0 /* Unlock a previously locked region */
5510 # define F_LOCK 1 /* Lock a region for exclusive use */
5513 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5516 # define F_TEST 3 /* Test a region for other processes locks */
5520 lockf_emulate_flock(int fd, int operation)
5526 /* flock locks entire file so for lockf we need to do the same */
5527 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5528 if (pos > 0) /* is seekable and needs to be repositioned */
5529 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5530 pos = -1; /* seek failed, so don't seek back afterwards */
5533 switch (operation) {
5535 /* LOCK_SH - get a shared lock */
5537 /* LOCK_EX - get an exclusive lock */
5539 i = lockf (fd, F_LOCK, 0);
5542 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5543 case LOCK_SH|LOCK_NB:
5544 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5545 case LOCK_EX|LOCK_NB:
5546 i = lockf (fd, F_TLOCK, 0);
5548 if ((errno == EAGAIN) || (errno == EACCES))
5549 errno = EWOULDBLOCK;
5552 /* LOCK_UN - unlock (non-blocking is a no-op) */
5554 case LOCK_UN|LOCK_NB:
5555 i = lockf (fd, F_ULOCK, 0);
5558 /* Default - can't decipher operation */
5565 if (pos > 0) /* need to restore position of the handle */
5566 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5571 #endif /* LOCKF_EMULATE_FLOCK */
5575 * c-indentation-style: bsd
5577 * indent-tabs-mode: nil
5580 * ex: set ts=8 sts=4 sw=4 et: