3 * Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 * 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * But only a short way ahead its floor and the walls on either side were
13 * cloven by a great fissure, out of which the red glare came, now leaping
14 * up, now dying down into darkness; and all the while far below there was
15 * a rumour and a trouble as of great engines throbbing and labouring.
17 * [p.945 of _The Lord of the Rings_, VI/iii: "Mount Doom"]
20 /* This file contains system pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
26 * By 'system', we mean ops which interact with the OS, such as pp_open().
30 #define PERL_IN_PP_SYS_C
36 /* Shadow password support for solaris - pdo@cs.umd.edu
37 * Not just Solaris: at least HP-UX, IRIX, Linux.
38 * The API is from SysV.
40 * There are at least two more shadow interfaces,
41 * see the comments in pp_gpwent().
45 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
46 * and another MAXINT from "perl.h" <- <sys/param.h>. */
53 # include <sys/resource.h>
62 # include <sys/select.h>
66 /* XXX Configure test needed.
67 h_errno might not be a simple 'int', especially for multi-threaded
68 applications, see "extern int errno in perl.h". Creating such
69 a test requires taking into account the differences between
70 compiling multithreaded and singlethreaded ($ccflags et al).
71 HOST_NOT_FOUND is typically defined in <netdb.h>.
73 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
82 struct passwd *getpwnam (char *);
83 struct passwd *getpwuid (Uid_t);
88 struct passwd *getpwent (void);
89 #elif defined (VMS) && defined (my_getpwent)
90 struct passwd *Perl_my_getpwent (pTHX);
99 struct group *getgrnam (char *);
100 struct group *getgrgid (Gid_t);
104 struct group *getgrent (void);
110 # if defined(_MSC_VER) || defined(__MINGW32__)
111 # include <sys/utime.h>
118 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
121 # define my_chsize PerlLIO_chsize
124 # define my_chsize PerlLIO_chsize
126 I32 my_chsize(int fd, Off_t length);
132 #else /* no flock() */
134 /* fcntl.h might not have been included, even if it exists, because
135 the current Configure only sets I_FCNTL if it's needed to pick up
136 the *_OK constants. Make sure it has been included before testing
137 the fcntl() locking constants. */
138 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
142 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
143 # define FLOCK fcntl_emulate_flock
144 # define FCNTL_EMULATE_FLOCK
145 # else /* no flock() or fcntl(F_SETLK,...) */
147 # define FLOCK lockf_emulate_flock
148 # define LOCKF_EMULATE_FLOCK
150 # endif /* no flock() or fcntl(F_SETLK,...) */
153 static int FLOCK (int, int);
156 * These are the flock() constants. Since this sytems doesn't have
157 * flock(), the values of the constants are probably not available.
171 # endif /* emulating flock() */
173 #endif /* no flock() */
176 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
178 #if defined(I_SYS_ACCESS) && !defined(R_OK)
179 # include <sys/access.h>
182 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
183 # define FD_CLOEXEC 1 /* NeXT needs this */
189 /* Missing protos on LynxOS */
190 void sethostent(int);
191 void endhostent(void);
193 void endnetent(void);
194 void setprotoent(int);
195 void endprotoent(void);
196 void setservent(int);
197 void endservent(void);
200 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
202 /* F_OK unused: if stat() cannot find it... */
204 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
205 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
206 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
209 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
210 # ifdef I_SYS_SECURITY
211 # include <sys/security.h>
215 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
218 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
222 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
224 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
228 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
229 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
230 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
233 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
235 const Uid_t ruid = getuid();
236 const Uid_t euid = geteuid();
237 const Gid_t rgid = getgid();
238 const Gid_t egid = getegid();
241 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
242 Perl_croak(aTHX_ "switching effective uid is not implemented");
245 if (setreuid(euid, ruid))
248 if (setresuid(euid, ruid, (Uid_t)-1))
251 /* diag_listed_as: entering effective %s failed */
252 Perl_croak(aTHX_ "entering effective uid failed");
255 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
256 Perl_croak(aTHX_ "switching effective gid is not implemented");
259 if (setregid(egid, rgid))
262 if (setresgid(egid, rgid, (Gid_t)-1))
265 /* diag_listed_as: entering effective %s failed */
266 Perl_croak(aTHX_ "entering effective gid failed");
269 res = access(path, mode);
272 if (setreuid(ruid, euid))
275 if (setresuid(ruid, euid, (Uid_t)-1))
278 /* diag_listed_as: leaving effective %s failed */
279 Perl_croak(aTHX_ "leaving effective uid failed");
282 if (setregid(rgid, egid))
285 if (setresgid(rgid, egid, (Gid_t)-1))
288 /* diag_listed_as: leaving effective %s failed */
289 Perl_croak(aTHX_ "leaving effective gid failed");
293 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
300 const char * const tmps = POPpconstx;
301 const I32 gimme = GIMME_V;
302 const char *mode = "r";
305 if (PL_op->op_private & OPpOPEN_IN_RAW)
307 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
309 fp = PerlProc_popen(tmps, mode);
311 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
313 PerlIO_apply_layers(aTHX_ fp,mode,type);
315 if (gimme == G_VOID) {
317 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
320 else if (gimme == G_SCALAR) {
321 ENTER_with_name("backtick");
323 PL_rs = &PL_sv_undef;
324 sv_setpvs(TARG, ""); /* note that this preserves previous buffer */
325 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
327 LEAVE_with_name("backtick");
333 SV * const sv = newSV(79);
334 if (sv_gets(sv, fp, 0) == NULL) {
339 if (SvLEN(sv) - SvCUR(sv) > 20) {
340 SvPV_shrink_to_cur(sv);
345 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
346 TAINT; /* "I believe that this is not gratuitous!" */
349 STATUS_NATIVE_CHILD_SET(-1);
350 if (gimme == G_SCALAR)
362 GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs;
366 /* make a copy of the pattern if it is gmagical, to ensure that magic
367 * is called once and only once */
368 if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs));
370 tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL));
372 if (PL_op->op_flags & OPf_SPECIAL) {
373 /* call Perl-level glob function instead. Stack args are:
375 * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
384 /* Note that we only ever get here if File::Glob fails to load
385 * without at the same time croaking, for some reason, or if
386 * perl was built with PERL_EXTERNAL_GLOB */
388 ENTER_with_name("glob");
393 * The external globbing program may use things we can't control,
394 * so for security reasons we must assume the worst.
397 taint_proper(PL_no_security, "glob");
401 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
404 SAVESPTR(PL_rs); /* This is not permanent, either. */
405 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
408 *SvPVX(PL_rs) = '\n';
412 result = do_readline();
413 LEAVE_with_name("glob");
420 PL_last_in_gv = cGVOP_gv;
421 return do_readline();
431 do_join(TARG, &PL_sv_no, MARK, SP);
435 else if (SP == MARK) {
442 if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
445 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
446 /* well-formed exception supplied */
449 SV * const errsv = ERRSV;
452 if (SvGMAGICAL(errsv)) {
453 exsv = sv_newmortal();
454 sv_setsv_nomg(exsv, errsv);
458 else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) {
459 exsv = sv_newmortal();
460 sv_setsv_nomg(exsv, errsv);
461 sv_catpvs(exsv, "\t...caught");
464 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
467 if (SvROK(exsv) && !PL_warnhook)
468 Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
479 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
481 if (SP - MARK != 1) {
483 do_join(TARG, &PL_sv_no, MARK, SP);
491 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
492 /* well-formed exception supplied */
495 SV * const errsv = ERRSV;
499 if (sv_isobject(exsv)) {
500 HV * const stash = SvSTASH(SvRV(exsv));
501 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
503 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
504 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
511 call_sv(MUTABLE_SV(GvCV(gv)),
512 G_SCALAR|G_EVAL|G_KEEPERR);
513 exsv = sv_mortalcopy(*PL_stack_sp--);
517 else if (SvPOK(errsv) && SvCUR(errsv)) {
518 exsv = sv_mortalcopy(errsv);
519 sv_catpvs(exsv, "\t...propagated");
522 exsv = newSVpvs_flags("Died", SVs_TEMP);
531 Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv,
532 const MAGIC *const mg, const U32 flags, U32 argc, ...)
537 PERL_ARGS_ASSERT_TIED_METHOD;
539 /* Ensure that our flag bits do not overlap. */
540 assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
541 assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
542 assert((TIED_METHOD_SAY & G_WANT) == 0);
544 PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
545 PUSHSTACKi(PERLSI_MAGIC);
546 EXTEND(SP, argc+1); /* object + args */
548 PUSHs(SvTIED_obj(sv, mg));
549 if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
550 Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
554 const U32 mortalize_not_needed
555 = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
557 va_start(args, argc);
559 SV *const arg = va_arg(args, SV *);
560 if(mortalize_not_needed)
569 ENTER_with_name("call_tied_method");
570 if (flags & TIED_METHOD_SAY) {
571 /* local $\ = "\n" */
572 SAVEGENERICSV(PL_ors_sv);
573 PL_ors_sv = newSVpvs("\n");
575 ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED);
580 if (ret_args) { /* copy results back to original stack */
581 EXTEND(sp, ret_args);
582 Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
586 LEAVE_with_name("call_tied_method");
590 #define tied_method0(a,b,c,d) \
591 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
592 #define tied_method1(a,b,c,d,e) \
593 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
594 #define tied_method2(a,b,c,d,e,f) \
595 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
608 GV * const gv = MUTABLE_GV(*++MARK);
610 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
611 DIE(aTHX_ PL_no_usym, "filehandle");
613 if ((io = GvIOp(gv))) {
615 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
618 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
619 "Opening dirhandle %"HEKf" also as a file",
620 HEKfARG(GvENAME_HEK(gv)));
622 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
624 /* Method's args are same as ours ... */
625 /* ... except handle is replaced by the object */
626 return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg,
627 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
639 tmps = SvPV_const(sv, len);
640 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
643 PUSHi( (I32)PL_forkprocess );
644 else if (PL_forkprocess == 0) /* we are a new child */
655 MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
661 IO * const io = GvIO(gv);
663 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
665 return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg);
669 PUSHs(boolSV(do_close(gv, TRUE)));
682 GV * const wgv = MUTABLE_GV(POPs);
683 GV * const rgv = MUTABLE_GV(POPs);
688 if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
689 DIE(aTHX_ PL_no_usym, "filehandle");
694 do_close(rgv, FALSE);
696 do_close(wgv, FALSE);
698 if (PerlProc_pipe(fd) < 0)
701 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
702 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
703 IoOFP(rstio) = IoIFP(rstio);
704 IoIFP(wstio) = IoOFP(wstio);
705 IoTYPE(rstio) = IoTYPE_RDONLY;
706 IoTYPE(wstio) = IoTYPE_WRONLY;
708 if (!IoIFP(rstio) || !IoOFP(wstio)) {
710 PerlIO_close(IoIFP(rstio));
712 PerlLIO_close(fd[0]);
714 PerlIO_close(IoOFP(wstio));
716 PerlLIO_close(fd[1]);
719 #if defined(HAS_FCNTL) && defined(F_SETFD)
720 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
721 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
728 DIE(aTHX_ PL_no_func, "pipe");
742 gv = MUTABLE_GV(POPs);
746 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
748 return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg);
751 if (!io || !(fp = IoIFP(io))) {
752 /* Can't do this because people seem to do things like
753 defined(fileno($foo)) to check whether $foo is a valid fh.
760 PUSHi(PerlIO_fileno(fp));
772 if (MAXARG < 1 || (!TOPs && !POPs)) {
773 anum = PerlLIO_umask(022);
774 /* setting it to 022 between the two calls to umask avoids
775 * to have a window where the umask is set to 0 -- meaning
776 * that another thread could create world-writeable files. */
778 (void)PerlLIO_umask(anum);
781 anum = PerlLIO_umask(POPi);
782 TAINT_PROPER("umask");
785 /* Only DIE if trying to restrict permissions on "user" (self).
786 * Otherwise it's harmless and more useful to just return undef
787 * since 'group' and 'other' concepts probably don't exist here. */
788 if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
789 DIE(aTHX_ "umask not implemented");
790 XPUSHs(&PL_sv_undef);
809 gv = MUTABLE_GV(POPs);
813 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
815 /* This takes advantage of the implementation of the varargs
816 function, which I don't think that the optimiser will be able to
817 figure out. Although, as it's a static function, in theory it
819 return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg,
820 G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
821 discp ? 1 : 0, discp);
825 if (!io || !(fp = IoIFP(io))) {
827 SETERRNO(EBADF,RMS_IFI);
834 const char *d = NULL;
837 d = SvPV_const(discp, len);
838 mode = mode_from_discipline(d, len);
839 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
840 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
841 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
862 const I32 markoff = MARK - PL_stack_base;
863 const char *methname;
864 int how = PERL_MAGIC_tied;
868 switch(SvTYPE(varsv)) {
872 methname = "TIEHASH";
873 if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
874 HvLAZYDEL_off(varsv);
875 hv_free_ent((HV *)varsv, entry);
877 HvEITER_set(MUTABLE_HV(varsv), 0);
881 methname = "TIEARRAY";
882 if (!AvREAL(varsv)) {
884 Perl_croak(aTHX_ "Cannot tie unreifiable array");
885 av_clear((AV *)varsv);
892 if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
893 methname = "TIEHANDLE";
894 how = PERL_MAGIC_tiedscalar;
895 /* For tied filehandles, we apply tiedscalar magic to the IO
896 slot of the GP rather than the GV itself. AMS 20010812 */
898 GvIOp(varsv) = newIO();
899 varsv = MUTABLE_SV(GvIOp(varsv));
902 if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
903 vivify_defelem(varsv);
904 varsv = LvTARG(varsv);
908 methname = "TIESCALAR";
909 how = PERL_MAGIC_tiedscalar;
913 if (sv_isobject(*MARK)) { /* Calls GET magic. */
914 ENTER_with_name("call_TIE");
915 PUSHSTACKi(PERLSI_MAGIC);
917 EXTEND(SP,(I32)items);
921 call_method(methname, G_SCALAR);
924 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
925 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
926 * wrong error message, and worse case, supreme action at a distance.
927 * (Sorry obfuscation writers. You're not going to be given this one.)
929 stash = gv_stashsv(*MARK, 0);
930 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
931 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
932 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
934 ENTER_with_name("call_TIE");
935 PUSHSTACKi(PERLSI_MAGIC);
937 EXTEND(SP,(I32)items);
941 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
947 if (sv_isobject(sv)) {
948 sv_unmagic(varsv, how);
949 /* Croak if a self-tie on an aggregate is attempted. */
950 if (varsv == SvRV(sv) &&
951 (SvTYPE(varsv) == SVt_PVAV ||
952 SvTYPE(varsv) == SVt_PVHV))
954 "Self-ties of arrays and hashes are not supported");
955 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
957 LEAVE_with_name("call_TIE");
958 SP = PL_stack_base + markoff;
968 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
969 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
971 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
974 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
975 !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
977 if ((mg = SvTIED_mg(sv, how))) {
978 SV * const obj = SvRV(SvTIED_obj(sv, mg));
980 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
982 if (gv && isGV(gv) && (cv = GvCV(gv))) {
984 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
985 mXPUSHi(SvREFCNT(obj) - 1);
987 ENTER_with_name("call_UNTIE");
988 call_sv(MUTABLE_SV(cv), G_VOID);
989 LEAVE_with_name("call_UNTIE");
992 else if (mg && SvREFCNT(obj) > 1) {
993 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
994 "untie attempted while %"UVuf" inner references still exist",
995 (UV)SvREFCNT(obj) - 1 ) ;
999 sv_unmagic(sv, how) ;
1009 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1010 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1012 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1015 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1016 !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
1018 if ((mg = SvTIED_mg(sv, how))) {
1019 PUSHs(SvTIED_obj(sv, mg));
1032 HV * const hv = MUTABLE_HV(POPs);
1033 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1034 stash = gv_stashsv(sv, 0);
1035 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1037 require_pv("AnyDBM_File.pm");
1039 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1040 DIE(aTHX_ "No dbm on this machine");
1050 mPUSHu(O_RDWR|O_CREAT);
1054 if (!SvOK(right)) right = &PL_sv_no;
1058 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1061 if (!sv_isobject(TOPs)) {
1069 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1073 if (sv_isobject(TOPs)) {
1074 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1075 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1092 struct timeval timebuf;
1093 struct timeval *tbuf = &timebuf;
1096 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1101 # if BYTEORDER & 0xf0000
1102 # define ORDERBYTE (0x88888888 - BYTEORDER)
1104 # define ORDERBYTE (0x4444 - BYTEORDER)
1110 for (i = 1; i <= 3; i++) {
1111 SV * const sv = SP[i];
1115 if (SvREADONLY(sv)) {
1116 if (!(SvPOK(sv) && SvCUR(sv) == 0))
1117 Perl_croak_no_modify();
1119 else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
1122 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1123 "Non-string passed as bitmask");
1124 SvPV_force_nomg_nolen(sv); /* force string conversion */
1131 /* little endians can use vecs directly */
1132 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1139 masksize = NFDBITS / NBBY;
1141 masksize = sizeof(long); /* documented int, everyone seems to use long */
1143 Zero(&fd_sets[0], 4, char*);
1146 # if SELECT_MIN_BITS == 1
1147 growsize = sizeof(fd_set);
1149 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1150 # undef SELECT_MIN_BITS
1151 # define SELECT_MIN_BITS __FD_SETSIZE
1153 /* If SELECT_MIN_BITS is greater than one we most probably will want
1154 * to align the sizes with SELECT_MIN_BITS/8 because for example
1155 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1156 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1157 * on (sets/tests/clears bits) is 32 bits. */
1158 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1166 timebuf.tv_sec = (long)value;
1167 value -= (NV)timebuf.tv_sec;
1168 timebuf.tv_usec = (long)(value * 1000000.0);
1173 for (i = 1; i <= 3; i++) {
1175 if (!SvOK(sv) || SvCUR(sv) == 0) {
1182 Sv_Grow(sv, growsize);
1186 while (++j <= growsize) {
1190 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1192 Newx(fd_sets[i], growsize, char);
1193 for (offset = 0; offset < growsize; offset += masksize) {
1194 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1195 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1198 fd_sets[i] = SvPVX(sv);
1202 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1203 /* Can't make just the (void*) conditional because that would be
1204 * cpp #if within cpp macro, and not all compilers like that. */
1205 nfound = PerlSock_select(
1207 (Select_fd_set_t) fd_sets[1],
1208 (Select_fd_set_t) fd_sets[2],
1209 (Select_fd_set_t) fd_sets[3],
1210 (void*) tbuf); /* Workaround for compiler bug. */
1212 nfound = PerlSock_select(
1214 (Select_fd_set_t) fd_sets[1],
1215 (Select_fd_set_t) fd_sets[2],
1216 (Select_fd_set_t) fd_sets[3],
1219 for (i = 1; i <= 3; i++) {
1222 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1224 for (offset = 0; offset < growsize; offset += masksize) {
1225 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1226 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1228 Safefree(fd_sets[i]);
1235 if (GIMME == G_ARRAY && tbuf) {
1236 value = (NV)(timebuf.tv_sec) +
1237 (NV)(timebuf.tv_usec) / 1000000.0;
1242 DIE(aTHX_ "select not implemented");
1247 =for apidoc setdefout
1249 Sets PL_defoutgv, the default file handle for output, to the passed in
1250 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1251 count of the passed in typeglob is increased by one, and the reference count
1252 of the typeglob that PL_defoutgv points to is decreased by one.
1258 Perl_setdefout(pTHX_ GV *gv)
1261 PERL_ARGS_ASSERT_SETDEFOUT;
1262 SvREFCNT_inc_simple_void_NN(gv);
1263 SvREFCNT_dec(PL_defoutgv);
1271 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1272 GV * egv = GvEGVx(PL_defoutgv);
1277 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1278 gvp = hv && HvENAME(hv)
1279 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1281 if (gvp && *gvp == egv) {
1282 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1286 mXPUSHs(newRV(MUTABLE_SV(egv)));
1290 if (!GvIO(newdefout))
1291 gv_IOadd(newdefout);
1292 setdefout(newdefout);
1302 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1303 IO *const io = GvIO(gv);
1309 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1311 const U32 gimme = GIMME_V;
1312 Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1313 if (gimme == G_SCALAR) {
1315 SvSetMagicSV_nosteal(TARG, TOPs);
1320 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1321 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1323 SETERRNO(EBADF,RMS_IFI);
1327 sv_setpvs(TARG, " ");
1328 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1329 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1330 /* Find out how many bytes the char needs */
1331 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1334 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1335 SvCUR_set(TARG,1+len);
1344 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1348 const I32 gimme = GIMME_V;
1350 PERL_ARGS_ASSERT_DOFORM;
1352 if (cv && CvCLONE(cv))
1353 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1358 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1359 PUSHFORMAT(cx, retop);
1360 if (CvDEPTH(cv) >= 2) {
1361 PERL_STACK_OVERFLOW_CHECK();
1362 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1365 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1367 setdefout(gv); /* locally select filehandle so $% et al work */
1386 gv = MUTABLE_GV(POPs);
1403 tmpsv = sv_newmortal();
1404 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1405 DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
1407 IoFLAGS(io) &= ~IOf_DIDTOP;
1408 RETURNOP(doform(cv,gv,PL_op->op_next));
1414 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1415 IO * const io = GvIOp(gv);
1423 if (!io || !(ofp = IoOFP(io)))
1426 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1427 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1429 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1430 PL_formtarget != PL_toptarget)
1434 if (!IoTOP_GV(io)) {
1437 if (!IoTOP_NAME(io)) {
1439 if (!IoFMT_NAME(io))
1440 IoFMT_NAME(io) = savepv(GvNAME(gv));
1441 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1442 HEKfARG(GvNAME_HEK(gv))));
1443 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1444 if ((topgv && GvFORM(topgv)) ||
1445 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1446 IoTOP_NAME(io) = savesvpv(topname);
1448 IoTOP_NAME(io) = savepvs("top");
1450 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1451 if (!topgv || !GvFORM(topgv)) {
1452 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1455 IoTOP_GV(io) = topgv;
1457 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1458 I32 lines = IoLINES_LEFT(io);
1459 const char *s = SvPVX_const(PL_formtarget);
1460 if (lines <= 0) /* Yow, header didn't even fit!!! */
1462 while (lines-- > 0) {
1463 s = strchr(s, '\n');
1469 const STRLEN save = SvCUR(PL_formtarget);
1470 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1471 do_print(PL_formtarget, ofp);
1472 SvCUR_set(PL_formtarget, save);
1473 sv_chop(PL_formtarget, s);
1474 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1477 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1478 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1479 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1481 PL_formtarget = PL_toptarget;
1482 IoFLAGS(io) |= IOf_DIDTOP;
1484 assert(fgv); /* IoTOP_GV(io) should have been set above */
1487 SV * const sv = sv_newmortal();
1488 gv_efullname4(sv, fgv, NULL, FALSE);
1489 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1491 return doform(cv, gv, PL_op);
1495 POPBLOCK(cx,PL_curpm);
1497 retop = cx->blk_sub.retop;
1498 SP = newsp; /* ignore retval of formline */
1501 if (!io || !(fp = IoOFP(io))) {
1502 if (io && IoIFP(io))
1503 report_wrongway_fh(gv, '<');
1509 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1510 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1512 if (!do_print(PL_formtarget, fp))
1515 FmLINES(PL_formtarget) = 0;
1516 SvCUR_set(PL_formtarget, 0);
1517 *SvEND(PL_formtarget) = '\0';
1518 if (IoFLAGS(io) & IOf_FLUSH)
1519 (void)PerlIO_flush(fp);
1523 PL_formtarget = PL_bodytarget;
1524 PERL_UNUSED_VAR(gimme);
1530 dVAR; dSP; dMARK; dORIGMARK;
1534 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1535 IO *const io = GvIO(gv);
1537 /* Treat empty list as "" */
1538 if (MARK == SP) XPUSHs(&PL_sv_no);
1541 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1543 if (MARK == ORIGMARK) {
1546 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1549 return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1551 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1558 SETERRNO(EBADF,RMS_IFI);
1561 else if (!(fp = IoOFP(io))) {
1563 report_wrongway_fh(gv, '<');
1564 else if (ckWARN(WARN_CLOSED))
1566 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1570 SV *sv = sv_newmortal();
1571 do_sprintf(sv, SP - MARK, MARK + 1);
1572 if (!do_print(sv, fp))
1575 if (IoFLAGS(io) & IOf_FLUSH)
1576 if (PerlIO_flush(fp) == EOF)
1585 PUSHs(&PL_sv_undef);
1593 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1594 const int mode = POPi;
1595 SV * const sv = POPs;
1596 GV * const gv = MUTABLE_GV(POPs);
1599 /* Need TIEHANDLE method ? */
1600 const char * const tmps = SvPV_const(sv, len);
1601 /* FIXME? do_open should do const */
1602 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1603 IoLINES(GvIOp(gv)) = 0;
1607 PUSHs(&PL_sv_undef);
1614 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1628 bool charstart = FALSE;
1629 STRLEN charskip = 0;
1632 GV * const gv = MUTABLE_GV(*++MARK);
1633 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1634 && gv && (io = GvIO(gv)) )
1636 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1638 return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1639 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1648 sv_setpvs(bufsv, "");
1649 length = SvIVx(*++MARK);
1651 DIE(aTHX_ "Negative length");
1654 offset = SvIVx(*++MARK);
1658 if (!io || !IoIFP(io)) {
1660 SETERRNO(EBADF,RMS_IFI);
1663 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1664 buffer = SvPVutf8_force(bufsv, blen);
1665 /* UTF-8 may not have been set if they are all low bytes */
1670 buffer = SvPV_force(bufsv, blen);
1671 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1673 if (DO_UTF8(bufsv)) {
1674 blen = sv_len_utf8_nomg(bufsv);
1683 if (PL_op->op_type == OP_RECV) {
1684 Sock_size_t bufsize;
1685 char namebuf[MAXPATHLEN];
1686 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1687 bufsize = sizeof (struct sockaddr_in);
1689 bufsize = sizeof namebuf;
1691 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1695 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1696 /* 'offset' means 'flags' here */
1697 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1698 (struct sockaddr *)namebuf, &bufsize);
1701 /* MSG_TRUNC can give oversized count; quietly lose it */
1704 SvCUR_set(bufsv, count);
1705 *SvEND(bufsv) = '\0';
1706 (void)SvPOK_only(bufsv);
1710 /* This should not be marked tainted if the fp is marked clean */
1711 if (!(IoFLAGS(io) & IOf_UNTAINT))
1712 SvTAINTED_on(bufsv);
1714 sv_setpvn(TARG, namebuf, bufsize);
1720 if (-offset > (SSize_t)blen)
1721 DIE(aTHX_ "Offset outside string");
1724 if (DO_UTF8(bufsv)) {
1725 /* convert offset-as-chars to offset-as-bytes */
1726 if (offset >= (SSize_t)blen)
1727 offset += SvCUR(bufsv) - blen;
1729 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1732 orig_size = SvCUR(bufsv);
1733 /* Allocating length + offset + 1 isn't perfect in the case of reading
1734 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1736 (should be 2 * length + offset + 1, or possibly something longer if
1737 PL_encoding is true) */
1738 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1739 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1740 Zero(buffer+orig_size, offset-orig_size, char);
1742 buffer = buffer + offset;
1744 read_target = bufsv;
1746 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1747 concatenate it to the current buffer. */
1749 /* Truncate the existing buffer to the start of where we will be
1751 SvCUR_set(bufsv, offset);
1753 read_target = sv_newmortal();
1754 SvUPGRADE(read_target, SVt_PV);
1755 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1758 if (PL_op->op_type == OP_SYSREAD) {
1759 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1760 if (IoTYPE(io) == IoTYPE_SOCKET) {
1761 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1767 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1772 #ifdef HAS_SOCKET__bad_code_maybe
1773 if (IoTYPE(io) == IoTYPE_SOCKET) {
1774 Sock_size_t bufsize;
1775 char namebuf[MAXPATHLEN];
1776 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1777 bufsize = sizeof (struct sockaddr_in);
1779 bufsize = sizeof namebuf;
1781 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1782 (struct sockaddr *)namebuf, &bufsize);
1787 count = PerlIO_read(IoIFP(io), buffer, length);
1788 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1789 if (count == 0 && PerlIO_error(IoIFP(io)))
1793 if (IoTYPE(io) == IoTYPE_WRONLY)
1794 report_wrongway_fh(gv, '>');
1797 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1798 *SvEND(read_target) = '\0';
1799 (void)SvPOK_only(read_target);
1800 if (fp_utf8 && !IN_BYTES) {
1801 /* Look at utf8 we got back and count the characters */
1802 const char *bend = buffer + count;
1803 while (buffer < bend) {
1805 skip = UTF8SKIP(buffer);
1808 if (buffer - charskip + skip > bend) {
1809 /* partial character - try for rest of it */
1810 length = skip - (bend-buffer);
1811 offset = bend - SvPVX_const(bufsv);
1823 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1824 provided amount read (count) was what was requested (length)
1826 if (got < wanted && count == length) {
1827 length = wanted - got;
1828 offset = bend - SvPVX_const(bufsv);
1831 /* return value is character count */
1835 else if (buffer_utf8) {
1836 /* Let svcatsv upgrade the bytes we read in to utf8.
1837 The buffer is a mortal so will be freed soon. */
1838 sv_catsv_nomg(bufsv, read_target);
1841 /* This should not be marked tainted if the fp is marked clean */
1842 if (!(IoFLAGS(io) & IOf_UNTAINT))
1843 SvTAINTED_on(bufsv);
1855 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1860 STRLEN orig_blen_bytes;
1861 const int op_type = PL_op->op_type;
1864 GV *const gv = MUTABLE_GV(*++MARK);
1865 IO *const io = GvIO(gv);
1867 if (op_type == OP_SYSWRITE && io) {
1868 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1870 if (MARK == SP - 1) {
1872 mXPUSHi(sv_len(sv));
1876 return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1877 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1887 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1889 if (io && IoIFP(io))
1890 report_wrongway_fh(gv, '<');
1893 SETERRNO(EBADF,RMS_IFI);
1897 /* Do this first to trigger any overloading. */
1898 buffer = SvPV_const(bufsv, blen);
1899 orig_blen_bytes = blen;
1900 doing_utf8 = DO_UTF8(bufsv);
1902 if (PerlIO_isutf8(IoIFP(io))) {
1903 if (!SvUTF8(bufsv)) {
1904 /* We don't modify the original scalar. */
1905 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1906 buffer = (char *) tmpbuf;
1910 else if (doing_utf8) {
1911 STRLEN tmplen = blen;
1912 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1915 buffer = (char *) tmpbuf;
1919 assert((char *)result == buffer);
1920 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1925 if (op_type == OP_SEND) {
1926 const int flags = SvIVx(*++MARK);
1929 char * const sockbuf = SvPVx(*++MARK, mlen);
1930 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1931 flags, (struct sockaddr *)sockbuf, mlen);
1935 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1941 Size_t length = 0; /* This length is in characters. */
1947 /* The SV is bytes, and we've had to upgrade it. */
1948 blen_chars = orig_blen_bytes;
1950 /* The SV really is UTF-8. */
1951 /* Don't call sv_len_utf8 on a magical or overloaded
1952 scalar, as we might get back a different result. */
1953 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
1960 length = blen_chars;
1962 #if Size_t_size > IVSIZE
1963 length = (Size_t)SvNVx(*++MARK);
1965 length = (Size_t)SvIVx(*++MARK);
1967 if ((SSize_t)length < 0) {
1969 DIE(aTHX_ "Negative length");
1974 offset = SvIVx(*++MARK);
1976 if (-offset > (IV)blen_chars) {
1978 DIE(aTHX_ "Offset outside string");
1980 offset += blen_chars;
1981 } else if (offset > (IV)blen_chars) {
1983 DIE(aTHX_ "Offset outside string");
1987 if (length > blen_chars - offset)
1988 length = blen_chars - offset;
1990 /* Here we convert length from characters to bytes. */
1991 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1992 /* Either we had to convert the SV, or the SV is magical, or
1993 the SV has overloading, in which case we can't or mustn't
1994 or mustn't call it again. */
1996 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1997 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1999 /* It's a real UTF-8 SV, and it's not going to change under
2000 us. Take advantage of any cache. */
2002 I32 len_I32 = length;
2004 /* Convert the start and end character positions to bytes.
2005 Remember that the second argument to sv_pos_u2b is relative
2007 sv_pos_u2b(bufsv, &start, &len_I32);
2014 buffer = buffer+offset;
2016 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2017 if (IoTYPE(io) == IoTYPE_SOCKET) {
2018 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
2024 /* See the note at doio.c:do_print about filesize limits. --jhi */
2025 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2034 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2037 #if Size_t_size > IVSIZE
2057 * in Perl 5.12 and later, the additional parameter is a bitmask:
2060 * 2 = eof() <- ARGV magic
2062 * I'll rely on the compiler's trace flow analysis to decide whether to
2063 * actually assign this out here, or punt it into the only block where it is
2064 * used. Doing it out here is DRY on the condition logic.
2069 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2075 if (PL_op->op_flags & OPf_SPECIAL) {
2076 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2080 gv = PL_last_in_gv; /* eof */
2088 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2089 return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2092 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2093 if (io && !IoIFP(io)) {
2094 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2096 IoFLAGS(io) &= ~IOf_START;
2097 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2099 sv_setpvs(GvSV(gv), "-");
2101 GvSV(gv) = newSVpvs("-");
2102 SvSETMAGIC(GvSV(gv));
2104 else if (!nextargv(gv))
2109 PUSHs(boolSV(do_eof(gv)));
2119 if (MAXARG != 0 && (TOPs || POPs))
2120 PL_last_in_gv = MUTABLE_GV(POPs);
2127 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2129 return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2134 SETERRNO(EBADF,RMS_IFI);
2139 #if LSEEKSIZE > IVSIZE
2140 PUSHn( do_tell(gv) );
2142 PUSHi( do_tell(gv) );
2150 const int whence = POPi;
2151 #if LSEEKSIZE > IVSIZE
2152 const Off_t offset = (Off_t)SvNVx(POPs);
2154 const Off_t offset = (Off_t)SvIVx(POPs);
2157 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2158 IO *const io = GvIO(gv);
2161 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2163 #if LSEEKSIZE > IVSIZE
2164 SV *const offset_sv = newSVnv((NV) offset);
2166 SV *const offset_sv = newSViv(offset);
2169 return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2174 if (PL_op->op_type == OP_SEEK)
2175 PUSHs(boolSV(do_seek(gv, offset, whence)));
2177 const Off_t sought = do_sysseek(gv, offset, whence);
2179 PUSHs(&PL_sv_undef);
2181 SV* const sv = sought ?
2182 #if LSEEKSIZE > IVSIZE
2187 : newSVpvn(zero_but_true, ZBTLEN);
2198 /* There seems to be no consensus on the length type of truncate()
2199 * and ftruncate(), both off_t and size_t have supporters. In
2200 * general one would think that when using large files, off_t is
2201 * at least as wide as size_t, so using an off_t should be okay. */
2202 /* XXX Configure probe for the length type of *truncate() needed XXX */
2205 #if Off_t_size > IVSIZE
2210 /* Checking for length < 0 is problematic as the type might or
2211 * might not be signed: if it is not, clever compilers will moan. */
2212 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2215 SV * const sv = POPs;
2220 if (PL_op->op_flags & OPf_SPECIAL
2221 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2222 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2229 TAINT_PROPER("truncate");
2230 if (!(fp = IoIFP(io))) {
2236 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2238 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2244 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2245 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2246 goto do_ftruncate_io;
2249 const char * const name = SvPV_nomg_const_nolen(sv);
2250 TAINT_PROPER("truncate");
2252 if (truncate(name, len) < 0)
2256 const int tmpfd = PerlLIO_open(name, O_RDWR);
2261 if (my_chsize(tmpfd, len) < 0)
2263 PerlLIO_close(tmpfd);
2272 SETERRNO(EBADF,RMS_IFI);
2280 SV * const argsv = POPs;
2281 const unsigned int func = POPu;
2282 const int optype = PL_op->op_type;
2283 GV * const gv = MUTABLE_GV(POPs);
2284 IO * const io = gv ? GvIOn(gv) : NULL;
2288 if (!io || !argsv || !IoIFP(io)) {
2290 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2294 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2297 s = SvPV_force(argsv, len);
2298 need = IOCPARM_LEN(func);
2300 s = Sv_Grow(argsv, need + 1);
2301 SvCUR_set(argsv, need);
2304 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2307 retval = SvIV(argsv);
2308 s = INT2PTR(char*,retval); /* ouch */
2311 TAINT_PROPER(PL_op_desc[optype]);
2313 if (optype == OP_IOCTL)
2315 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2317 DIE(aTHX_ "ioctl is not implemented");
2321 DIE(aTHX_ "fcntl is not implemented");
2323 #if defined(OS2) && defined(__EMX__)
2324 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2326 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2330 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2332 if (s[SvCUR(argsv)] != 17)
2333 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2335 s[SvCUR(argsv)] = 0; /* put our null back */
2336 SvSETMAGIC(argsv); /* Assume it has changed */
2345 PUSHp(zero_but_true, ZBTLEN);
2356 const int argtype = POPi;
2357 GV * const gv = MUTABLE_GV(POPs);
2358 IO *const io = GvIO(gv);
2359 PerlIO *const fp = io ? IoIFP(io) : NULL;
2361 /* XXX Looks to me like io is always NULL at this point */
2363 (void)PerlIO_flush(fp);
2364 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2369 SETERRNO(EBADF,RMS_IFI);
2374 DIE(aTHX_ PL_no_func, "flock()");
2385 const int protocol = POPi;
2386 const int type = POPi;
2387 const int domain = POPi;
2388 GV * const gv = MUTABLE_GV(POPs);
2389 IO * const io = gv ? GvIOn(gv) : NULL;
2394 if (io && IoIFP(io))
2395 do_close(gv, FALSE);
2396 SETERRNO(EBADF,LIB_INVARG);
2401 do_close(gv, FALSE);
2403 TAINT_PROPER("socket");
2404 fd = PerlSock_socket(domain, type, protocol);
2407 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2408 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2409 IoTYPE(io) = IoTYPE_SOCKET;
2410 if (!IoIFP(io) || !IoOFP(io)) {
2411 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2412 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2413 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2416 #if defined(HAS_FCNTL) && defined(F_SETFD)
2417 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2426 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2428 const int protocol = POPi;
2429 const int type = POPi;
2430 const int domain = POPi;
2431 GV * const gv2 = MUTABLE_GV(POPs);
2432 GV * const gv1 = MUTABLE_GV(POPs);
2433 IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2434 IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2438 report_evil_fh(gv1);
2440 report_evil_fh(gv2);
2442 if (io1 && IoIFP(io1))
2443 do_close(gv1, FALSE);
2444 if (io2 && IoIFP(io2))
2445 do_close(gv2, FALSE);
2450 TAINT_PROPER("socketpair");
2451 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2453 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2454 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2455 IoTYPE(io1) = IoTYPE_SOCKET;
2456 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2457 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2458 IoTYPE(io2) = IoTYPE_SOCKET;
2459 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2460 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2461 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2462 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2463 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2464 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2465 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2468 #if defined(HAS_FCNTL) && defined(F_SETFD)
2469 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2470 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2475 DIE(aTHX_ PL_no_sock_func, "socketpair");
2484 SV * const addrsv = POPs;
2485 /* OK, so on what platform does bind modify addr? */
2487 GV * const gv = MUTABLE_GV(POPs);
2488 IO * const io = GvIOn(gv);
2490 const int op_type = PL_op->op_type;
2492 if (!io || !IoIFP(io))
2495 addr = SvPV_const(addrsv, len);
2496 TAINT_PROPER(PL_op_desc[op_type]);
2497 if ((op_type == OP_BIND
2498 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2499 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2507 SETERRNO(EBADF,SS_IVCHAN);
2514 const int backlog = POPi;
2515 GV * const gv = MUTABLE_GV(POPs);
2516 IO * const io = gv ? GvIOn(gv) : NULL;
2518 if (!io || !IoIFP(io))
2521 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2528 SETERRNO(EBADF,SS_IVCHAN);
2537 char namebuf[MAXPATHLEN];
2538 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2539 Sock_size_t len = sizeof (struct sockaddr_in);
2541 Sock_size_t len = sizeof namebuf;
2543 GV * const ggv = MUTABLE_GV(POPs);
2544 GV * const ngv = MUTABLE_GV(POPs);
2553 if (!gstio || !IoIFP(gstio))
2557 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2560 /* Some platforms indicate zero length when an AF_UNIX client is
2561 * not bound. Simulate a non-zero-length sockaddr structure in
2563 namebuf[0] = 0; /* sun_len */
2564 namebuf[1] = AF_UNIX; /* sun_family */
2572 do_close(ngv, FALSE);
2573 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2574 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2575 IoTYPE(nstio) = IoTYPE_SOCKET;
2576 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2577 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2578 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2579 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2582 #if defined(HAS_FCNTL) && defined(F_SETFD)
2583 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2586 #ifdef __SCO_VERSION__
2587 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2590 PUSHp(namebuf, len);
2594 report_evil_fh(ggv);
2595 SETERRNO(EBADF,SS_IVCHAN);
2605 const int how = POPi;
2606 GV * const gv = MUTABLE_GV(POPs);
2607 IO * const io = GvIOn(gv);
2609 if (!io || !IoIFP(io))
2612 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2617 SETERRNO(EBADF,SS_IVCHAN);
2624 const int optype = PL_op->op_type;
2625 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2626 const unsigned int optname = (unsigned int) POPi;
2627 const unsigned int lvl = (unsigned int) POPi;
2628 GV * const gv = MUTABLE_GV(POPs);
2629 IO * const io = GvIOn(gv);
2633 if (!io || !IoIFP(io))
2636 fd = PerlIO_fileno(IoIFP(io));
2640 (void)SvPOK_only(sv);
2644 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2651 #if defined(__SYMBIAN32__)
2652 # define SETSOCKOPT_OPTION_VALUE_T void *
2654 # define SETSOCKOPT_OPTION_VALUE_T const char *
2656 /* XXX TODO: We need to have a proper type (a Configure probe,
2657 * etc.) for what the C headers think of the third argument of
2658 * setsockopt(), the option_value read-only buffer: is it
2659 * a "char *", or a "void *", const or not. Some compilers
2660 * don't take kindly to e.g. assuming that "char *" implicitly
2661 * promotes to a "void *", or to explicitly promoting/demoting
2662 * consts to non/vice versa. The "const void *" is the SUS
2663 * definition, but that does not fly everywhere for the above
2665 SETSOCKOPT_OPTION_VALUE_T buf;
2669 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2673 aint = (int)SvIV(sv);
2674 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2677 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2687 SETERRNO(EBADF,SS_IVCHAN);
2696 const int optype = PL_op->op_type;
2697 GV * const gv = MUTABLE_GV(POPs);
2698 IO * const io = GvIOn(gv);
2703 if (!io || !IoIFP(io))
2706 sv = sv_2mortal(newSV(257));
2707 (void)SvPOK_only(sv);
2711 fd = PerlIO_fileno(IoIFP(io));
2713 case OP_GETSOCKNAME:
2714 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2717 case OP_GETPEERNAME:
2718 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2720 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2722 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";
2723 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2724 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2725 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2726 sizeof(u_short) + sizeof(struct in_addr))) {
2733 #ifdef BOGUS_GETNAME_RETURN
2734 /* Interactive Unix, getpeername() and getsockname()
2735 does not return valid namelen */
2736 if (len == BOGUS_GETNAME_RETURN)
2737 len = sizeof(struct sockaddr);
2746 SETERRNO(EBADF,SS_IVCHAN);
2765 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2766 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2767 if (PL_op->op_type == OP_LSTAT) {
2768 if (gv != PL_defgv) {
2769 do_fstat_warning_check:
2770 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2771 "lstat() on filehandle%s%"SVf,
2774 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2776 } else if (PL_laststype != OP_LSTAT)
2777 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2778 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2781 if (gv != PL_defgv) {
2785 PL_laststype = OP_STAT;
2786 PL_statgv = gv ? gv : (GV *)io;
2787 sv_setpvs(PL_statname, "");
2794 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2796 } else if (IoDIRP(io)) {
2798 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2801 PL_laststatval = -1;
2804 else PL_laststatval = -1;
2805 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2808 if (PL_laststatval < 0) {
2813 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2814 io = MUTABLE_IO(SvRV(sv));
2815 if (PL_op->op_type == OP_LSTAT)
2816 goto do_fstat_warning_check;
2817 goto do_fstat_have_io;
2820 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2821 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2823 PL_laststype = PL_op->op_type;
2824 if (PL_op->op_type == OP_LSTAT)
2825 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2827 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2828 if (PL_laststatval < 0) {
2829 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2830 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2836 if (gimme != G_ARRAY) {
2837 if (gimme != G_VOID)
2838 XPUSHs(boolSV(max));
2844 mPUSHi(PL_statcache.st_dev);
2845 #if ST_INO_SIZE > IVSIZE
2846 mPUSHn(PL_statcache.st_ino);
2848 # if ST_INO_SIGN <= 0
2849 mPUSHi(PL_statcache.st_ino);
2851 mPUSHu(PL_statcache.st_ino);
2854 mPUSHu(PL_statcache.st_mode);
2855 mPUSHu(PL_statcache.st_nlink);
2857 sv_setuid(PUSHmortal, PL_statcache.st_uid);
2858 sv_setgid(PUSHmortal, PL_statcache.st_gid);
2860 #ifdef USE_STAT_RDEV
2861 mPUSHi(PL_statcache.st_rdev);
2863 PUSHs(newSVpvs_flags("", SVs_TEMP));
2865 #if Off_t_size > IVSIZE
2866 mPUSHn(PL_statcache.st_size);
2868 mPUSHi(PL_statcache.st_size);
2871 mPUSHn(PL_statcache.st_atime);
2872 mPUSHn(PL_statcache.st_mtime);
2873 mPUSHn(PL_statcache.st_ctime);
2875 mPUSHi(PL_statcache.st_atime);
2876 mPUSHi(PL_statcache.st_mtime);
2877 mPUSHi(PL_statcache.st_ctime);
2879 #ifdef USE_STAT_BLOCKS
2880 mPUSHu(PL_statcache.st_blksize);
2881 mPUSHu(PL_statcache.st_blocks);
2883 PUSHs(newSVpvs_flags("", SVs_TEMP));
2884 PUSHs(newSVpvs_flags("", SVs_TEMP));
2890 /* All filetest ops avoid manipulating the perl stack pointer in their main
2891 bodies (since commit d2c4d2d1e22d3125), and return using either
2892 S_ft_return_false() or S_ft_return_true(). These two helper functions are
2893 the only two which manipulate the perl stack. To ensure that no stack
2894 manipulation macros are used, the filetest ops avoid defining a local copy
2895 of the stack pointer with dSP. */
2897 /* If the next filetest is stacked up with this one
2898 (PL_op->op_private & OPpFT_STACKING), we leave
2899 the original argument on the stack for success,
2900 and skip the stacked operators on failure.
2901 The next few macros/functions take care of this.
2905 S_ft_return_false(pTHX_ SV *ret) {
2909 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
2913 if (PL_op->op_private & OPpFT_STACKING) {
2914 while (OP_IS_FILETEST(next->op_type)
2915 && next->op_private & OPpFT_STACKED)
2916 next = next->op_next;
2921 PERL_STATIC_INLINE OP *
2922 S_ft_return_true(pTHX_ SV *ret) {
2924 if (PL_op->op_flags & OPf_REF)
2925 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
2926 else if (!(PL_op->op_private & OPpFT_STACKING))
2932 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
2933 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
2934 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
2936 #define tryAMAGICftest_MG(chr) STMT_START { \
2937 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
2938 && PL_op->op_flags & OPf_KIDS) { \
2939 OP *next = S_try_amagic_ftest(aTHX_ chr); \
2940 if (next) return next; \
2945 S_try_amagic_ftest(pTHX_ char chr) {
2947 SV *const arg = *PL_stack_sp;
2950 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
2954 const char tmpchr = chr;
2955 SV * const tmpsv = amagic_call(arg,
2956 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2957 ftest_amg, AMGf_unary);
2962 return SvTRUE(tmpsv)
2963 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
2973 /* Not const, because things tweak this below. Not bool, because there's
2974 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2975 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2976 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2977 /* Giving some sort of initial value silences compilers. */
2979 int access_mode = R_OK;
2981 int access_mode = 0;
2984 /* access_mode is never used, but leaving use_access in makes the
2985 conditional compiling below much clearer. */
2988 Mode_t stat_mode = S_IRUSR;
2990 bool effective = FALSE;
2993 switch (PL_op->op_type) {
2994 case OP_FTRREAD: opchar = 'R'; break;
2995 case OP_FTRWRITE: opchar = 'W'; break;
2996 case OP_FTREXEC: opchar = 'X'; break;
2997 case OP_FTEREAD: opchar = 'r'; break;
2998 case OP_FTEWRITE: opchar = 'w'; break;
2999 case OP_FTEEXEC: opchar = 'x'; break;
3001 tryAMAGICftest_MG(opchar);
3003 switch (PL_op->op_type) {
3005 #if !(defined(HAS_ACCESS) && defined(R_OK))
3011 #if defined(HAS_ACCESS) && defined(W_OK)
3016 stat_mode = S_IWUSR;
3020 #if defined(HAS_ACCESS) && defined(X_OK)
3025 stat_mode = S_IXUSR;
3029 #ifdef PERL_EFF_ACCESS
3032 stat_mode = S_IWUSR;
3036 #ifndef PERL_EFF_ACCESS
3043 #ifdef PERL_EFF_ACCESS
3048 stat_mode = S_IXUSR;
3054 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3055 const char *name = SvPV_nolen(*PL_stack_sp);
3057 # ifdef PERL_EFF_ACCESS
3058 result = PERL_EFF_ACCESS(name, access_mode);
3060 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3066 result = access(name, access_mode);
3068 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3079 result = my_stat_flags(0);
3082 if (cando(stat_mode, effective, &PL_statcache))
3091 const int op_type = PL_op->op_type;
3095 case OP_FTIS: opchar = 'e'; break;
3096 case OP_FTSIZE: opchar = 's'; break;
3097 case OP_FTMTIME: opchar = 'M'; break;
3098 case OP_FTCTIME: opchar = 'C'; break;
3099 case OP_FTATIME: opchar = 'A'; break;
3101 tryAMAGICftest_MG(opchar);
3103 result = my_stat_flags(0);
3106 if (op_type == OP_FTIS)
3109 /* You can't dTARGET inside OP_FTIS, because you'll get
3110 "panic: pad_sv po" - the op is not flagged to have a target. */
3114 #if Off_t_size > IVSIZE
3115 sv_setnv(TARG, (NV)PL_statcache.st_size);
3117 sv_setiv(TARG, (IV)PL_statcache.st_size);
3122 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3126 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3130 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3134 return SvTRUE_nomg(TARG)
3135 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3145 switch (PL_op->op_type) {
3146 case OP_FTROWNED: opchar = 'O'; break;
3147 case OP_FTEOWNED: opchar = 'o'; break;
3148 case OP_FTZERO: opchar = 'z'; break;
3149 case OP_FTSOCK: opchar = 'S'; break;
3150 case OP_FTCHR: opchar = 'c'; break;
3151 case OP_FTBLK: opchar = 'b'; break;
3152 case OP_FTFILE: opchar = 'f'; break;
3153 case OP_FTDIR: opchar = 'd'; break;
3154 case OP_FTPIPE: opchar = 'p'; break;
3155 case OP_FTSUID: opchar = 'u'; break;
3156 case OP_FTSGID: opchar = 'g'; break;
3157 case OP_FTSVTX: opchar = 'k'; break;
3159 tryAMAGICftest_MG(opchar);
3161 /* I believe that all these three are likely to be defined on most every
3162 system these days. */
3164 if(PL_op->op_type == OP_FTSUID) {
3169 if(PL_op->op_type == OP_FTSGID) {
3174 if(PL_op->op_type == OP_FTSVTX) {
3179 result = my_stat_flags(0);
3182 switch (PL_op->op_type) {
3184 if (PL_statcache.st_uid == PerlProc_getuid())
3188 if (PL_statcache.st_uid == PerlProc_geteuid())
3192 if (PL_statcache.st_size == 0)
3196 if (S_ISSOCK(PL_statcache.st_mode))
3200 if (S_ISCHR(PL_statcache.st_mode))
3204 if (S_ISBLK(PL_statcache.st_mode))
3208 if (S_ISREG(PL_statcache.st_mode))
3212 if (S_ISDIR(PL_statcache.st_mode))
3216 if (S_ISFIFO(PL_statcache.st_mode))
3221 if (PL_statcache.st_mode & S_ISUID)
3227 if (PL_statcache.st_mode & S_ISGID)
3233 if (PL_statcache.st_mode & S_ISVTX)
3246 tryAMAGICftest_MG('l');
3247 result = my_lstat_flags(0);
3251 if (S_ISLNK(PL_statcache.st_mode))
3264 tryAMAGICftest_MG('t');
3266 if (PL_op->op_flags & OPf_REF)
3269 SV *tmpsv = *PL_stack_sp;
3270 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3271 name = SvPV_nomg(tmpsv, namelen);
3272 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3276 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3277 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3278 else if (name && isDIGIT(*name))
3282 if (PerlLIO_isatty(fd))
3300 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3302 if (PL_op->op_flags & OPf_REF)
3304 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3309 gv = MAYBE_DEREF_GV_nomg(sv);
3313 if (gv == PL_defgv) {
3315 io = SvTYPE(PL_statgv) == SVt_PVIO
3319 goto really_filename;
3324 sv_setpvs(PL_statname, "");
3325 io = GvIO(PL_statgv);
3327 PL_laststatval = -1;
3328 PL_laststype = OP_STAT;
3329 if (io && IoIFP(io)) {
3330 if (! PerlIO_has_base(IoIFP(io)))
3331 DIE(aTHX_ "-T and -B not implemented on filehandles");
3332 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3333 if (PL_laststatval < 0)
3335 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3336 if (PL_op->op_type == OP_FTTEXT)
3341 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3342 i = PerlIO_getc(IoIFP(io));
3344 (void)PerlIO_ungetc(IoIFP(io),i);
3346 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3348 len = PerlIO_get_bufsiz(IoIFP(io));
3349 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3350 /* sfio can have large buffers - limit to 512 */
3355 SETERRNO(EBADF,RMS_IFI);
3357 SETERRNO(EBADF,RMS_IFI);
3362 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3365 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3367 PL_laststatval = -1;
3368 PL_laststype = OP_STAT;
3370 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3372 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3375 PL_laststype = OP_STAT;
3376 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3377 if (PL_laststatval < 0) {
3378 (void)PerlIO_close(fp);
3381 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3382 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3383 (void)PerlIO_close(fp);
3385 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3386 FT_RETURNNO; /* special case NFS directories */
3387 FT_RETURNYES; /* null file is anything */
3392 /* now scan s to look for textiness */
3393 /* XXX ASCII dependent code */
3395 #if defined(DOSISH) || defined(USEMYBINMODE)
3396 /* ignore trailing ^Z on short files */
3397 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3401 for (i = 0; i < len; i++, s++) {
3402 if (!*s) { /* null never allowed in text */
3407 else if (!(isPRINT(*s) || isSPACE(*s)))
3410 else if (*s & 128) {
3412 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3415 /* utf8 characters don't count as odd */
3416 if (UTF8_IS_START(*s)) {
3417 int ulen = UTF8SKIP(s);
3418 if (ulen < len - i) {
3420 for (j = 1; j < ulen; j++) {
3421 if (!UTF8_IS_CONTINUATION(s[j]))
3424 --ulen; /* loop does extra increment */
3434 *s != '\n' && *s != '\r' && *s != '\b' &&
3435 *s != '\t' && *s != '\f' && *s != 27)
3440 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3451 const char *tmps = NULL;
3455 SV * const sv = POPs;
3456 if (PL_op->op_flags & OPf_SPECIAL) {
3457 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3459 else if (!(gv = MAYBE_DEREF_GV(sv)))
3460 tmps = SvPV_nomg_const_nolen(sv);
3463 if( !gv && (!tmps || !*tmps) ) {
3464 HV * const table = GvHVn(PL_envgv);
3467 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3468 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3470 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3475 deprecate("chdir('') or chdir(undef) as chdir()");
3476 tmps = SvPV_nolen_const(*svp);
3480 TAINT_PROPER("chdir");
3485 TAINT_PROPER("chdir");
3488 IO* const io = GvIO(gv);
3491 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3492 } else if (IoIFP(io)) {
3493 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3497 SETERRNO(EBADF, RMS_IFI);
3503 SETERRNO(EBADF,RMS_IFI);
3507 DIE(aTHX_ PL_no_func, "fchdir");
3511 PUSHi( PerlDir_chdir(tmps) >= 0 );
3513 /* Clear the DEFAULT element of ENV so we'll get the new value
3515 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3522 dVAR; dSP; dMARK; dTARGET;
3523 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3534 char * const tmps = POPpx;
3535 TAINT_PROPER("chroot");
3536 PUSHi( chroot(tmps) >= 0 );
3539 DIE(aTHX_ PL_no_func, "chroot");
3547 const char * const tmps2 = POPpconstx;
3548 const char * const tmps = SvPV_nolen_const(TOPs);
3549 TAINT_PROPER("rename");
3551 anum = PerlLIO_rename(tmps, tmps2);
3553 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3554 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3557 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3558 (void)UNLINK(tmps2);
3559 if (!(anum = link(tmps, tmps2)))
3560 anum = UNLINK(tmps);
3568 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3572 const int op_type = PL_op->op_type;
3576 if (op_type == OP_LINK)
3577 DIE(aTHX_ PL_no_func, "link");
3579 # ifndef HAS_SYMLINK
3580 if (op_type == OP_SYMLINK)
3581 DIE(aTHX_ PL_no_func, "symlink");
3585 const char * const tmps2 = POPpconstx;
3586 const char * const tmps = SvPV_nolen_const(TOPs);
3587 TAINT_PROPER(PL_op_desc[op_type]);
3589 # if defined(HAS_LINK)
3590 # if defined(HAS_SYMLINK)
3591 /* Both present - need to choose which. */
3592 (op_type == OP_LINK) ?
3593 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3595 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3596 PerlLIO_link(tmps, tmps2);
3599 # if defined(HAS_SYMLINK)
3600 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3601 symlink(tmps, tmps2);
3606 SETi( result >= 0 );
3613 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3624 char buf[MAXPATHLEN];
3627 #ifndef INCOMPLETE_TAINTS
3631 len = readlink(tmps, buf, sizeof(buf) - 1);
3638 RETSETUNDEF; /* just pretend it's a normal file */
3642 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3644 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3646 char * const save_filename = filename;
3651 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3653 PERL_ARGS_ASSERT_DOONELINER;
3655 Newx(cmdline, size, char);
3656 my_strlcpy(cmdline, cmd, size);
3657 my_strlcat(cmdline, " ", size);
3658 for (s = cmdline + strlen(cmdline); *filename; ) {
3662 if (s - cmdline < size)
3663 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3664 myfp = PerlProc_popen(cmdline, "r");
3668 SV * const tmpsv = sv_newmortal();
3669 /* Need to save/restore 'PL_rs' ?? */
3670 s = sv_gets(tmpsv, myfp, 0);
3671 (void)PerlProc_pclose(myfp);
3675 #ifdef HAS_SYS_ERRLIST
3680 /* you don't see this */
3681 const char * const errmsg = Strerror(e) ;
3684 if (instr(s, errmsg)) {
3691 #define EACCES EPERM
3693 if (instr(s, "cannot make"))
3694 SETERRNO(EEXIST,RMS_FEX);
3695 else if (instr(s, "existing file"))
3696 SETERRNO(EEXIST,RMS_FEX);
3697 else if (instr(s, "ile exists"))
3698 SETERRNO(EEXIST,RMS_FEX);
3699 else if (instr(s, "non-exist"))
3700 SETERRNO(ENOENT,RMS_FNF);
3701 else if (instr(s, "does not exist"))
3702 SETERRNO(ENOENT,RMS_FNF);
3703 else if (instr(s, "not empty"))
3704 SETERRNO(EBUSY,SS_DEVOFFLINE);
3705 else if (instr(s, "cannot access"))
3706 SETERRNO(EACCES,RMS_PRV);
3708 SETERRNO(EPERM,RMS_PRV);
3711 else { /* some mkdirs return no failure indication */
3712 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3713 if (PL_op->op_type == OP_RMDIR)
3718 SETERRNO(EACCES,RMS_PRV); /* a guess */
3727 /* This macro removes trailing slashes from a directory name.
3728 * Different operating and file systems take differently to
3729 * trailing slashes. According to POSIX 1003.1 1996 Edition
3730 * any number of trailing slashes should be allowed.
3731 * Thusly we snip them away so that even non-conforming
3732 * systems are happy.
3733 * We should probably do this "filtering" for all
3734 * the functions that expect (potentially) directory names:
3735 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3736 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3738 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3739 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3742 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3743 (tmps) = savepvn((tmps), (len)); \
3753 const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3755 TRIMSLASHES(tmps,len,copy);
3757 TAINT_PROPER("mkdir");
3759 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3763 SETi( dooneliner("mkdir", tmps) );
3764 oldumask = PerlLIO_umask(0);
3765 PerlLIO_umask(oldumask);
3766 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3781 TRIMSLASHES(tmps,len,copy);
3782 TAINT_PROPER("rmdir");
3784 SETi( PerlDir_rmdir(tmps) >= 0 );
3786 SETi( dooneliner("rmdir", tmps) );
3793 /* Directory calls. */
3797 #if defined(Direntry_t) && defined(HAS_READDIR)
3799 const char * const dirname = POPpconstx;
3800 GV * const gv = MUTABLE_GV(POPs);
3801 IO * const io = GvIOn(gv);
3806 if ((IoIFP(io) || IoOFP(io)))
3807 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3808 "Opening filehandle %"HEKf" also as a directory",
3809 HEKfARG(GvENAME_HEK(gv)) );
3811 PerlDir_close(IoDIRP(io));
3812 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3818 SETERRNO(EBADF,RMS_DIR);
3821 DIE(aTHX_ PL_no_dir_func, "opendir");
3827 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3828 DIE(aTHX_ PL_no_dir_func, "readdir");
3830 #if !defined(I_DIRENT) && !defined(VMS)
3831 Direntry_t *readdir (DIR *);
3837 const I32 gimme = GIMME;
3838 GV * const gv = MUTABLE_GV(POPs);
3839 const Direntry_t *dp;
3840 IO * const io = GvIOn(gv);
3842 if (!io || !IoDIRP(io)) {
3843 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3844 "readdir() attempted on invalid dirhandle %"HEKf,
3845 HEKfARG(GvENAME_HEK(gv)));
3850 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3854 sv = newSVpvn(dp->d_name, dp->d_namlen);
3856 sv = newSVpv(dp->d_name, 0);
3858 #ifndef INCOMPLETE_TAINTS
3859 if (!(IoFLAGS(io) & IOf_UNTAINT))
3863 } while (gimme == G_ARRAY);
3865 if (!dp && gimme != G_ARRAY)
3872 SETERRNO(EBADF,RMS_ISI);
3873 if (GIMME == G_ARRAY)
3882 #if defined(HAS_TELLDIR) || defined(telldir)
3884 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3885 /* XXX netbsd still seemed to.
3886 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3887 --JHI 1999-Feb-02 */
3888 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3889 long telldir (DIR *);
3891 GV * const gv = MUTABLE_GV(POPs);
3892 IO * const io = GvIOn(gv);
3894 if (!io || !IoDIRP(io)) {
3895 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3896 "telldir() attempted on invalid dirhandle %"HEKf,
3897 HEKfARG(GvENAME_HEK(gv)));
3901 PUSHi( PerlDir_tell(IoDIRP(io)) );
3905 SETERRNO(EBADF,RMS_ISI);
3908 DIE(aTHX_ PL_no_dir_func, "telldir");
3914 #if defined(HAS_SEEKDIR) || defined(seekdir)
3916 const long along = POPl;
3917 GV * const gv = MUTABLE_GV(POPs);
3918 IO * const io = GvIOn(gv);
3920 if (!io || !IoDIRP(io)) {
3921 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3922 "seekdir() attempted on invalid dirhandle %"HEKf,
3923 HEKfARG(GvENAME_HEK(gv)));
3926 (void)PerlDir_seek(IoDIRP(io), along);
3931 SETERRNO(EBADF,RMS_ISI);
3934 DIE(aTHX_ PL_no_dir_func, "seekdir");
3940 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3942 GV * const gv = MUTABLE_GV(POPs);
3943 IO * const io = GvIOn(gv);
3945 if (!io || !IoDIRP(io)) {
3946 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3947 "rewinddir() attempted on invalid dirhandle %"HEKf,
3948 HEKfARG(GvENAME_HEK(gv)));
3951 (void)PerlDir_rewind(IoDIRP(io));
3955 SETERRNO(EBADF,RMS_ISI);
3958 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3964 #if defined(Direntry_t) && defined(HAS_READDIR)
3966 GV * const gv = MUTABLE_GV(POPs);
3967 IO * const io = GvIOn(gv);
3969 if (!io || !IoDIRP(io)) {
3970 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3971 "closedir() attempted on invalid dirhandle %"HEKf,
3972 HEKfARG(GvENAME_HEK(gv)));
3975 #ifdef VOID_CLOSEDIR
3976 PerlDir_close(IoDIRP(io));
3978 if (PerlDir_close(IoDIRP(io)) < 0) {
3979 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3988 SETERRNO(EBADF,RMS_IFI);
3991 DIE(aTHX_ PL_no_dir_func, "closedir");
3995 /* Process control. */
4002 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4003 sigset_t oldmask, newmask;
4007 PERL_FLUSHALL_FOR_CHILD;
4008 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4009 sigfillset(&newmask);
4010 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4012 childpid = PerlProc_fork();
4013 if (childpid == 0) {
4017 for (sig = 1; sig < SIG_SIZE; sig++)
4018 PL_psig_pend[sig] = 0;
4020 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4023 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4030 #ifdef PERL_USES_PL_PIDSTATUS
4031 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4037 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4042 PERL_FLUSHALL_FOR_CHILD;
4043 childpid = PerlProc_fork();
4049 DIE(aTHX_ PL_no_func, "fork");
4056 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4061 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4062 childpid = wait4pid(-1, &argflags, 0);
4064 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4069 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4070 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4071 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4073 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4078 DIE(aTHX_ PL_no_func, "wait");
4084 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4086 const int optype = POPi;
4087 const Pid_t pid = TOPi;
4091 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4092 result = wait4pid(pid, &argflags, optype);
4094 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4099 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4100 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4101 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4103 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4108 DIE(aTHX_ PL_no_func, "waitpid");
4114 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4115 #if defined(__LIBCATAMOUNT__)
4116 PL_statusvalue = -1;
4125 while (++MARK <= SP) {
4126 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4131 TAINT_PROPER("system");
4133 PERL_FLUSHALL_FOR_CHILD;
4134 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4139 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4140 sigset_t newset, oldset;
4143 if (PerlProc_pipe(pp) >= 0)
4145 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4146 sigemptyset(&newset);
4147 sigaddset(&newset, SIGCHLD);
4148 sigprocmask(SIG_BLOCK, &newset, &oldset);
4150 while ((childpid = PerlProc_fork()) == -1) {
4151 if (errno != EAGAIN) {
4156 PerlLIO_close(pp[0]);
4157 PerlLIO_close(pp[1]);
4159 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4160 sigprocmask(SIG_SETMASK, &oldset, NULL);
4167 Sigsave_t ihand,qhand; /* place to save signals during system() */
4171 PerlLIO_close(pp[1]);
4173 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4174 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4177 result = wait4pid(childpid, &status, 0);
4178 } while (result == -1 && errno == EINTR);
4180 #ifdef HAS_SIGPROCMASK
4181 sigprocmask(SIG_SETMASK, &oldset, NULL);
4183 (void)rsignal_restore(SIGINT, &ihand);
4184 (void)rsignal_restore(SIGQUIT, &qhand);
4186 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4187 do_execfree(); /* free any memory child malloced on fork */
4194 while (n < sizeof(int)) {
4195 n1 = PerlLIO_read(pp[0],
4196 (void*)(((char*)&errkid)+n),
4202 PerlLIO_close(pp[0]);
4203 if (n) { /* Error */
4204 if (n != sizeof(int))
4205 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4206 errno = errkid; /* Propagate errno from kid */
4207 STATUS_NATIVE_CHILD_SET(-1);
4210 XPUSHi(STATUS_CURRENT);
4213 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4214 sigprocmask(SIG_SETMASK, &oldset, NULL);
4217 PerlLIO_close(pp[0]);
4218 #if defined(HAS_FCNTL) && defined(F_SETFD)
4219 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4222 if (PL_op->op_flags & OPf_STACKED) {
4223 SV * const really = *++MARK;
4224 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4226 else if (SP - MARK != 1)
4227 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4229 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4233 #else /* ! FORK or VMS or OS/2 */
4236 if (PL_op->op_flags & OPf_STACKED) {
4237 SV * const really = *++MARK;
4238 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4239 value = (I32)do_aspawn(really, MARK, SP);
4241 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4244 else if (SP - MARK != 1) {
4245 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4246 value = (I32)do_aspawn(NULL, MARK, SP);
4248 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4252 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4254 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4256 STATUS_NATIVE_CHILD_SET(value);
4259 XPUSHi(result ? value : STATUS_CURRENT);
4260 #endif /* !FORK or VMS or OS/2 */
4267 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4272 while (++MARK <= SP) {
4273 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4278 TAINT_PROPER("exec");
4280 PERL_FLUSHALL_FOR_CHILD;
4281 if (PL_op->op_flags & OPf_STACKED) {
4282 SV * const really = *++MARK;
4283 value = (I32)do_aexec(really, MARK, SP);
4285 else if (SP - MARK != 1)
4287 value = (I32)vms_do_aexec(NULL, MARK, SP);
4289 value = (I32)do_aexec(NULL, MARK, SP);
4293 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4295 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4308 XPUSHi( getppid() );
4311 DIE(aTHX_ PL_no_func, "getppid");
4321 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4324 pgrp = (I32)BSD_GETPGRP(pid);
4326 if (pid != 0 && pid != PerlProc_getpid())
4327 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4333 DIE(aTHX_ PL_no_func, "getpgrp()");
4343 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4344 if (MAXARG > 0) pid = TOPs && TOPi;
4350 TAINT_PROPER("setpgrp");
4352 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4354 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4355 || (pid != 0 && pid != PerlProc_getpid()))
4357 DIE(aTHX_ "setpgrp can't take arguments");
4359 SETi( setpgrp() >= 0 );
4360 #endif /* USE_BSDPGRP */
4363 DIE(aTHX_ PL_no_func, "setpgrp()");
4367 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4368 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4370 # define PRIORITY_WHICH_T(which) which
4375 #ifdef HAS_GETPRIORITY
4377 const int who = POPi;
4378 const int which = TOPi;
4379 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4382 DIE(aTHX_ PL_no_func, "getpriority()");
4388 #ifdef HAS_SETPRIORITY
4390 const int niceval = POPi;
4391 const int who = POPi;
4392 const int which = TOPi;
4393 TAINT_PROPER("setpriority");
4394 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4397 DIE(aTHX_ PL_no_func, "setpriority()");
4401 #undef PRIORITY_WHICH_T
4409 XPUSHn( time(NULL) );
4411 XPUSHi( time(NULL) );
4423 (void)PerlProc_times(&PL_timesbuf);
4425 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4426 /* struct tms, though same data */
4430 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4431 if (GIMME == G_ARRAY) {
4432 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4433 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4434 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4442 if (GIMME == G_ARRAY) {
4449 DIE(aTHX_ "times not implemented");
4451 #endif /* HAS_TIMES */
4454 /* The 32 bit int year limits the times we can represent to these
4455 boundaries with a few days wiggle room to account for time zone
4458 /* Sat Jan 3 00:00:00 -2147481748 */
4459 #define TIME_LOWER_BOUND -67768100567755200.0
4460 /* Sun Dec 29 12:00:00 2147483647 */
4461 #define TIME_UPPER_BOUND 67767976233316800.0
4470 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4471 static const char * const dayname[] =
4472 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4473 static const char * const monname[] =
4474 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4475 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4477 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4480 when = (Time64_T)now;
4483 NV input = Perl_floor(POPn);
4484 when = (Time64_T)input;
4485 if (when != input) {
4486 /* diag_listed_as: gmtime(%f) too large */
4487 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4488 "%s(%.0" NVff ") too large", opname, input);
4492 if ( TIME_LOWER_BOUND > when ) {
4493 /* diag_listed_as: gmtime(%f) too small */
4494 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4495 "%s(%.0" NVff ") too small", opname, when);
4498 else if( when > TIME_UPPER_BOUND ) {
4499 /* diag_listed_as: gmtime(%f) too small */
4500 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4501 "%s(%.0" NVff ") too large", opname, when);
4505 if (PL_op->op_type == OP_LOCALTIME)
4506 err = S_localtime64_r(&when, &tmbuf);
4508 err = S_gmtime64_r(&when, &tmbuf);
4512 /* XXX %lld broken for quads */
4513 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4514 "%s(%.0" NVff ") failed", opname, when);
4517 if (GIMME != G_ARRAY) { /* scalar context */
4519 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4520 double year = (double)tmbuf.tm_year + 1900;
4527 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4528 dayname[tmbuf.tm_wday],
4529 monname[tmbuf.tm_mon],
4537 else { /* list context */
4543 mPUSHi(tmbuf.tm_sec);
4544 mPUSHi(tmbuf.tm_min);
4545 mPUSHi(tmbuf.tm_hour);
4546 mPUSHi(tmbuf.tm_mday);
4547 mPUSHi(tmbuf.tm_mon);
4548 mPUSHn(tmbuf.tm_year);
4549 mPUSHi(tmbuf.tm_wday);
4550 mPUSHi(tmbuf.tm_yday);
4551 mPUSHi(tmbuf.tm_isdst);
4562 anum = alarm((unsigned int)anum);
4568 DIE(aTHX_ PL_no_func, "alarm");
4579 (void)time(&lasttime);
4580 if (MAXARG < 1 || (!TOPs && !POPs))
4584 PerlProc_sleep((unsigned int)duration);
4587 XPUSHi(when - lasttime);
4591 /* Shared memory. */
4592 /* Merged with some message passing. */
4596 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4597 dVAR; dSP; dMARK; dTARGET;
4598 const int op_type = PL_op->op_type;
4603 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4606 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4609 value = (I32)(do_semop(MARK, SP) >= 0);
4612 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4620 return Perl_pp_semget(aTHX);
4628 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4629 dVAR; dSP; dMARK; dTARGET;
4630 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4637 DIE(aTHX_ "System V IPC is not implemented on this machine");
4643 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4644 dVAR; dSP; dMARK; dTARGET;
4645 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4653 PUSHp(zero_but_true, ZBTLEN);
4657 return Perl_pp_semget(aTHX);
4661 /* I can't const this further without getting warnings about the types of
4662 various arrays passed in from structures. */
4664 S_space_join_names_mortal(pTHX_ char *const *array)
4668 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4670 if (array && *array) {
4671 target = newSVpvs_flags("", SVs_TEMP);
4673 sv_catpv(target, *array);
4676 sv_catpvs(target, " ");
4679 target = sv_mortalcopy(&PL_sv_no);
4684 /* Get system info. */
4688 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4690 I32 which = PL_op->op_type;
4693 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4694 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4695 struct hostent *gethostbyname(Netdb_name_t);
4696 struct hostent *gethostent(void);
4698 struct hostent *hent = NULL;
4702 if (which == OP_GHBYNAME) {
4703 #ifdef HAS_GETHOSTBYNAME
4704 const char* const name = POPpbytex;
4705 hent = PerlSock_gethostbyname(name);
4707 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4710 else if (which == OP_GHBYADDR) {
4711 #ifdef HAS_GETHOSTBYADDR
4712 const int addrtype = POPi;
4713 SV * const addrsv = POPs;
4715 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4717 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4719 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4723 #ifdef HAS_GETHOSTENT
4724 hent = PerlSock_gethostent();
4726 DIE(aTHX_ PL_no_sock_func, "gethostent");
4729 #ifdef HOST_NOT_FOUND
4731 #ifdef USE_REENTRANT_API
4732 # ifdef USE_GETHOSTENT_ERRNO
4733 h_errno = PL_reentrant_buffer->_gethostent_errno;
4736 STATUS_UNIX_SET(h_errno);
4740 if (GIMME != G_ARRAY) {
4741 PUSHs(sv = sv_newmortal());
4743 if (which == OP_GHBYNAME) {
4745 sv_setpvn(sv, hent->h_addr, hent->h_length);
4748 sv_setpv(sv, (char*)hent->h_name);
4754 mPUSHs(newSVpv((char*)hent->h_name, 0));
4755 PUSHs(space_join_names_mortal(hent->h_aliases));
4756 mPUSHi(hent->h_addrtype);
4757 len = hent->h_length;
4760 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4761 mXPUSHp(*elem, len);
4765 mPUSHp(hent->h_addr, len);
4767 PUSHs(sv_mortalcopy(&PL_sv_no));
4772 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4778 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4780 I32 which = PL_op->op_type;
4782 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4783 struct netent *getnetbyaddr(Netdb_net_t, int);
4784 struct netent *getnetbyname(Netdb_name_t);
4785 struct netent *getnetent(void);
4787 struct netent *nent;
4789 if (which == OP_GNBYNAME){
4790 #ifdef HAS_GETNETBYNAME
4791 const char * const name = POPpbytex;
4792 nent = PerlSock_getnetbyname(name);
4794 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4797 else if (which == OP_GNBYADDR) {
4798 #ifdef HAS_GETNETBYADDR
4799 const int addrtype = POPi;
4800 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4801 nent = PerlSock_getnetbyaddr(addr, addrtype);
4803 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4807 #ifdef HAS_GETNETENT
4808 nent = PerlSock_getnetent();
4810 DIE(aTHX_ PL_no_sock_func, "getnetent");
4813 #ifdef HOST_NOT_FOUND
4815 #ifdef USE_REENTRANT_API
4816 # ifdef USE_GETNETENT_ERRNO
4817 h_errno = PL_reentrant_buffer->_getnetent_errno;
4820 STATUS_UNIX_SET(h_errno);
4825 if (GIMME != G_ARRAY) {
4826 PUSHs(sv = sv_newmortal());
4828 if (which == OP_GNBYNAME)
4829 sv_setiv(sv, (IV)nent->n_net);
4831 sv_setpv(sv, nent->n_name);
4837 mPUSHs(newSVpv(nent->n_name, 0));
4838 PUSHs(space_join_names_mortal(nent->n_aliases));
4839 mPUSHi(nent->n_addrtype);
4840 mPUSHi(nent->n_net);
4845 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4851 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4853 I32 which = PL_op->op_type;
4855 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4856 struct protoent *getprotobyname(Netdb_name_t);
4857 struct protoent *getprotobynumber(int);
4858 struct protoent *getprotoent(void);
4860 struct protoent *pent;
4862 if (which == OP_GPBYNAME) {
4863 #ifdef HAS_GETPROTOBYNAME
4864 const char* const name = POPpbytex;
4865 pent = PerlSock_getprotobyname(name);
4867 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4870 else if (which == OP_GPBYNUMBER) {
4871 #ifdef HAS_GETPROTOBYNUMBER
4872 const int number = POPi;
4873 pent = PerlSock_getprotobynumber(number);
4875 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4879 #ifdef HAS_GETPROTOENT
4880 pent = PerlSock_getprotoent();
4882 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4886 if (GIMME != G_ARRAY) {
4887 PUSHs(sv = sv_newmortal());
4889 if (which == OP_GPBYNAME)
4890 sv_setiv(sv, (IV)pent->p_proto);
4892 sv_setpv(sv, pent->p_name);
4898 mPUSHs(newSVpv(pent->p_name, 0));
4899 PUSHs(space_join_names_mortal(pent->p_aliases));
4900 mPUSHi(pent->p_proto);
4905 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4911 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4913 I32 which = PL_op->op_type;
4915 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4916 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4917 struct servent *getservbyport(int, Netdb_name_t);
4918 struct servent *getservent(void);
4920 struct servent *sent;
4922 if (which == OP_GSBYNAME) {
4923 #ifdef HAS_GETSERVBYNAME
4924 const char * const proto = POPpbytex;
4925 const char * const name = POPpbytex;
4926 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4928 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4931 else if (which == OP_GSBYPORT) {
4932 #ifdef HAS_GETSERVBYPORT
4933 const char * const proto = POPpbytex;
4934 unsigned short port = (unsigned short)POPu;
4935 port = PerlSock_htons(port);
4936 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4938 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4942 #ifdef HAS_GETSERVENT
4943 sent = PerlSock_getservent();
4945 DIE(aTHX_ PL_no_sock_func, "getservent");
4949 if (GIMME != G_ARRAY) {
4950 PUSHs(sv = sv_newmortal());
4952 if (which == OP_GSBYNAME) {
4953 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4956 sv_setpv(sv, sent->s_name);
4962 mPUSHs(newSVpv(sent->s_name, 0));
4963 PUSHs(space_join_names_mortal(sent->s_aliases));
4964 mPUSHi(PerlSock_ntohs(sent->s_port));
4965 mPUSHs(newSVpv(sent->s_proto, 0));
4970 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4977 const int stayopen = TOPi;
4978 switch(PL_op->op_type) {
4980 #ifdef HAS_SETHOSTENT
4981 PerlSock_sethostent(stayopen);
4983 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4986 #ifdef HAS_SETNETENT
4988 PerlSock_setnetent(stayopen);
4990 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4994 #ifdef HAS_SETPROTOENT
4995 PerlSock_setprotoent(stayopen);
4997 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5001 #ifdef HAS_SETSERVENT
5002 PerlSock_setservent(stayopen);
5004 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5014 switch(PL_op->op_type) {
5016 #ifdef HAS_ENDHOSTENT
5017 PerlSock_endhostent();
5019 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5023 #ifdef HAS_ENDNETENT
5024 PerlSock_endnetent();
5026 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5030 #ifdef HAS_ENDPROTOENT
5031 PerlSock_endprotoent();
5033 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5037 #ifdef HAS_ENDSERVENT
5038 PerlSock_endservent();
5040 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5044 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5047 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5051 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5054 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5058 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5061 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5065 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5068 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5080 I32 which = PL_op->op_type;
5082 struct passwd *pwent = NULL;
5084 * We currently support only the SysV getsp* shadow password interface.
5085 * The interface is declared in <shadow.h> and often one needs to link
5086 * with -lsecurity or some such.
5087 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5090 * AIX getpwnam() is clever enough to return the encrypted password
5091 * only if the caller (euid?) is root.
5093 * There are at least three other shadow password APIs. Many platforms
5094 * seem to contain more than one interface for accessing the shadow
5095 * password databases, possibly for compatibility reasons.
5096 * The getsp*() is by far he simplest one, the other two interfaces
5097 * are much more complicated, but also very similar to each other.
5102 * struct pr_passwd *getprpw*();
5103 * The password is in
5104 * char getprpw*(...).ufld.fd_encrypt[]
5105 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5110 * struct es_passwd *getespw*();
5111 * The password is in
5112 * char *(getespw*(...).ufld.fd_encrypt)
5113 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5116 * struct userpw *getuserpw();
5117 * The password is in
5118 * char *(getuserpw(...)).spw_upw_passwd
5119 * (but the de facto standard getpwnam() should work okay)
5121 * Mention I_PROT here so that Configure probes for it.
5123 * In HP-UX for getprpw*() the manual page claims that one should include
5124 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5125 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5126 * and pp_sys.c already includes <shadow.h> if there is such.
5128 * Note that <sys/security.h> is already probed for, but currently
5129 * it is only included in special cases.
5131 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5132 * be preferred interface, even though also the getprpw*() interface
5133 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5134 * One also needs to call set_auth_parameters() in main() before
5135 * doing anything else, whether one is using getespw*() or getprpw*().
5137 * Note that accessing the shadow databases can be magnitudes
5138 * slower than accessing the standard databases.
5143 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5144 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5145 * the pw_comment is left uninitialized. */
5146 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5152 const char* const name = POPpbytex;
5153 pwent = getpwnam(name);
5159 pwent = getpwuid(uid);
5163 # ifdef HAS_GETPWENT
5165 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5166 if (pwent) pwent = getpwnam(pwent->pw_name);
5169 DIE(aTHX_ PL_no_func, "getpwent");
5175 if (GIMME != G_ARRAY) {
5176 PUSHs(sv = sv_newmortal());
5178 if (which == OP_GPWNAM)
5179 sv_setuid(sv, pwent->pw_uid);
5181 sv_setpv(sv, pwent->pw_name);
5187 mPUSHs(newSVpv(pwent->pw_name, 0));
5191 /* If we have getspnam(), we try to dig up the shadow
5192 * password. If we are underprivileged, the shadow
5193 * interface will set the errno to EACCES or similar,
5194 * and return a null pointer. If this happens, we will
5195 * use the dummy password (usually "*" or "x") from the
5196 * standard password database.
5198 * In theory we could skip the shadow call completely
5199 * if euid != 0 but in practice we cannot know which
5200 * security measures are guarding the shadow databases
5201 * on a random platform.
5203 * Resist the urge to use additional shadow interfaces.
5204 * Divert the urge to writing an extension instead.
5207 /* Some AIX setups falsely(?) detect some getspnam(), which
5208 * has a different API than the Solaris/IRIX one. */
5209 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5212 const struct spwd * const spwent = getspnam(pwent->pw_name);
5213 /* Save and restore errno so that
5214 * underprivileged attempts seem
5215 * to have never made the unsuccessful
5216 * attempt to retrieve the shadow password. */
5218 if (spwent && spwent->sp_pwdp)
5219 sv_setpv(sv, spwent->sp_pwdp);
5223 if (!SvPOK(sv)) /* Use the standard password, then. */
5224 sv_setpv(sv, pwent->pw_passwd);
5227 # ifndef INCOMPLETE_TAINTS
5228 /* passwd is tainted because user himself can diddle with it.
5229 * admittedly not much and in a very limited way, but nevertheless. */
5233 sv_setuid(PUSHmortal, pwent->pw_uid);
5234 sv_setgid(PUSHmortal, pwent->pw_gid);
5236 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5237 * because of the poor interface of the Perl getpw*(),
5238 * not because there's some standard/convention saying so.
5239 * A better interface would have been to return a hash,
5240 * but we are accursed by our history, alas. --jhi. */
5242 mPUSHi(pwent->pw_change);
5245 mPUSHi(pwent->pw_quota);
5248 mPUSHs(newSVpv(pwent->pw_age, 0));
5250 /* I think that you can never get this compiled, but just in case. */
5251 PUSHs(sv_mortalcopy(&PL_sv_no));
5256 /* pw_class and pw_comment are mutually exclusive--.
5257 * see the above note for pw_change, pw_quota, and pw_age. */
5259 mPUSHs(newSVpv(pwent->pw_class, 0));
5262 mPUSHs(newSVpv(pwent->pw_comment, 0));
5264 /* I think that you can never get this compiled, but just in case. */
5265 PUSHs(sv_mortalcopy(&PL_sv_no));
5270 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5272 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5274 # ifndef INCOMPLETE_TAINTS
5275 /* pw_gecos is tainted because user himself can diddle with it. */
5279 mPUSHs(newSVpv(pwent->pw_dir, 0));
5281 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5282 # ifndef INCOMPLETE_TAINTS
5283 /* pw_shell is tainted because user himself can diddle with it. */
5288 mPUSHi(pwent->pw_expire);
5293 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5301 const I32 which = PL_op->op_type;
5302 const struct group *grent;
5304 if (which == OP_GGRNAM) {
5305 const char* const name = POPpbytex;
5306 grent = (const struct group *)getgrnam(name);
5308 else if (which == OP_GGRGID) {
5309 const Gid_t gid = POPi;
5310 grent = (const struct group *)getgrgid(gid);
5314 grent = (struct group *)getgrent();
5316 DIE(aTHX_ PL_no_func, "getgrent");
5320 if (GIMME != G_ARRAY) {
5321 SV * const sv = sv_newmortal();
5325 if (which == OP_GGRNAM)
5326 sv_setgid(sv, grent->gr_gid);
5328 sv_setpv(sv, grent->gr_name);
5334 mPUSHs(newSVpv(grent->gr_name, 0));
5337 mPUSHs(newSVpv(grent->gr_passwd, 0));
5339 PUSHs(sv_mortalcopy(&PL_sv_no));
5342 sv_setgid(PUSHmortal, grent->gr_gid);
5344 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5345 /* In UNICOS/mk (_CRAYMPP) the multithreading
5346 * versions (getgrnam_r, getgrgid_r)
5347 * seem to return an illegal pointer
5348 * as the group members list, gr_mem.
5349 * getgrent() doesn't even have a _r version
5350 * but the gr_mem is poisonous anyway.
5351 * So yes, you cannot get the list of group
5352 * members if building multithreaded in UNICOS/mk. */
5353 PUSHs(space_join_names_mortal(grent->gr_mem));
5359 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5369 if (!(tmps = PerlProc_getlogin()))
5371 sv_setpv_mg(TARG, tmps);
5375 DIE(aTHX_ PL_no_func, "getlogin");
5379 /* Miscellaneous. */
5384 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5385 I32 items = SP - MARK;
5386 unsigned long a[20];
5391 while (++MARK <= SP) {
5392 if (SvTAINTED(*MARK)) {
5398 TAINT_PROPER("syscall");
5401 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5402 * or where sizeof(long) != sizeof(char*). But such machines will
5403 * not likely have syscall implemented either, so who cares?
5405 while (++MARK <= SP) {
5406 if (SvNIOK(*MARK) || !i)
5407 a[i++] = SvIV(*MARK);
5408 else if (*MARK == &PL_sv_undef)
5411 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5417 DIE(aTHX_ "Too many args to syscall");
5419 DIE(aTHX_ "Too few args to syscall");
5421 retval = syscall(a[0]);
5424 retval = syscall(a[0],a[1]);
5427 retval = syscall(a[0],a[1],a[2]);
5430 retval = syscall(a[0],a[1],a[2],a[3]);
5433 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5436 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5439 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5442 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5449 DIE(aTHX_ PL_no_func, "syscall");
5453 #ifdef FCNTL_EMULATE_FLOCK
5455 /* XXX Emulate flock() with fcntl().
5456 What's really needed is a good file locking module.
5460 fcntl_emulate_flock(int fd, int operation)
5465 switch (operation & ~LOCK_NB) {
5467 flock.l_type = F_RDLCK;
5470 flock.l_type = F_WRLCK;
5473 flock.l_type = F_UNLCK;
5479 flock.l_whence = SEEK_SET;
5480 flock.l_start = flock.l_len = (Off_t)0;
5482 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5483 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5484 errno = EWOULDBLOCK;
5488 #endif /* FCNTL_EMULATE_FLOCK */
5490 #ifdef LOCKF_EMULATE_FLOCK
5492 /* XXX Emulate flock() with lockf(). This is just to increase
5493 portability of scripts. The calls are not completely
5494 interchangeable. What's really needed is a good file
5498 /* The lockf() constants might have been defined in <unistd.h>.
5499 Unfortunately, <unistd.h> causes troubles on some mixed
5500 (BSD/POSIX) systems, such as SunOS 4.1.3.
5502 Further, the lockf() constants aren't POSIX, so they might not be
5503 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5504 just stick in the SVID values and be done with it. Sigh.
5508 # define F_ULOCK 0 /* Unlock a previously locked region */
5511 # define F_LOCK 1 /* Lock a region for exclusive use */
5514 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5517 # define F_TEST 3 /* Test a region for other processes locks */
5521 lockf_emulate_flock(int fd, int operation)
5527 /* flock locks entire file so for lockf we need to do the same */
5528 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5529 if (pos > 0) /* is seekable and needs to be repositioned */
5530 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5531 pos = -1; /* seek failed, so don't seek back afterwards */
5534 switch (operation) {
5536 /* LOCK_SH - get a shared lock */
5538 /* LOCK_EX - get an exclusive lock */
5540 i = lockf (fd, F_LOCK, 0);
5543 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5544 case LOCK_SH|LOCK_NB:
5545 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5546 case LOCK_EX|LOCK_NB:
5547 i = lockf (fd, F_TLOCK, 0);
5549 if ((errno == EAGAIN) || (errno == EACCES))
5550 errno = EWOULDBLOCK;
5553 /* LOCK_UN - unlock (non-blocking is a no-op) */
5555 case LOCK_UN|LOCK_NB:
5556 i = lockf (fd, F_ULOCK, 0);
5559 /* Default - can't decipher operation */
5566 if (pos > 0) /* need to restore position of the handle */
5567 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5572 #endif /* LOCKF_EMULATE_FLOCK */
5576 * c-indentation-style: bsd
5578 * indent-tabs-mode: nil
5581 * ex: set ts=8 sts=4 sw=4 et: