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));
904 methname = "TIESCALAR";
905 how = PERL_MAGIC_tiedscalar;
909 if (sv_isobject(*MARK)) { /* Calls GET magic. */
910 ENTER_with_name("call_TIE");
911 PUSHSTACKi(PERLSI_MAGIC);
913 EXTEND(SP,(I32)items);
917 call_method(methname, G_SCALAR);
920 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
921 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
922 * wrong error message, and worse case, supreme action at a distance.
923 * (Sorry obfuscation writers. You're not going to be given this one.)
925 stash = gv_stashsv(*MARK, 0);
926 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
927 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
928 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
930 ENTER_with_name("call_TIE");
931 PUSHSTACKi(PERLSI_MAGIC);
933 EXTEND(SP,(I32)items);
937 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
943 if (sv_isobject(sv)) {
944 sv_unmagic(varsv, how);
945 /* Croak if a self-tie on an aggregate is attempted. */
946 if (varsv == SvRV(sv) &&
947 (SvTYPE(varsv) == SVt_PVAV ||
948 SvTYPE(varsv) == SVt_PVHV))
950 "Self-ties of arrays and hashes are not supported");
951 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
953 LEAVE_with_name("call_TIE");
954 SP = PL_stack_base + markoff;
964 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
965 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
967 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
970 if ((mg = SvTIED_mg(sv, how))) {
971 SV * const obj = SvRV(SvTIED_obj(sv, mg));
973 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
975 if (gv && isGV(gv) && (cv = GvCV(gv))) {
977 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
978 mXPUSHi(SvREFCNT(obj) - 1);
980 ENTER_with_name("call_UNTIE");
981 call_sv(MUTABLE_SV(cv), G_VOID);
982 LEAVE_with_name("call_UNTIE");
985 else if (mg && SvREFCNT(obj) > 1) {
986 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
987 "untie attempted while %"UVuf" inner references still exist",
988 (UV)SvREFCNT(obj) - 1 ) ;
992 sv_unmagic(sv, how) ;
1002 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1003 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1005 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1008 if ((mg = SvTIED_mg(sv, how))) {
1009 PUSHs(SvTIED_obj(sv, mg));
1022 HV * const hv = MUTABLE_HV(POPs);
1023 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1024 stash = gv_stashsv(sv, 0);
1025 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1027 require_pv("AnyDBM_File.pm");
1029 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1030 DIE(aTHX_ "No dbm on this machine");
1040 mPUSHu(O_RDWR|O_CREAT);
1044 if (!SvOK(right)) right = &PL_sv_no;
1048 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1051 if (!sv_isobject(TOPs)) {
1059 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1063 if (sv_isobject(TOPs)) {
1064 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1065 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1082 struct timeval timebuf;
1083 struct timeval *tbuf = &timebuf;
1086 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1091 # if BYTEORDER & 0xf0000
1092 # define ORDERBYTE (0x88888888 - BYTEORDER)
1094 # define ORDERBYTE (0x4444 - BYTEORDER)
1100 for (i = 1; i <= 3; i++) {
1101 SV * const sv = SP[i];
1106 sv_force_normal_flags(sv, 0);
1107 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1108 Perl_croak_no_modify();
1111 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1112 "Non-string passed as bitmask");
1113 SvPV_force_nomg_nolen(sv); /* force string conversion */
1120 /* little endians can use vecs directly */
1121 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1128 masksize = NFDBITS / NBBY;
1130 masksize = sizeof(long); /* documented int, everyone seems to use long */
1132 Zero(&fd_sets[0], 4, char*);
1135 # if SELECT_MIN_BITS == 1
1136 growsize = sizeof(fd_set);
1138 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1139 # undef SELECT_MIN_BITS
1140 # define SELECT_MIN_BITS __FD_SETSIZE
1142 /* If SELECT_MIN_BITS is greater than one we most probably will want
1143 * to align the sizes with SELECT_MIN_BITS/8 because for example
1144 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1145 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1146 * on (sets/tests/clears bits) is 32 bits. */
1147 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1155 timebuf.tv_sec = (long)value;
1156 value -= (NV)timebuf.tv_sec;
1157 timebuf.tv_usec = (long)(value * 1000000.0);
1162 for (i = 1; i <= 3; i++) {
1164 if (!SvOK(sv) || SvCUR(sv) == 0) {
1171 Sv_Grow(sv, growsize);
1175 while (++j <= growsize) {
1179 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1181 Newx(fd_sets[i], growsize, char);
1182 for (offset = 0; offset < growsize; offset += masksize) {
1183 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1184 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1187 fd_sets[i] = SvPVX(sv);
1191 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1192 /* Can't make just the (void*) conditional because that would be
1193 * cpp #if within cpp macro, and not all compilers like that. */
1194 nfound = PerlSock_select(
1196 (Select_fd_set_t) fd_sets[1],
1197 (Select_fd_set_t) fd_sets[2],
1198 (Select_fd_set_t) fd_sets[3],
1199 (void*) tbuf); /* Workaround for compiler bug. */
1201 nfound = PerlSock_select(
1203 (Select_fd_set_t) fd_sets[1],
1204 (Select_fd_set_t) fd_sets[2],
1205 (Select_fd_set_t) fd_sets[3],
1208 for (i = 1; i <= 3; i++) {
1211 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1213 for (offset = 0; offset < growsize; offset += masksize) {
1214 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1215 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1217 Safefree(fd_sets[i]);
1224 if (GIMME == G_ARRAY && tbuf) {
1225 value = (NV)(timebuf.tv_sec) +
1226 (NV)(timebuf.tv_usec) / 1000000.0;
1231 DIE(aTHX_ "select not implemented");
1236 =for apidoc setdefout
1238 Sets PL_defoutgv, the default file handle for output, to the passed in
1239 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1240 count of the passed in typeglob is increased by one, and the reference count
1241 of the typeglob that PL_defoutgv points to is decreased by one.
1247 Perl_setdefout(pTHX_ GV *gv)
1250 PERL_ARGS_ASSERT_SETDEFOUT;
1251 SvREFCNT_inc_simple_void_NN(gv);
1252 SvREFCNT_dec(PL_defoutgv);
1260 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1261 GV * egv = GvEGVx(PL_defoutgv);
1266 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1267 gvp = hv && HvENAME(hv)
1268 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1270 if (gvp && *gvp == egv) {
1271 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1275 mXPUSHs(newRV(MUTABLE_SV(egv)));
1279 if (!GvIO(newdefout))
1280 gv_IOadd(newdefout);
1281 setdefout(newdefout);
1291 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1292 IO *const io = GvIO(gv);
1298 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1300 const U32 gimme = GIMME_V;
1301 Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1302 if (gimme == G_SCALAR) {
1304 SvSetMagicSV_nosteal(TARG, TOPs);
1309 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1310 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1312 SETERRNO(EBADF,RMS_IFI);
1316 sv_setpvs(TARG, " ");
1317 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1318 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1319 /* Find out how many bytes the char needs */
1320 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1323 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1324 SvCUR_set(TARG,1+len);
1333 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1337 const I32 gimme = GIMME_V;
1339 PERL_ARGS_ASSERT_DOFORM;
1341 if (cv && CvCLONE(cv))
1342 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1347 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1348 PUSHFORMAT(cx, retop);
1349 if (CvDEPTH(cv) >= 2) {
1350 PERL_STACK_OVERFLOW_CHECK();
1351 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1354 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1356 setdefout(gv); /* locally select filehandle so $% et al work */
1375 gv = MUTABLE_GV(POPs);
1392 tmpsv = sv_newmortal();
1393 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1394 DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
1396 IoFLAGS(io) &= ~IOf_DIDTOP;
1397 RETURNOP(doform(cv,gv,PL_op->op_next));
1403 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1404 IO * const io = GvIOp(gv);
1412 if (!io || !(ofp = IoOFP(io)))
1415 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1416 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1418 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1419 PL_formtarget != PL_toptarget)
1423 if (!IoTOP_GV(io)) {
1426 if (!IoTOP_NAME(io)) {
1428 if (!IoFMT_NAME(io))
1429 IoFMT_NAME(io) = savepv(GvNAME(gv));
1430 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1431 HEKfARG(GvNAME_HEK(gv))));
1432 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1433 if ((topgv && GvFORM(topgv)) ||
1434 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1435 IoTOP_NAME(io) = savesvpv(topname);
1437 IoTOP_NAME(io) = savepvs("top");
1439 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1440 if (!topgv || !GvFORM(topgv)) {
1441 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1444 IoTOP_GV(io) = topgv;
1446 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1447 I32 lines = IoLINES_LEFT(io);
1448 const char *s = SvPVX_const(PL_formtarget);
1449 if (lines <= 0) /* Yow, header didn't even fit!!! */
1451 while (lines-- > 0) {
1452 s = strchr(s, '\n');
1458 const STRLEN save = SvCUR(PL_formtarget);
1459 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1460 do_print(PL_formtarget, ofp);
1461 SvCUR_set(PL_formtarget, save);
1462 sv_chop(PL_formtarget, s);
1463 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1466 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1467 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1468 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1470 PL_formtarget = PL_toptarget;
1471 IoFLAGS(io) |= IOf_DIDTOP;
1473 assert(fgv); /* IoTOP_GV(io) should have been set above */
1476 SV * const sv = sv_newmortal();
1477 gv_efullname4(sv, fgv, NULL, FALSE);
1478 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1480 return doform(cv, gv, PL_op);
1484 POPBLOCK(cx,PL_curpm);
1486 retop = cx->blk_sub.retop;
1487 SP = newsp; /* ignore retval of formline */
1490 if (!io || !(fp = IoOFP(io))) {
1491 if (io && IoIFP(io))
1492 report_wrongway_fh(gv, '<');
1498 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1499 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1501 if (!do_print(PL_formtarget, fp))
1504 FmLINES(PL_formtarget) = 0;
1505 SvCUR_set(PL_formtarget, 0);
1506 *SvEND(PL_formtarget) = '\0';
1507 if (IoFLAGS(io) & IOf_FLUSH)
1508 (void)PerlIO_flush(fp);
1512 PL_formtarget = PL_bodytarget;
1513 PERL_UNUSED_VAR(gimme);
1519 dVAR; dSP; dMARK; dORIGMARK;
1523 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1524 IO *const io = GvIO(gv);
1526 /* Treat empty list as "" */
1527 if (MARK == SP) XPUSHs(&PL_sv_no);
1530 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1532 if (MARK == ORIGMARK) {
1535 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1538 return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1540 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1547 SETERRNO(EBADF,RMS_IFI);
1550 else if (!(fp = IoOFP(io))) {
1552 report_wrongway_fh(gv, '<');
1553 else if (ckWARN(WARN_CLOSED))
1555 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1559 SV *sv = sv_newmortal();
1560 do_sprintf(sv, SP - MARK, MARK + 1);
1561 if (!do_print(sv, fp))
1564 if (IoFLAGS(io) & IOf_FLUSH)
1565 if (PerlIO_flush(fp) == EOF)
1574 PUSHs(&PL_sv_undef);
1582 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1583 const int mode = POPi;
1584 SV * const sv = POPs;
1585 GV * const gv = MUTABLE_GV(POPs);
1588 /* Need TIEHANDLE method ? */
1589 const char * const tmps = SvPV_const(sv, len);
1590 /* FIXME? do_open should do const */
1591 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1592 IoLINES(GvIOp(gv)) = 0;
1596 PUSHs(&PL_sv_undef);
1603 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1617 bool charstart = FALSE;
1618 STRLEN charskip = 0;
1621 GV * const gv = MUTABLE_GV(*++MARK);
1622 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1623 && gv && (io = GvIO(gv)) )
1625 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1627 return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1628 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1637 sv_setpvs(bufsv, "");
1638 length = SvIVx(*++MARK);
1640 DIE(aTHX_ "Negative length");
1643 offset = SvIVx(*++MARK);
1647 if (!io || !IoIFP(io)) {
1649 SETERRNO(EBADF,RMS_IFI);
1652 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1653 buffer = SvPVutf8_force(bufsv, blen);
1654 /* UTF-8 may not have been set if they are all low bytes */
1659 buffer = SvPV_force(bufsv, blen);
1660 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1662 if (DO_UTF8(bufsv)) {
1663 blen = sv_len_utf8_nomg(bufsv);
1672 if (PL_op->op_type == OP_RECV) {
1673 Sock_size_t bufsize;
1674 char namebuf[MAXPATHLEN];
1675 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1676 bufsize = sizeof (struct sockaddr_in);
1678 bufsize = sizeof namebuf;
1680 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1684 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1685 /* 'offset' means 'flags' here */
1686 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1687 (struct sockaddr *)namebuf, &bufsize);
1690 /* MSG_TRUNC can give oversized count; quietly lose it */
1693 SvCUR_set(bufsv, count);
1694 *SvEND(bufsv) = '\0';
1695 (void)SvPOK_only(bufsv);
1699 /* This should not be marked tainted if the fp is marked clean */
1700 if (!(IoFLAGS(io) & IOf_UNTAINT))
1701 SvTAINTED_on(bufsv);
1703 sv_setpvn(TARG, namebuf, bufsize);
1709 if (-offset > (SSize_t)blen)
1710 DIE(aTHX_ "Offset outside string");
1713 if (DO_UTF8(bufsv)) {
1714 /* convert offset-as-chars to offset-as-bytes */
1715 if (offset >= (SSize_t)blen)
1716 offset += SvCUR(bufsv) - blen;
1718 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1721 orig_size = SvCUR(bufsv);
1722 /* Allocating length + offset + 1 isn't perfect in the case of reading
1723 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1725 (should be 2 * length + offset + 1, or possibly something longer if
1726 PL_encoding is true) */
1727 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1728 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1729 Zero(buffer+orig_size, offset-orig_size, char);
1731 buffer = buffer + offset;
1733 read_target = bufsv;
1735 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1736 concatenate it to the current buffer. */
1738 /* Truncate the existing buffer to the start of where we will be
1740 SvCUR_set(bufsv, offset);
1742 read_target = sv_newmortal();
1743 SvUPGRADE(read_target, SVt_PV);
1744 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1747 if (PL_op->op_type == OP_SYSREAD) {
1748 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1749 if (IoTYPE(io) == IoTYPE_SOCKET) {
1750 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1756 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1761 #ifdef HAS_SOCKET__bad_code_maybe
1762 if (IoTYPE(io) == IoTYPE_SOCKET) {
1763 Sock_size_t bufsize;
1764 char namebuf[MAXPATHLEN];
1765 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1766 bufsize = sizeof (struct sockaddr_in);
1768 bufsize = sizeof namebuf;
1770 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1771 (struct sockaddr *)namebuf, &bufsize);
1776 count = PerlIO_read(IoIFP(io), buffer, length);
1777 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1778 if (count == 0 && PerlIO_error(IoIFP(io)))
1782 if (IoTYPE(io) == IoTYPE_WRONLY)
1783 report_wrongway_fh(gv, '>');
1786 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1787 *SvEND(read_target) = '\0';
1788 (void)SvPOK_only(read_target);
1789 if (fp_utf8 && !IN_BYTES) {
1790 /* Look at utf8 we got back and count the characters */
1791 const char *bend = buffer + count;
1792 while (buffer < bend) {
1794 skip = UTF8SKIP(buffer);
1797 if (buffer - charskip + skip > bend) {
1798 /* partial character - try for rest of it */
1799 length = skip - (bend-buffer);
1800 offset = bend - SvPVX_const(bufsv);
1812 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1813 provided amount read (count) was what was requested (length)
1815 if (got < wanted && count == length) {
1816 length = wanted - got;
1817 offset = bend - SvPVX_const(bufsv);
1820 /* return value is character count */
1824 else if (buffer_utf8) {
1825 /* Let svcatsv upgrade the bytes we read in to utf8.
1826 The buffer is a mortal so will be freed soon. */
1827 sv_catsv_nomg(bufsv, read_target);
1830 /* This should not be marked tainted if the fp is marked clean */
1831 if (!(IoFLAGS(io) & IOf_UNTAINT))
1832 SvTAINTED_on(bufsv);
1844 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1849 STRLEN orig_blen_bytes;
1850 const int op_type = PL_op->op_type;
1853 GV *const gv = MUTABLE_GV(*++MARK);
1854 IO *const io = GvIO(gv);
1856 if (op_type == OP_SYSWRITE && io) {
1857 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1859 if (MARK == SP - 1) {
1861 mXPUSHi(sv_len(sv));
1865 return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1866 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1876 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1878 if (io && IoIFP(io))
1879 report_wrongway_fh(gv, '<');
1882 SETERRNO(EBADF,RMS_IFI);
1886 /* Do this first to trigger any overloading. */
1887 buffer = SvPV_const(bufsv, blen);
1888 orig_blen_bytes = blen;
1889 doing_utf8 = DO_UTF8(bufsv);
1891 if (PerlIO_isutf8(IoIFP(io))) {
1892 if (!SvUTF8(bufsv)) {
1893 /* We don't modify the original scalar. */
1894 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1895 buffer = (char *) tmpbuf;
1899 else if (doing_utf8) {
1900 STRLEN tmplen = blen;
1901 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1904 buffer = (char *) tmpbuf;
1908 assert((char *)result == buffer);
1909 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1914 if (op_type == OP_SEND) {
1915 const int flags = SvIVx(*++MARK);
1918 char * const sockbuf = SvPVx(*++MARK, mlen);
1919 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1920 flags, (struct sockaddr *)sockbuf, mlen);
1924 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1930 Size_t length = 0; /* This length is in characters. */
1936 /* The SV is bytes, and we've had to upgrade it. */
1937 blen_chars = orig_blen_bytes;
1939 /* The SV really is UTF-8. */
1940 /* Don't call sv_len_utf8 on a magical or overloaded
1941 scalar, as we might get back a different result. */
1942 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
1949 length = blen_chars;
1951 #if Size_t_size > IVSIZE
1952 length = (Size_t)SvNVx(*++MARK);
1954 length = (Size_t)SvIVx(*++MARK);
1956 if ((SSize_t)length < 0) {
1958 DIE(aTHX_ "Negative length");
1963 offset = SvIVx(*++MARK);
1965 if (-offset > (IV)blen_chars) {
1967 DIE(aTHX_ "Offset outside string");
1969 offset += blen_chars;
1970 } else if (offset > (IV)blen_chars) {
1972 DIE(aTHX_ "Offset outside string");
1976 if (length > blen_chars - offset)
1977 length = blen_chars - offset;
1979 /* Here we convert length from characters to bytes. */
1980 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1981 /* Either we had to convert the SV, or the SV is magical, or
1982 the SV has overloading, in which case we can't or mustn't
1983 or mustn't call it again. */
1985 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1986 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1988 /* It's a real UTF-8 SV, and it's not going to change under
1989 us. Take advantage of any cache. */
1991 I32 len_I32 = length;
1993 /* Convert the start and end character positions to bytes.
1994 Remember that the second argument to sv_pos_u2b is relative
1996 sv_pos_u2b(bufsv, &start, &len_I32);
2003 buffer = buffer+offset;
2005 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2006 if (IoTYPE(io) == IoTYPE_SOCKET) {
2007 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
2013 /* See the note at doio.c:do_print about filesize limits. --jhi */
2014 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2023 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2026 #if Size_t_size > IVSIZE
2046 * in Perl 5.12 and later, the additional parameter is a bitmask:
2049 * 2 = eof() <- ARGV magic
2051 * I'll rely on the compiler's trace flow analysis to decide whether to
2052 * actually assign this out here, or punt it into the only block where it is
2053 * used. Doing it out here is DRY on the condition logic.
2058 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2064 if (PL_op->op_flags & OPf_SPECIAL) {
2065 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2069 gv = PL_last_in_gv; /* eof */
2077 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2078 return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2081 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2082 if (io && !IoIFP(io)) {
2083 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2085 IoFLAGS(io) &= ~IOf_START;
2086 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2088 sv_setpvs(GvSV(gv), "-");
2090 GvSV(gv) = newSVpvs("-");
2091 SvSETMAGIC(GvSV(gv));
2093 else if (!nextargv(gv))
2098 PUSHs(boolSV(do_eof(gv)));
2108 if (MAXARG != 0 && (TOPs || POPs))
2109 PL_last_in_gv = MUTABLE_GV(POPs);
2116 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2118 return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2123 SETERRNO(EBADF,RMS_IFI);
2128 #if LSEEKSIZE > IVSIZE
2129 PUSHn( do_tell(gv) );
2131 PUSHi( do_tell(gv) );
2139 const int whence = POPi;
2140 #if LSEEKSIZE > IVSIZE
2141 const Off_t offset = (Off_t)SvNVx(POPs);
2143 const Off_t offset = (Off_t)SvIVx(POPs);
2146 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2147 IO *const io = GvIO(gv);
2150 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2152 #if LSEEKSIZE > IVSIZE
2153 SV *const offset_sv = newSVnv((NV) offset);
2155 SV *const offset_sv = newSViv(offset);
2158 return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2163 if (PL_op->op_type == OP_SEEK)
2164 PUSHs(boolSV(do_seek(gv, offset, whence)));
2166 const Off_t sought = do_sysseek(gv, offset, whence);
2168 PUSHs(&PL_sv_undef);
2170 SV* const sv = sought ?
2171 #if LSEEKSIZE > IVSIZE
2176 : newSVpvn(zero_but_true, ZBTLEN);
2187 /* There seems to be no consensus on the length type of truncate()
2188 * and ftruncate(), both off_t and size_t have supporters. In
2189 * general one would think that when using large files, off_t is
2190 * at least as wide as size_t, so using an off_t should be okay. */
2191 /* XXX Configure probe for the length type of *truncate() needed XXX */
2194 #if Off_t_size > IVSIZE
2199 /* Checking for length < 0 is problematic as the type might or
2200 * might not be signed: if it is not, clever compilers will moan. */
2201 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2204 SV * const sv = POPs;
2209 if (PL_op->op_flags & OPf_SPECIAL
2210 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2211 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2218 TAINT_PROPER("truncate");
2219 if (!(fp = IoIFP(io))) {
2225 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2227 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2233 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2234 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2235 goto do_ftruncate_io;
2238 const char * const name = SvPV_nomg_const_nolen(sv);
2239 TAINT_PROPER("truncate");
2241 if (truncate(name, len) < 0)
2245 const int tmpfd = PerlLIO_open(name, O_RDWR);
2250 if (my_chsize(tmpfd, len) < 0)
2252 PerlLIO_close(tmpfd);
2261 SETERRNO(EBADF,RMS_IFI);
2269 SV * const argsv = POPs;
2270 const unsigned int func = POPu;
2271 const int optype = PL_op->op_type;
2272 GV * const gv = MUTABLE_GV(POPs);
2273 IO * const io = gv ? GvIOn(gv) : NULL;
2277 if (!io || !argsv || !IoIFP(io)) {
2279 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2283 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2286 s = SvPV_force(argsv, len);
2287 need = IOCPARM_LEN(func);
2289 s = Sv_Grow(argsv, need + 1);
2290 SvCUR_set(argsv, need);
2293 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2296 retval = SvIV(argsv);
2297 s = INT2PTR(char*,retval); /* ouch */
2300 TAINT_PROPER(PL_op_desc[optype]);
2302 if (optype == OP_IOCTL)
2304 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2306 DIE(aTHX_ "ioctl is not implemented");
2310 DIE(aTHX_ "fcntl is not implemented");
2312 #if defined(OS2) && defined(__EMX__)
2313 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2315 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2319 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2321 if (s[SvCUR(argsv)] != 17)
2322 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2324 s[SvCUR(argsv)] = 0; /* put our null back */
2325 SvSETMAGIC(argsv); /* Assume it has changed */
2334 PUSHp(zero_but_true, ZBTLEN);
2345 const int argtype = POPi;
2346 GV * const gv = MUTABLE_GV(POPs);
2347 IO *const io = GvIO(gv);
2348 PerlIO *const fp = io ? IoIFP(io) : NULL;
2350 /* XXX Looks to me like io is always NULL at this point */
2352 (void)PerlIO_flush(fp);
2353 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2358 SETERRNO(EBADF,RMS_IFI);
2363 DIE(aTHX_ PL_no_func, "flock()");
2374 const int protocol = POPi;
2375 const int type = POPi;
2376 const int domain = POPi;
2377 GV * const gv = MUTABLE_GV(POPs);
2378 IO * const io = gv ? GvIOn(gv) : NULL;
2383 if (io && IoIFP(io))
2384 do_close(gv, FALSE);
2385 SETERRNO(EBADF,LIB_INVARG);
2390 do_close(gv, FALSE);
2392 TAINT_PROPER("socket");
2393 fd = PerlSock_socket(domain, type, protocol);
2396 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2397 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2398 IoTYPE(io) = IoTYPE_SOCKET;
2399 if (!IoIFP(io) || !IoOFP(io)) {
2400 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2401 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2402 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2405 #if defined(HAS_FCNTL) && defined(F_SETFD)
2406 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2415 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2417 const int protocol = POPi;
2418 const int type = POPi;
2419 const int domain = POPi;
2420 GV * const gv2 = MUTABLE_GV(POPs);
2421 GV * const gv1 = MUTABLE_GV(POPs);
2422 IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2423 IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2427 report_evil_fh(gv1);
2429 report_evil_fh(gv2);
2431 if (io1 && IoIFP(io1))
2432 do_close(gv1, FALSE);
2433 if (io2 && IoIFP(io2))
2434 do_close(gv2, FALSE);
2439 TAINT_PROPER("socketpair");
2440 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2442 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2443 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2444 IoTYPE(io1) = IoTYPE_SOCKET;
2445 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2446 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2447 IoTYPE(io2) = IoTYPE_SOCKET;
2448 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2449 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2450 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2451 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2452 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2453 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2454 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2457 #if defined(HAS_FCNTL) && defined(F_SETFD)
2458 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2459 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2464 DIE(aTHX_ PL_no_sock_func, "socketpair");
2473 SV * const addrsv = POPs;
2474 /* OK, so on what platform does bind modify addr? */
2476 GV * const gv = MUTABLE_GV(POPs);
2477 IO * const io = GvIOn(gv);
2479 const int op_type = PL_op->op_type;
2481 if (!io || !IoIFP(io))
2484 addr = SvPV_const(addrsv, len);
2485 TAINT_PROPER(PL_op_desc[op_type]);
2486 if ((op_type == OP_BIND
2487 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2488 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2496 SETERRNO(EBADF,SS_IVCHAN);
2503 const int backlog = POPi;
2504 GV * const gv = MUTABLE_GV(POPs);
2505 IO * const io = gv ? GvIOn(gv) : NULL;
2507 if (!io || !IoIFP(io))
2510 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2517 SETERRNO(EBADF,SS_IVCHAN);
2526 char namebuf[MAXPATHLEN];
2527 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2528 Sock_size_t len = sizeof (struct sockaddr_in);
2530 Sock_size_t len = sizeof namebuf;
2532 GV * const ggv = MUTABLE_GV(POPs);
2533 GV * const ngv = MUTABLE_GV(POPs);
2542 if (!gstio || !IoIFP(gstio))
2546 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2549 /* Some platforms indicate zero length when an AF_UNIX client is
2550 * not bound. Simulate a non-zero-length sockaddr structure in
2552 namebuf[0] = 0; /* sun_len */
2553 namebuf[1] = AF_UNIX; /* sun_family */
2561 do_close(ngv, FALSE);
2562 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2563 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2564 IoTYPE(nstio) = IoTYPE_SOCKET;
2565 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2566 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2567 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2568 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2571 #if defined(HAS_FCNTL) && defined(F_SETFD)
2572 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2575 #ifdef __SCO_VERSION__
2576 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2579 PUSHp(namebuf, len);
2583 report_evil_fh(ggv);
2584 SETERRNO(EBADF,SS_IVCHAN);
2594 const int how = POPi;
2595 GV * const gv = MUTABLE_GV(POPs);
2596 IO * const io = GvIOn(gv);
2598 if (!io || !IoIFP(io))
2601 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2606 SETERRNO(EBADF,SS_IVCHAN);
2613 const int optype = PL_op->op_type;
2614 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2615 const unsigned int optname = (unsigned int) POPi;
2616 const unsigned int lvl = (unsigned int) POPi;
2617 GV * const gv = MUTABLE_GV(POPs);
2618 IO * const io = GvIOn(gv);
2622 if (!io || !IoIFP(io))
2625 fd = PerlIO_fileno(IoIFP(io));
2629 (void)SvPOK_only(sv);
2633 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2640 #if defined(__SYMBIAN32__)
2641 # define SETSOCKOPT_OPTION_VALUE_T void *
2643 # define SETSOCKOPT_OPTION_VALUE_T const char *
2645 /* XXX TODO: We need to have a proper type (a Configure probe,
2646 * etc.) for what the C headers think of the third argument of
2647 * setsockopt(), the option_value read-only buffer: is it
2648 * a "char *", or a "void *", const or not. Some compilers
2649 * don't take kindly to e.g. assuming that "char *" implicitly
2650 * promotes to a "void *", or to explicitly promoting/demoting
2651 * consts to non/vice versa. The "const void *" is the SUS
2652 * definition, but that does not fly everywhere for the above
2654 SETSOCKOPT_OPTION_VALUE_T buf;
2658 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2662 aint = (int)SvIV(sv);
2663 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2666 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2676 SETERRNO(EBADF,SS_IVCHAN);
2685 const int optype = PL_op->op_type;
2686 GV * const gv = MUTABLE_GV(POPs);
2687 IO * const io = GvIOn(gv);
2692 if (!io || !IoIFP(io))
2695 sv = sv_2mortal(newSV(257));
2696 (void)SvPOK_only(sv);
2700 fd = PerlIO_fileno(IoIFP(io));
2702 case OP_GETSOCKNAME:
2703 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2706 case OP_GETPEERNAME:
2707 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2709 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2711 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";
2712 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2713 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2714 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2715 sizeof(u_short) + sizeof(struct in_addr))) {
2722 #ifdef BOGUS_GETNAME_RETURN
2723 /* Interactive Unix, getpeername() and getsockname()
2724 does not return valid namelen */
2725 if (len == BOGUS_GETNAME_RETURN)
2726 len = sizeof(struct sockaddr);
2735 SETERRNO(EBADF,SS_IVCHAN);
2754 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2755 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2756 if (PL_op->op_type == OP_LSTAT) {
2757 if (gv != PL_defgv) {
2758 do_fstat_warning_check:
2759 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2760 "lstat() on filehandle%s%"SVf,
2763 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2765 } else if (PL_laststype != OP_LSTAT)
2766 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2767 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2770 if (gv != PL_defgv) {
2774 PL_laststype = OP_STAT;
2775 PL_statgv = gv ? gv : (GV *)io;
2776 sv_setpvs(PL_statname, "");
2783 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2785 } else if (IoDIRP(io)) {
2787 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2790 PL_laststatval = -1;
2793 else PL_laststatval = -1;
2794 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2797 if (PL_laststatval < 0) {
2802 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2803 io = MUTABLE_IO(SvRV(sv));
2804 if (PL_op->op_type == OP_LSTAT)
2805 goto do_fstat_warning_check;
2806 goto do_fstat_have_io;
2809 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2810 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2812 PL_laststype = PL_op->op_type;
2813 if (PL_op->op_type == OP_LSTAT)
2814 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2816 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2817 if (PL_laststatval < 0) {
2818 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2819 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2825 if (gimme != G_ARRAY) {
2826 if (gimme != G_VOID)
2827 XPUSHs(boolSV(max));
2833 mPUSHi(PL_statcache.st_dev);
2834 #if ST_INO_SIZE > IVSIZE
2835 mPUSHn(PL_statcache.st_ino);
2837 # if ST_INO_SIGN <= 0
2838 mPUSHi(PL_statcache.st_ino);
2840 mPUSHu(PL_statcache.st_ino);
2843 mPUSHu(PL_statcache.st_mode);
2844 mPUSHu(PL_statcache.st_nlink);
2846 sv_setuid(PUSHmortal, PL_statcache.st_uid);
2847 sv_setgid(PUSHmortal, PL_statcache.st_gid);
2849 #ifdef USE_STAT_RDEV
2850 mPUSHi(PL_statcache.st_rdev);
2852 PUSHs(newSVpvs_flags("", SVs_TEMP));
2854 #if Off_t_size > IVSIZE
2855 mPUSHn(PL_statcache.st_size);
2857 mPUSHi(PL_statcache.st_size);
2860 mPUSHn(PL_statcache.st_atime);
2861 mPUSHn(PL_statcache.st_mtime);
2862 mPUSHn(PL_statcache.st_ctime);
2864 mPUSHi(PL_statcache.st_atime);
2865 mPUSHi(PL_statcache.st_mtime);
2866 mPUSHi(PL_statcache.st_ctime);
2868 #ifdef USE_STAT_BLOCKS
2869 mPUSHu(PL_statcache.st_blksize);
2870 mPUSHu(PL_statcache.st_blocks);
2872 PUSHs(newSVpvs_flags("", SVs_TEMP));
2873 PUSHs(newSVpvs_flags("", SVs_TEMP));
2879 /* All filetest ops avoid manipulating the perl stack pointer in their main
2880 bodies (since commit d2c4d2d1e22d3125), and return using either
2881 S_ft_return_false() or S_ft_return_true(). These two helper functions are
2882 the only two which manipulate the perl stack. To ensure that no stack
2883 manipulation macros are used, the filetest ops avoid defining a local copy
2884 of the stack pointer with dSP. */
2886 /* If the next filetest is stacked up with this one
2887 (PL_op->op_private & OPpFT_STACKING), we leave
2888 the original argument on the stack for success,
2889 and skip the stacked operators on failure.
2890 The next few macros/functions take care of this.
2894 S_ft_return_false(pTHX_ SV *ret) {
2898 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
2902 if (PL_op->op_private & OPpFT_STACKING) {
2903 while (OP_IS_FILETEST(next->op_type)
2904 && next->op_private & OPpFT_STACKED)
2905 next = next->op_next;
2910 PERL_STATIC_INLINE OP *
2911 S_ft_return_true(pTHX_ SV *ret) {
2913 if (PL_op->op_flags & OPf_REF)
2914 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
2915 else if (!(PL_op->op_private & OPpFT_STACKING))
2921 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
2922 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
2923 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
2925 #define tryAMAGICftest_MG(chr) STMT_START { \
2926 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
2927 && PL_op->op_flags & OPf_KIDS) { \
2928 OP *next = S_try_amagic_ftest(aTHX_ chr); \
2929 if (next) return next; \
2934 S_try_amagic_ftest(pTHX_ char chr) {
2936 SV *const arg = *PL_stack_sp;
2939 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
2943 const char tmpchr = chr;
2944 SV * const tmpsv = amagic_call(arg,
2945 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2946 ftest_amg, AMGf_unary);
2951 return SvTRUE(tmpsv)
2952 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
2962 /* Not const, because things tweak this below. Not bool, because there's
2963 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2964 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2965 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2966 /* Giving some sort of initial value silences compilers. */
2968 int access_mode = R_OK;
2970 int access_mode = 0;
2973 /* access_mode is never used, but leaving use_access in makes the
2974 conditional compiling below much clearer. */
2977 Mode_t stat_mode = S_IRUSR;
2979 bool effective = FALSE;
2982 switch (PL_op->op_type) {
2983 case OP_FTRREAD: opchar = 'R'; break;
2984 case OP_FTRWRITE: opchar = 'W'; break;
2985 case OP_FTREXEC: opchar = 'X'; break;
2986 case OP_FTEREAD: opchar = 'r'; break;
2987 case OP_FTEWRITE: opchar = 'w'; break;
2988 case OP_FTEEXEC: opchar = 'x'; break;
2990 tryAMAGICftest_MG(opchar);
2992 switch (PL_op->op_type) {
2994 #if !(defined(HAS_ACCESS) && defined(R_OK))
3000 #if defined(HAS_ACCESS) && defined(W_OK)
3005 stat_mode = S_IWUSR;
3009 #if defined(HAS_ACCESS) && defined(X_OK)
3014 stat_mode = S_IXUSR;
3018 #ifdef PERL_EFF_ACCESS
3021 stat_mode = S_IWUSR;
3025 #ifndef PERL_EFF_ACCESS
3032 #ifdef PERL_EFF_ACCESS
3037 stat_mode = S_IXUSR;
3043 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3044 const char *name = SvPV_nolen(*PL_stack_sp);
3046 # ifdef PERL_EFF_ACCESS
3047 result = PERL_EFF_ACCESS(name, access_mode);
3049 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3055 result = access(name, access_mode);
3057 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3068 result = my_stat_flags(0);
3071 if (cando(stat_mode, effective, &PL_statcache))
3080 const int op_type = PL_op->op_type;
3084 case OP_FTIS: opchar = 'e'; break;
3085 case OP_FTSIZE: opchar = 's'; break;
3086 case OP_FTMTIME: opchar = 'M'; break;
3087 case OP_FTCTIME: opchar = 'C'; break;
3088 case OP_FTATIME: opchar = 'A'; break;
3090 tryAMAGICftest_MG(opchar);
3092 result = my_stat_flags(0);
3095 if (op_type == OP_FTIS)
3098 /* You can't dTARGET inside OP_FTIS, because you'll get
3099 "panic: pad_sv po" - the op is not flagged to have a target. */
3103 #if Off_t_size > IVSIZE
3104 sv_setnv(TARG, (NV)PL_statcache.st_size);
3106 sv_setiv(TARG, (IV)PL_statcache.st_size);
3111 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3115 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3119 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3123 return SvTRUE_nomg(TARG)
3124 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3134 switch (PL_op->op_type) {
3135 case OP_FTROWNED: opchar = 'O'; break;
3136 case OP_FTEOWNED: opchar = 'o'; break;
3137 case OP_FTZERO: opchar = 'z'; break;
3138 case OP_FTSOCK: opchar = 'S'; break;
3139 case OP_FTCHR: opchar = 'c'; break;
3140 case OP_FTBLK: opchar = 'b'; break;
3141 case OP_FTFILE: opchar = 'f'; break;
3142 case OP_FTDIR: opchar = 'd'; break;
3143 case OP_FTPIPE: opchar = 'p'; break;
3144 case OP_FTSUID: opchar = 'u'; break;
3145 case OP_FTSGID: opchar = 'g'; break;
3146 case OP_FTSVTX: opchar = 'k'; break;
3148 tryAMAGICftest_MG(opchar);
3150 /* I believe that all these three are likely to be defined on most every
3151 system these days. */
3153 if(PL_op->op_type == OP_FTSUID) {
3158 if(PL_op->op_type == OP_FTSGID) {
3163 if(PL_op->op_type == OP_FTSVTX) {
3168 result = my_stat_flags(0);
3171 switch (PL_op->op_type) {
3173 if (PL_statcache.st_uid == PerlProc_getuid())
3177 if (PL_statcache.st_uid == PerlProc_geteuid())
3181 if (PL_statcache.st_size == 0)
3185 if (S_ISSOCK(PL_statcache.st_mode))
3189 if (S_ISCHR(PL_statcache.st_mode))
3193 if (S_ISBLK(PL_statcache.st_mode))
3197 if (S_ISREG(PL_statcache.st_mode))
3201 if (S_ISDIR(PL_statcache.st_mode))
3205 if (S_ISFIFO(PL_statcache.st_mode))
3210 if (PL_statcache.st_mode & S_ISUID)
3216 if (PL_statcache.st_mode & S_ISGID)
3222 if (PL_statcache.st_mode & S_ISVTX)
3235 tryAMAGICftest_MG('l');
3236 result = my_lstat_flags(0);
3240 if (S_ISLNK(PL_statcache.st_mode))
3253 tryAMAGICftest_MG('t');
3255 if (PL_op->op_flags & OPf_REF)
3258 SV *tmpsv = *PL_stack_sp;
3259 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3260 name = SvPV_nomg(tmpsv, namelen);
3261 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3265 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3266 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3267 else if (name && isDIGIT(*name))
3271 if (PerlLIO_isatty(fd))
3289 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3291 if (PL_op->op_flags & OPf_REF)
3293 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3298 gv = MAYBE_DEREF_GV_nomg(sv);
3302 if (gv == PL_defgv) {
3304 io = SvTYPE(PL_statgv) == SVt_PVIO
3308 goto really_filename;
3313 sv_setpvs(PL_statname, "");
3314 io = GvIO(PL_statgv);
3316 PL_laststatval = -1;
3317 PL_laststype = OP_STAT;
3318 if (io && IoIFP(io)) {
3319 if (! PerlIO_has_base(IoIFP(io)))
3320 DIE(aTHX_ "-T and -B not implemented on filehandles");
3321 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3322 if (PL_laststatval < 0)
3324 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3325 if (PL_op->op_type == OP_FTTEXT)
3330 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3331 i = PerlIO_getc(IoIFP(io));
3333 (void)PerlIO_ungetc(IoIFP(io),i);
3335 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3337 len = PerlIO_get_bufsiz(IoIFP(io));
3338 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3339 /* sfio can have large buffers - limit to 512 */
3344 SETERRNO(EBADF,RMS_IFI);
3346 SETERRNO(EBADF,RMS_IFI);
3351 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3354 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3356 PL_laststatval = -1;
3357 PL_laststype = OP_STAT;
3359 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3361 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3364 PL_laststype = OP_STAT;
3365 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3366 if (PL_laststatval < 0) {
3367 (void)PerlIO_close(fp);
3370 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3371 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3372 (void)PerlIO_close(fp);
3374 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3375 FT_RETURNNO; /* special case NFS directories */
3376 FT_RETURNYES; /* null file is anything */
3381 /* now scan s to look for textiness */
3382 /* XXX ASCII dependent code */
3384 #if defined(DOSISH) || defined(USEMYBINMODE)
3385 /* ignore trailing ^Z on short files */
3386 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3390 for (i = 0; i < len; i++, s++) {
3391 if (!*s) { /* null never allowed in text */
3396 else if (!(isPRINT(*s) || isSPACE(*s)))
3399 else if (*s & 128) {
3401 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3404 /* utf8 characters don't count as odd */
3405 if (UTF8_IS_START(*s)) {
3406 int ulen = UTF8SKIP(s);
3407 if (ulen < len - i) {
3409 for (j = 1; j < ulen; j++) {
3410 if (!UTF8_IS_CONTINUATION(s[j]))
3413 --ulen; /* loop does extra increment */
3423 *s != '\n' && *s != '\r' && *s != '\b' &&
3424 *s != '\t' && *s != '\f' && *s != 27)
3429 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3440 const char *tmps = NULL;
3444 SV * const sv = POPs;
3445 if (PL_op->op_flags & OPf_SPECIAL) {
3446 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3448 else if (!(gv = MAYBE_DEREF_GV(sv)))
3449 tmps = SvPV_nomg_const_nolen(sv);
3452 if( !gv && (!tmps || !*tmps) ) {
3453 HV * const table = GvHVn(PL_envgv);
3456 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3457 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3459 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3464 deprecate("chdir('') or chdir(undef) as chdir()");
3465 tmps = SvPV_nolen_const(*svp);
3469 TAINT_PROPER("chdir");
3474 TAINT_PROPER("chdir");
3477 IO* const io = GvIO(gv);
3480 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3481 } else if (IoIFP(io)) {
3482 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3486 SETERRNO(EBADF, RMS_IFI);
3492 SETERRNO(EBADF,RMS_IFI);
3496 DIE(aTHX_ PL_no_func, "fchdir");
3500 PUSHi( PerlDir_chdir(tmps) >= 0 );
3502 /* Clear the DEFAULT element of ENV so we'll get the new value
3504 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3511 dVAR; dSP; dMARK; dTARGET;
3512 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3523 char * const tmps = POPpx;
3524 TAINT_PROPER("chroot");
3525 PUSHi( chroot(tmps) >= 0 );
3528 DIE(aTHX_ PL_no_func, "chroot");
3536 const char * const tmps2 = POPpconstx;
3537 const char * const tmps = SvPV_nolen_const(TOPs);
3538 TAINT_PROPER("rename");
3540 anum = PerlLIO_rename(tmps, tmps2);
3542 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3543 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3546 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3547 (void)UNLINK(tmps2);
3548 if (!(anum = link(tmps, tmps2)))
3549 anum = UNLINK(tmps);
3557 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3561 const int op_type = PL_op->op_type;
3565 if (op_type == OP_LINK)
3566 DIE(aTHX_ PL_no_func, "link");
3568 # ifndef HAS_SYMLINK
3569 if (op_type == OP_SYMLINK)
3570 DIE(aTHX_ PL_no_func, "symlink");
3574 const char * const tmps2 = POPpconstx;
3575 const char * const tmps = SvPV_nolen_const(TOPs);
3576 TAINT_PROPER(PL_op_desc[op_type]);
3578 # if defined(HAS_LINK)
3579 # if defined(HAS_SYMLINK)
3580 /* Both present - need to choose which. */
3581 (op_type == OP_LINK) ?
3582 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3584 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3585 PerlLIO_link(tmps, tmps2);
3588 # if defined(HAS_SYMLINK)
3589 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3590 symlink(tmps, tmps2);
3595 SETi( result >= 0 );
3602 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3613 char buf[MAXPATHLEN];
3616 #ifndef INCOMPLETE_TAINTS
3620 len = readlink(tmps, buf, sizeof(buf) - 1);
3627 RETSETUNDEF; /* just pretend it's a normal file */
3631 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3633 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3635 char * const save_filename = filename;
3640 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3642 PERL_ARGS_ASSERT_DOONELINER;
3644 Newx(cmdline, size, char);
3645 my_strlcpy(cmdline, cmd, size);
3646 my_strlcat(cmdline, " ", size);
3647 for (s = cmdline + strlen(cmdline); *filename; ) {
3651 if (s - cmdline < size)
3652 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3653 myfp = PerlProc_popen(cmdline, "r");
3657 SV * const tmpsv = sv_newmortal();
3658 /* Need to save/restore 'PL_rs' ?? */
3659 s = sv_gets(tmpsv, myfp, 0);
3660 (void)PerlProc_pclose(myfp);
3664 #ifdef HAS_SYS_ERRLIST
3669 /* you don't see this */
3670 const char * const errmsg = Strerror(e) ;
3673 if (instr(s, errmsg)) {
3680 #define EACCES EPERM
3682 if (instr(s, "cannot make"))
3683 SETERRNO(EEXIST,RMS_FEX);
3684 else if (instr(s, "existing file"))
3685 SETERRNO(EEXIST,RMS_FEX);
3686 else if (instr(s, "ile exists"))
3687 SETERRNO(EEXIST,RMS_FEX);
3688 else if (instr(s, "non-exist"))
3689 SETERRNO(ENOENT,RMS_FNF);
3690 else if (instr(s, "does not exist"))
3691 SETERRNO(ENOENT,RMS_FNF);
3692 else if (instr(s, "not empty"))
3693 SETERRNO(EBUSY,SS_DEVOFFLINE);
3694 else if (instr(s, "cannot access"))
3695 SETERRNO(EACCES,RMS_PRV);
3697 SETERRNO(EPERM,RMS_PRV);
3700 else { /* some mkdirs return no failure indication */
3701 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3702 if (PL_op->op_type == OP_RMDIR)
3707 SETERRNO(EACCES,RMS_PRV); /* a guess */
3716 /* This macro removes trailing slashes from a directory name.
3717 * Different operating and file systems take differently to
3718 * trailing slashes. According to POSIX 1003.1 1996 Edition
3719 * any number of trailing slashes should be allowed.
3720 * Thusly we snip them away so that even non-conforming
3721 * systems are happy.
3722 * We should probably do this "filtering" for all
3723 * the functions that expect (potentially) directory names:
3724 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3725 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3727 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3728 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3731 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3732 (tmps) = savepvn((tmps), (len)); \
3742 const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3744 TRIMSLASHES(tmps,len,copy);
3746 TAINT_PROPER("mkdir");
3748 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3752 SETi( dooneliner("mkdir", tmps) );
3753 oldumask = PerlLIO_umask(0);
3754 PerlLIO_umask(oldumask);
3755 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3770 TRIMSLASHES(tmps,len,copy);
3771 TAINT_PROPER("rmdir");
3773 SETi( PerlDir_rmdir(tmps) >= 0 );
3775 SETi( dooneliner("rmdir", tmps) );
3782 /* Directory calls. */
3786 #if defined(Direntry_t) && defined(HAS_READDIR)
3788 const char * const dirname = POPpconstx;
3789 GV * const gv = MUTABLE_GV(POPs);
3790 IO * const io = GvIOn(gv);
3795 if ((IoIFP(io) || IoOFP(io)))
3796 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3797 "Opening filehandle %"HEKf" also as a directory",
3798 HEKfARG(GvENAME_HEK(gv)) );
3800 PerlDir_close(IoDIRP(io));
3801 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3807 SETERRNO(EBADF,RMS_DIR);
3810 DIE(aTHX_ PL_no_dir_func, "opendir");
3816 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3817 DIE(aTHX_ PL_no_dir_func, "readdir");
3819 #if !defined(I_DIRENT) && !defined(VMS)
3820 Direntry_t *readdir (DIR *);
3826 const I32 gimme = GIMME;
3827 GV * const gv = MUTABLE_GV(POPs);
3828 const Direntry_t *dp;
3829 IO * const io = GvIOn(gv);
3831 if (!io || !IoDIRP(io)) {
3832 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3833 "readdir() attempted on invalid dirhandle %"HEKf,
3834 HEKfARG(GvENAME_HEK(gv)));
3839 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3843 sv = newSVpvn(dp->d_name, dp->d_namlen);
3845 sv = newSVpv(dp->d_name, 0);
3847 #ifndef INCOMPLETE_TAINTS
3848 if (!(IoFLAGS(io) & IOf_UNTAINT))
3852 } while (gimme == G_ARRAY);
3854 if (!dp && gimme != G_ARRAY)
3861 SETERRNO(EBADF,RMS_ISI);
3862 if (GIMME == G_ARRAY)
3871 #if defined(HAS_TELLDIR) || defined(telldir)
3873 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3874 /* XXX netbsd still seemed to.
3875 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3876 --JHI 1999-Feb-02 */
3877 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3878 long telldir (DIR *);
3880 GV * const gv = MUTABLE_GV(POPs);
3881 IO * const io = GvIOn(gv);
3883 if (!io || !IoDIRP(io)) {
3884 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3885 "telldir() attempted on invalid dirhandle %"HEKf,
3886 HEKfARG(GvENAME_HEK(gv)));
3890 PUSHi( PerlDir_tell(IoDIRP(io)) );
3894 SETERRNO(EBADF,RMS_ISI);
3897 DIE(aTHX_ PL_no_dir_func, "telldir");
3903 #if defined(HAS_SEEKDIR) || defined(seekdir)
3905 const long along = POPl;
3906 GV * const gv = MUTABLE_GV(POPs);
3907 IO * const io = GvIOn(gv);
3909 if (!io || !IoDIRP(io)) {
3910 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3911 "seekdir() attempted on invalid dirhandle %"HEKf,
3912 HEKfARG(GvENAME_HEK(gv)));
3915 (void)PerlDir_seek(IoDIRP(io), along);
3920 SETERRNO(EBADF,RMS_ISI);
3923 DIE(aTHX_ PL_no_dir_func, "seekdir");
3929 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3931 GV * const gv = MUTABLE_GV(POPs);
3932 IO * const io = GvIOn(gv);
3934 if (!io || !IoDIRP(io)) {
3935 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3936 "rewinddir() attempted on invalid dirhandle %"HEKf,
3937 HEKfARG(GvENAME_HEK(gv)));
3940 (void)PerlDir_rewind(IoDIRP(io));
3944 SETERRNO(EBADF,RMS_ISI);
3947 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3953 #if defined(Direntry_t) && defined(HAS_READDIR)
3955 GV * const gv = MUTABLE_GV(POPs);
3956 IO * const io = GvIOn(gv);
3958 if (!io || !IoDIRP(io)) {
3959 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3960 "closedir() attempted on invalid dirhandle %"HEKf,
3961 HEKfARG(GvENAME_HEK(gv)));
3964 #ifdef VOID_CLOSEDIR
3965 PerlDir_close(IoDIRP(io));
3967 if (PerlDir_close(IoDIRP(io)) < 0) {
3968 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3977 SETERRNO(EBADF,RMS_IFI);
3980 DIE(aTHX_ PL_no_dir_func, "closedir");
3984 /* Process control. */
3991 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
3992 sigset_t oldmask, newmask;
3996 PERL_FLUSHALL_FOR_CHILD;
3997 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
3998 sigfillset(&newmask);
3999 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4001 childpid = PerlProc_fork();
4002 if (childpid == 0) {
4006 for (sig = 1; sig < SIG_SIZE; sig++)
4007 PL_psig_pend[sig] = 0;
4009 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4012 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4019 #ifdef PERL_USES_PL_PIDSTATUS
4020 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4026 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4031 PERL_FLUSHALL_FOR_CHILD;
4032 childpid = PerlProc_fork();
4038 DIE(aTHX_ PL_no_func, "fork");
4045 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4050 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4051 childpid = wait4pid(-1, &argflags, 0);
4053 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4058 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4059 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4060 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4062 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4067 DIE(aTHX_ PL_no_func, "wait");
4073 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4075 const int optype = POPi;
4076 const Pid_t pid = TOPi;
4080 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4081 result = wait4pid(pid, &argflags, optype);
4083 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4088 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4089 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4090 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4092 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4097 DIE(aTHX_ PL_no_func, "waitpid");
4103 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4104 #if defined(__LIBCATAMOUNT__)
4105 PL_statusvalue = -1;
4114 while (++MARK <= SP) {
4115 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4120 TAINT_PROPER("system");
4122 PERL_FLUSHALL_FOR_CHILD;
4123 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4128 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4129 sigset_t newset, oldset;
4132 if (PerlProc_pipe(pp) >= 0)
4134 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4135 sigemptyset(&newset);
4136 sigaddset(&newset, SIGCHLD);
4137 sigprocmask(SIG_BLOCK, &newset, &oldset);
4139 while ((childpid = PerlProc_fork()) == -1) {
4140 if (errno != EAGAIN) {
4145 PerlLIO_close(pp[0]);
4146 PerlLIO_close(pp[1]);
4148 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4149 sigprocmask(SIG_SETMASK, &oldset, NULL);
4156 Sigsave_t ihand,qhand; /* place to save signals during system() */
4160 PerlLIO_close(pp[1]);
4162 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4163 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4166 result = wait4pid(childpid, &status, 0);
4167 } while (result == -1 && errno == EINTR);
4169 #ifdef HAS_SIGPROCMASK
4170 sigprocmask(SIG_SETMASK, &oldset, NULL);
4172 (void)rsignal_restore(SIGINT, &ihand);
4173 (void)rsignal_restore(SIGQUIT, &qhand);
4175 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4176 do_execfree(); /* free any memory child malloced on fork */
4183 while (n < sizeof(int)) {
4184 n1 = PerlLIO_read(pp[0],
4185 (void*)(((char*)&errkid)+n),
4191 PerlLIO_close(pp[0]);
4192 if (n) { /* Error */
4193 if (n != sizeof(int))
4194 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4195 errno = errkid; /* Propagate errno from kid */
4196 STATUS_NATIVE_CHILD_SET(-1);
4199 XPUSHi(STATUS_CURRENT);
4202 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4203 sigprocmask(SIG_SETMASK, &oldset, NULL);
4206 PerlLIO_close(pp[0]);
4207 #if defined(HAS_FCNTL) && defined(F_SETFD)
4208 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4211 if (PL_op->op_flags & OPf_STACKED) {
4212 SV * const really = *++MARK;
4213 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4215 else if (SP - MARK != 1)
4216 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4218 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4222 #else /* ! FORK or VMS or OS/2 */
4225 if (PL_op->op_flags & OPf_STACKED) {
4226 SV * const really = *++MARK;
4227 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4228 value = (I32)do_aspawn(really, MARK, SP);
4230 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4233 else if (SP - MARK != 1) {
4234 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4235 value = (I32)do_aspawn(NULL, MARK, SP);
4237 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4241 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4243 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4245 STATUS_NATIVE_CHILD_SET(value);
4248 XPUSHi(result ? value : STATUS_CURRENT);
4249 #endif /* !FORK or VMS or OS/2 */
4256 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4261 while (++MARK <= SP) {
4262 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4267 TAINT_PROPER("exec");
4269 PERL_FLUSHALL_FOR_CHILD;
4270 if (PL_op->op_flags & OPf_STACKED) {
4271 SV * const really = *++MARK;
4272 value = (I32)do_aexec(really, MARK, SP);
4274 else if (SP - MARK != 1)
4276 value = (I32)vms_do_aexec(NULL, MARK, SP);
4278 value = (I32)do_aexec(NULL, MARK, SP);
4282 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4284 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4297 XPUSHi( getppid() );
4300 DIE(aTHX_ PL_no_func, "getppid");
4310 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4313 pgrp = (I32)BSD_GETPGRP(pid);
4315 if (pid != 0 && pid != PerlProc_getpid())
4316 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4322 DIE(aTHX_ PL_no_func, "getpgrp()");
4332 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4333 if (MAXARG > 0) pid = TOPs && TOPi;
4339 TAINT_PROPER("setpgrp");
4341 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4343 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4344 || (pid != 0 && pid != PerlProc_getpid()))
4346 DIE(aTHX_ "setpgrp can't take arguments");
4348 SETi( setpgrp() >= 0 );
4349 #endif /* USE_BSDPGRP */
4352 DIE(aTHX_ PL_no_func, "setpgrp()");
4356 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4357 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4359 # define PRIORITY_WHICH_T(which) which
4364 #ifdef HAS_GETPRIORITY
4366 const int who = POPi;
4367 const int which = TOPi;
4368 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4371 DIE(aTHX_ PL_no_func, "getpriority()");
4377 #ifdef HAS_SETPRIORITY
4379 const int niceval = POPi;
4380 const int who = POPi;
4381 const int which = TOPi;
4382 TAINT_PROPER("setpriority");
4383 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4386 DIE(aTHX_ PL_no_func, "setpriority()");
4390 #undef PRIORITY_WHICH_T
4398 XPUSHn( time(NULL) );
4400 XPUSHi( time(NULL) );
4412 (void)PerlProc_times(&PL_timesbuf);
4414 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4415 /* struct tms, though same data */
4419 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4420 if (GIMME == G_ARRAY) {
4421 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4422 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4423 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4431 if (GIMME == G_ARRAY) {
4438 DIE(aTHX_ "times not implemented");
4440 #endif /* HAS_TIMES */
4443 /* The 32 bit int year limits the times we can represent to these
4444 boundaries with a few days wiggle room to account for time zone
4447 /* Sat Jan 3 00:00:00 -2147481748 */
4448 #define TIME_LOWER_BOUND -67768100567755200.0
4449 /* Sun Dec 29 12:00:00 2147483647 */
4450 #define TIME_UPPER_BOUND 67767976233316800.0
4459 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4460 static const char * const dayname[] =
4461 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4462 static const char * const monname[] =
4463 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4464 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4466 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4469 when = (Time64_T)now;
4472 NV input = Perl_floor(POPn);
4473 when = (Time64_T)input;
4474 if (when != input) {
4475 /* diag_listed_as: gmtime(%f) too large */
4476 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4477 "%s(%.0" NVff ") too large", opname, input);
4481 if ( TIME_LOWER_BOUND > when ) {
4482 /* diag_listed_as: gmtime(%f) too small */
4483 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4484 "%s(%.0" NVff ") too small", opname, when);
4487 else if( when > TIME_UPPER_BOUND ) {
4488 /* diag_listed_as: gmtime(%f) too small */
4489 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4490 "%s(%.0" NVff ") too large", opname, when);
4494 if (PL_op->op_type == OP_LOCALTIME)
4495 err = S_localtime64_r(&when, &tmbuf);
4497 err = S_gmtime64_r(&when, &tmbuf);
4501 /* XXX %lld broken for quads */
4502 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4503 "%s(%.0" NVff ") failed", opname, when);
4506 if (GIMME != G_ARRAY) { /* scalar context */
4508 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4509 double year = (double)tmbuf.tm_year + 1900;
4516 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4517 dayname[tmbuf.tm_wday],
4518 monname[tmbuf.tm_mon],
4526 else { /* list context */
4532 mPUSHi(tmbuf.tm_sec);
4533 mPUSHi(tmbuf.tm_min);
4534 mPUSHi(tmbuf.tm_hour);
4535 mPUSHi(tmbuf.tm_mday);
4536 mPUSHi(tmbuf.tm_mon);
4537 mPUSHn(tmbuf.tm_year);
4538 mPUSHi(tmbuf.tm_wday);
4539 mPUSHi(tmbuf.tm_yday);
4540 mPUSHi(tmbuf.tm_isdst);
4551 anum = alarm((unsigned int)anum);
4557 DIE(aTHX_ PL_no_func, "alarm");
4568 (void)time(&lasttime);
4569 if (MAXARG < 1 || (!TOPs && !POPs))
4573 PerlProc_sleep((unsigned int)duration);
4576 XPUSHi(when - lasttime);
4580 /* Shared memory. */
4581 /* Merged with some message passing. */
4585 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4586 dVAR; dSP; dMARK; dTARGET;
4587 const int op_type = PL_op->op_type;
4592 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4595 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4598 value = (I32)(do_semop(MARK, SP) >= 0);
4601 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4609 return Perl_pp_semget(aTHX);
4617 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4618 dVAR; dSP; dMARK; dTARGET;
4619 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4626 DIE(aTHX_ "System V IPC is not implemented on this machine");
4632 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4633 dVAR; dSP; dMARK; dTARGET;
4634 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4642 PUSHp(zero_but_true, ZBTLEN);
4646 return Perl_pp_semget(aTHX);
4650 /* I can't const this further without getting warnings about the types of
4651 various arrays passed in from structures. */
4653 S_space_join_names_mortal(pTHX_ char *const *array)
4657 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4659 if (array && *array) {
4660 target = newSVpvs_flags("", SVs_TEMP);
4662 sv_catpv(target, *array);
4665 sv_catpvs(target, " ");
4668 target = sv_mortalcopy(&PL_sv_no);
4673 /* Get system info. */
4677 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4679 I32 which = PL_op->op_type;
4682 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4683 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4684 struct hostent *gethostbyname(Netdb_name_t);
4685 struct hostent *gethostent(void);
4687 struct hostent *hent = NULL;
4691 if (which == OP_GHBYNAME) {
4692 #ifdef HAS_GETHOSTBYNAME
4693 const char* const name = POPpbytex;
4694 hent = PerlSock_gethostbyname(name);
4696 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4699 else if (which == OP_GHBYADDR) {
4700 #ifdef HAS_GETHOSTBYADDR
4701 const int addrtype = POPi;
4702 SV * const addrsv = POPs;
4704 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4706 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4708 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4712 #ifdef HAS_GETHOSTENT
4713 hent = PerlSock_gethostent();
4715 DIE(aTHX_ PL_no_sock_func, "gethostent");
4718 #ifdef HOST_NOT_FOUND
4720 #ifdef USE_REENTRANT_API
4721 # ifdef USE_GETHOSTENT_ERRNO
4722 h_errno = PL_reentrant_buffer->_gethostent_errno;
4725 STATUS_UNIX_SET(h_errno);
4729 if (GIMME != G_ARRAY) {
4730 PUSHs(sv = sv_newmortal());
4732 if (which == OP_GHBYNAME) {
4734 sv_setpvn(sv, hent->h_addr, hent->h_length);
4737 sv_setpv(sv, (char*)hent->h_name);
4743 mPUSHs(newSVpv((char*)hent->h_name, 0));
4744 PUSHs(space_join_names_mortal(hent->h_aliases));
4745 mPUSHi(hent->h_addrtype);
4746 len = hent->h_length;
4749 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4750 mXPUSHp(*elem, len);
4754 mPUSHp(hent->h_addr, len);
4756 PUSHs(sv_mortalcopy(&PL_sv_no));
4761 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4767 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4769 I32 which = PL_op->op_type;
4771 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4772 struct netent *getnetbyaddr(Netdb_net_t, int);
4773 struct netent *getnetbyname(Netdb_name_t);
4774 struct netent *getnetent(void);
4776 struct netent *nent;
4778 if (which == OP_GNBYNAME){
4779 #ifdef HAS_GETNETBYNAME
4780 const char * const name = POPpbytex;
4781 nent = PerlSock_getnetbyname(name);
4783 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4786 else if (which == OP_GNBYADDR) {
4787 #ifdef HAS_GETNETBYADDR
4788 const int addrtype = POPi;
4789 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4790 nent = PerlSock_getnetbyaddr(addr, addrtype);
4792 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4796 #ifdef HAS_GETNETENT
4797 nent = PerlSock_getnetent();
4799 DIE(aTHX_ PL_no_sock_func, "getnetent");
4802 #ifdef HOST_NOT_FOUND
4804 #ifdef USE_REENTRANT_API
4805 # ifdef USE_GETNETENT_ERRNO
4806 h_errno = PL_reentrant_buffer->_getnetent_errno;
4809 STATUS_UNIX_SET(h_errno);
4814 if (GIMME != G_ARRAY) {
4815 PUSHs(sv = sv_newmortal());
4817 if (which == OP_GNBYNAME)
4818 sv_setiv(sv, (IV)nent->n_net);
4820 sv_setpv(sv, nent->n_name);
4826 mPUSHs(newSVpv(nent->n_name, 0));
4827 PUSHs(space_join_names_mortal(nent->n_aliases));
4828 mPUSHi(nent->n_addrtype);
4829 mPUSHi(nent->n_net);
4834 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4840 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4842 I32 which = PL_op->op_type;
4844 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4845 struct protoent *getprotobyname(Netdb_name_t);
4846 struct protoent *getprotobynumber(int);
4847 struct protoent *getprotoent(void);
4849 struct protoent *pent;
4851 if (which == OP_GPBYNAME) {
4852 #ifdef HAS_GETPROTOBYNAME
4853 const char* const name = POPpbytex;
4854 pent = PerlSock_getprotobyname(name);
4856 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4859 else if (which == OP_GPBYNUMBER) {
4860 #ifdef HAS_GETPROTOBYNUMBER
4861 const int number = POPi;
4862 pent = PerlSock_getprotobynumber(number);
4864 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4868 #ifdef HAS_GETPROTOENT
4869 pent = PerlSock_getprotoent();
4871 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4875 if (GIMME != G_ARRAY) {
4876 PUSHs(sv = sv_newmortal());
4878 if (which == OP_GPBYNAME)
4879 sv_setiv(sv, (IV)pent->p_proto);
4881 sv_setpv(sv, pent->p_name);
4887 mPUSHs(newSVpv(pent->p_name, 0));
4888 PUSHs(space_join_names_mortal(pent->p_aliases));
4889 mPUSHi(pent->p_proto);
4894 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4900 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4902 I32 which = PL_op->op_type;
4904 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4905 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4906 struct servent *getservbyport(int, Netdb_name_t);
4907 struct servent *getservent(void);
4909 struct servent *sent;
4911 if (which == OP_GSBYNAME) {
4912 #ifdef HAS_GETSERVBYNAME
4913 const char * const proto = POPpbytex;
4914 const char * const name = POPpbytex;
4915 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4917 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4920 else if (which == OP_GSBYPORT) {
4921 #ifdef HAS_GETSERVBYPORT
4922 const char * const proto = POPpbytex;
4923 unsigned short port = (unsigned short)POPu;
4924 port = PerlSock_htons(port);
4925 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4927 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4931 #ifdef HAS_GETSERVENT
4932 sent = PerlSock_getservent();
4934 DIE(aTHX_ PL_no_sock_func, "getservent");
4938 if (GIMME != G_ARRAY) {
4939 PUSHs(sv = sv_newmortal());
4941 if (which == OP_GSBYNAME) {
4942 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4945 sv_setpv(sv, sent->s_name);
4951 mPUSHs(newSVpv(sent->s_name, 0));
4952 PUSHs(space_join_names_mortal(sent->s_aliases));
4953 mPUSHi(PerlSock_ntohs(sent->s_port));
4954 mPUSHs(newSVpv(sent->s_proto, 0));
4959 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4966 const int stayopen = TOPi;
4967 switch(PL_op->op_type) {
4969 #ifdef HAS_SETHOSTENT
4970 PerlSock_sethostent(stayopen);
4972 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4975 #ifdef HAS_SETNETENT
4977 PerlSock_setnetent(stayopen);
4979 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4983 #ifdef HAS_SETPROTOENT
4984 PerlSock_setprotoent(stayopen);
4986 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4990 #ifdef HAS_SETSERVENT
4991 PerlSock_setservent(stayopen);
4993 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5003 switch(PL_op->op_type) {
5005 #ifdef HAS_ENDHOSTENT
5006 PerlSock_endhostent();
5008 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5012 #ifdef HAS_ENDNETENT
5013 PerlSock_endnetent();
5015 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5019 #ifdef HAS_ENDPROTOENT
5020 PerlSock_endprotoent();
5022 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5026 #ifdef HAS_ENDSERVENT
5027 PerlSock_endservent();
5029 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5033 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5036 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5040 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5043 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5047 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5050 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5054 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5057 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5069 I32 which = PL_op->op_type;
5071 struct passwd *pwent = NULL;
5073 * We currently support only the SysV getsp* shadow password interface.
5074 * The interface is declared in <shadow.h> and often one needs to link
5075 * with -lsecurity or some such.
5076 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5079 * AIX getpwnam() is clever enough to return the encrypted password
5080 * only if the caller (euid?) is root.
5082 * There are at least three other shadow password APIs. Many platforms
5083 * seem to contain more than one interface for accessing the shadow
5084 * password databases, possibly for compatibility reasons.
5085 * The getsp*() is by far he simplest one, the other two interfaces
5086 * are much more complicated, but also very similar to each other.
5091 * struct pr_passwd *getprpw*();
5092 * The password is in
5093 * char getprpw*(...).ufld.fd_encrypt[]
5094 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5099 * struct es_passwd *getespw*();
5100 * The password is in
5101 * char *(getespw*(...).ufld.fd_encrypt)
5102 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5105 * struct userpw *getuserpw();
5106 * The password is in
5107 * char *(getuserpw(...)).spw_upw_passwd
5108 * (but the de facto standard getpwnam() should work okay)
5110 * Mention I_PROT here so that Configure probes for it.
5112 * In HP-UX for getprpw*() the manual page claims that one should include
5113 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5114 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5115 * and pp_sys.c already includes <shadow.h> if there is such.
5117 * Note that <sys/security.h> is already probed for, but currently
5118 * it is only included in special cases.
5120 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5121 * be preferred interface, even though also the getprpw*() interface
5122 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5123 * One also needs to call set_auth_parameters() in main() before
5124 * doing anything else, whether one is using getespw*() or getprpw*().
5126 * Note that accessing the shadow databases can be magnitudes
5127 * slower than accessing the standard databases.
5132 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5133 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5134 * the pw_comment is left uninitialized. */
5135 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5141 const char* const name = POPpbytex;
5142 pwent = getpwnam(name);
5148 pwent = getpwuid(uid);
5152 # ifdef HAS_GETPWENT
5154 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5155 if (pwent) pwent = getpwnam(pwent->pw_name);
5158 DIE(aTHX_ PL_no_func, "getpwent");
5164 if (GIMME != G_ARRAY) {
5165 PUSHs(sv = sv_newmortal());
5167 if (which == OP_GPWNAM)
5168 sv_setuid(sv, pwent->pw_uid);
5170 sv_setpv(sv, pwent->pw_name);
5176 mPUSHs(newSVpv(pwent->pw_name, 0));
5180 /* If we have getspnam(), we try to dig up the shadow
5181 * password. If we are underprivileged, the shadow
5182 * interface will set the errno to EACCES or similar,
5183 * and return a null pointer. If this happens, we will
5184 * use the dummy password (usually "*" or "x") from the
5185 * standard password database.
5187 * In theory we could skip the shadow call completely
5188 * if euid != 0 but in practice we cannot know which
5189 * security measures are guarding the shadow databases
5190 * on a random platform.
5192 * Resist the urge to use additional shadow interfaces.
5193 * Divert the urge to writing an extension instead.
5196 /* Some AIX setups falsely(?) detect some getspnam(), which
5197 * has a different API than the Solaris/IRIX one. */
5198 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5201 const struct spwd * const spwent = getspnam(pwent->pw_name);
5202 /* Save and restore errno so that
5203 * underprivileged attempts seem
5204 * to have never made the unsuccessful
5205 * attempt to retrieve the shadow password. */
5207 if (spwent && spwent->sp_pwdp)
5208 sv_setpv(sv, spwent->sp_pwdp);
5212 if (!SvPOK(sv)) /* Use the standard password, then. */
5213 sv_setpv(sv, pwent->pw_passwd);
5216 # ifndef INCOMPLETE_TAINTS
5217 /* passwd is tainted because user himself can diddle with it.
5218 * admittedly not much and in a very limited way, but nevertheless. */
5222 sv_setuid(PUSHmortal, pwent->pw_uid);
5223 sv_setgid(PUSHmortal, pwent->pw_gid);
5225 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5226 * because of the poor interface of the Perl getpw*(),
5227 * not because there's some standard/convention saying so.
5228 * A better interface would have been to return a hash,
5229 * but we are accursed by our history, alas. --jhi. */
5231 mPUSHi(pwent->pw_change);
5234 mPUSHi(pwent->pw_quota);
5237 mPUSHs(newSVpv(pwent->pw_age, 0));
5239 /* I think that you can never get this compiled, but just in case. */
5240 PUSHs(sv_mortalcopy(&PL_sv_no));
5245 /* pw_class and pw_comment are mutually exclusive--.
5246 * see the above note for pw_change, pw_quota, and pw_age. */
5248 mPUSHs(newSVpv(pwent->pw_class, 0));
5251 mPUSHs(newSVpv(pwent->pw_comment, 0));
5253 /* I think that you can never get this compiled, but just in case. */
5254 PUSHs(sv_mortalcopy(&PL_sv_no));
5259 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5261 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5263 # ifndef INCOMPLETE_TAINTS
5264 /* pw_gecos is tainted because user himself can diddle with it. */
5268 mPUSHs(newSVpv(pwent->pw_dir, 0));
5270 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5271 # ifndef INCOMPLETE_TAINTS
5272 /* pw_shell is tainted because user himself can diddle with it. */
5277 mPUSHi(pwent->pw_expire);
5282 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5290 const I32 which = PL_op->op_type;
5291 const struct group *grent;
5293 if (which == OP_GGRNAM) {
5294 const char* const name = POPpbytex;
5295 grent = (const struct group *)getgrnam(name);
5297 else if (which == OP_GGRGID) {
5298 const Gid_t gid = POPi;
5299 grent = (const struct group *)getgrgid(gid);
5303 grent = (struct group *)getgrent();
5305 DIE(aTHX_ PL_no_func, "getgrent");
5309 if (GIMME != G_ARRAY) {
5310 SV * const sv = sv_newmortal();
5314 if (which == OP_GGRNAM)
5315 sv_setgid(sv, grent->gr_gid);
5317 sv_setpv(sv, grent->gr_name);
5323 mPUSHs(newSVpv(grent->gr_name, 0));
5326 mPUSHs(newSVpv(grent->gr_passwd, 0));
5328 PUSHs(sv_mortalcopy(&PL_sv_no));
5331 sv_setgid(PUSHmortal, grent->gr_gid);
5333 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5334 /* In UNICOS/mk (_CRAYMPP) the multithreading
5335 * versions (getgrnam_r, getgrgid_r)
5336 * seem to return an illegal pointer
5337 * as the group members list, gr_mem.
5338 * getgrent() doesn't even have a _r version
5339 * but the gr_mem is poisonous anyway.
5340 * So yes, you cannot get the list of group
5341 * members if building multithreaded in UNICOS/mk. */
5342 PUSHs(space_join_names_mortal(grent->gr_mem));
5348 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5358 if (!(tmps = PerlProc_getlogin()))
5360 sv_setpv_mg(TARG, tmps);
5364 DIE(aTHX_ PL_no_func, "getlogin");
5368 /* Miscellaneous. */
5373 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5374 I32 items = SP - MARK;
5375 unsigned long a[20];
5380 while (++MARK <= SP) {
5381 if (SvTAINTED(*MARK)) {
5387 TAINT_PROPER("syscall");
5390 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5391 * or where sizeof(long) != sizeof(char*). But such machines will
5392 * not likely have syscall implemented either, so who cares?
5394 while (++MARK <= SP) {
5395 if (SvNIOK(*MARK) || !i)
5396 a[i++] = SvIV(*MARK);
5397 else if (*MARK == &PL_sv_undef)
5400 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5406 DIE(aTHX_ "Too many args to syscall");
5408 DIE(aTHX_ "Too few args to syscall");
5410 retval = syscall(a[0]);
5413 retval = syscall(a[0],a[1]);
5416 retval = syscall(a[0],a[1],a[2]);
5419 retval = syscall(a[0],a[1],a[2],a[3]);
5422 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5425 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5428 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5431 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5438 DIE(aTHX_ PL_no_func, "syscall");
5442 #ifdef FCNTL_EMULATE_FLOCK
5444 /* XXX Emulate flock() with fcntl().
5445 What's really needed is a good file locking module.
5449 fcntl_emulate_flock(int fd, int operation)
5454 switch (operation & ~LOCK_NB) {
5456 flock.l_type = F_RDLCK;
5459 flock.l_type = F_WRLCK;
5462 flock.l_type = F_UNLCK;
5468 flock.l_whence = SEEK_SET;
5469 flock.l_start = flock.l_len = (Off_t)0;
5471 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5472 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5473 errno = EWOULDBLOCK;
5477 #endif /* FCNTL_EMULATE_FLOCK */
5479 #ifdef LOCKF_EMULATE_FLOCK
5481 /* XXX Emulate flock() with lockf(). This is just to increase
5482 portability of scripts. The calls are not completely
5483 interchangeable. What's really needed is a good file
5487 /* The lockf() constants might have been defined in <unistd.h>.
5488 Unfortunately, <unistd.h> causes troubles on some mixed
5489 (BSD/POSIX) systems, such as SunOS 4.1.3.
5491 Further, the lockf() constants aren't POSIX, so they might not be
5492 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5493 just stick in the SVID values and be done with it. Sigh.
5497 # define F_ULOCK 0 /* Unlock a previously locked region */
5500 # define F_LOCK 1 /* Lock a region for exclusive use */
5503 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5506 # define F_TEST 3 /* Test a region for other processes locks */
5510 lockf_emulate_flock(int fd, int operation)
5516 /* flock locks entire file so for lockf we need to do the same */
5517 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5518 if (pos > 0) /* is seekable and needs to be repositioned */
5519 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5520 pos = -1; /* seek failed, so don't seek back afterwards */
5523 switch (operation) {
5525 /* LOCK_SH - get a shared lock */
5527 /* LOCK_EX - get an exclusive lock */
5529 i = lockf (fd, F_LOCK, 0);
5532 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5533 case LOCK_SH|LOCK_NB:
5534 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5535 case LOCK_EX|LOCK_NB:
5536 i = lockf (fd, F_TLOCK, 0);
5538 if ((errno == EAGAIN) || (errno == EACCES))
5539 errno = EWOULDBLOCK;
5542 /* LOCK_UN - unlock (non-blocking is a no-op) */
5544 case LOCK_UN|LOCK_NB:
5545 i = lockf (fd, F_ULOCK, 0);
5548 /* Default - can't decipher operation */
5555 if (pos > 0) /* need to restore position of the handle */
5556 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5561 #endif /* LOCKF_EMULATE_FLOCK */
5565 * c-indentation-style: bsd
5567 * indent-tabs-mode: nil
5570 * ex: set ts=8 sts=4 sw=4 et: