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 /* make a copy of the pattern if it is gmagical, to ensure that magic
363 * is called once and only once */
364 if (SvGMAGICAL(TOPm1s)) TOPm1s = sv_2mortal(newSVsv(TOPm1s));
366 tryAMAGICunTARGETlist(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL));
368 if (PL_op->op_flags & OPf_SPECIAL) {
369 /* call Perl-level glob function instead. Stack args are:
370 * MARK, wildcard, csh_glob context index
371 * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
375 /* stack args are: wildcard, gv(_GEN_n) */
383 /* Note that we only ever get here if File::Glob fails to load
384 * without at the same time croaking, for some reason, or if
385 * perl was built with PERL_EXTERNAL_GLOB */
387 ENTER_with_name("glob");
392 * The external globbing program may use things we can't control,
393 * so for security reasons we must assume the worst.
396 taint_proper(PL_no_security, "glob");
400 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
401 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
403 SAVESPTR(PL_rs); /* This is not permanent, either. */
404 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
407 *SvPVX(PL_rs) = '\n';
411 result = do_readline();
412 LEAVE_with_name("glob");
419 PL_last_in_gv = cGVOP_gv;
420 return do_readline();
430 do_join(TARG, &PL_sv_no, MARK, SP);
434 else if (SP == MARK) {
441 if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
444 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
445 /* well-formed exception supplied */
448 SV * const errsv = ERRSV;
451 if (SvGMAGICAL(errsv)) {
452 exsv = sv_newmortal();
453 sv_setsv_nomg(exsv, errsv);
457 else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) {
458 exsv = sv_newmortal();
459 sv_setsv_nomg(exsv, errsv);
460 sv_catpvs(exsv, "\t...caught");
463 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
466 if (SvROK(exsv) && !PL_warnhook)
467 Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
478 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
480 if (SP - MARK != 1) {
482 do_join(TARG, &PL_sv_no, MARK, SP);
490 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
491 /* well-formed exception supplied */
494 SV * const errsv = ERRSV;
497 if (sv_isobject(exsv)) {
498 HV * const stash = SvSTASH(SvRV(exsv));
499 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
501 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
502 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
509 call_sv(MUTABLE_SV(GvCV(gv)),
510 G_SCALAR|G_EVAL|G_KEEPERR);
511 exsv = sv_mortalcopy(*PL_stack_sp--);
515 else if (SvPV_const(errsv, len), len) {
516 exsv = sv_mortalcopy(errsv);
517 sv_catpvs(exsv, "\t...propagated");
520 exsv = newSVpvs_flags("Died", SVs_TEMP);
529 Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv,
530 const MAGIC *const mg, const U32 flags, U32 argc, ...)
535 PERL_ARGS_ASSERT_TIED_METHOD;
537 /* Ensure that our flag bits do not overlap. */
538 assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
539 assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
540 assert((TIED_METHOD_SAY & G_WANT) == 0);
542 PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
543 PUSHSTACKi(PERLSI_MAGIC);
544 EXTEND(SP, argc+1); /* object + args */
546 PUSHs(SvTIED_obj(sv, mg));
547 if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
548 Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
552 const U32 mortalize_not_needed
553 = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
555 va_start(args, argc);
557 SV *const arg = va_arg(args, SV *);
558 if(mortalize_not_needed)
567 ENTER_with_name("call_tied_method");
568 if (flags & TIED_METHOD_SAY) {
569 /* local $\ = "\n" */
570 SAVEGENERICSV(PL_ors_sv);
571 PL_ors_sv = newSVpvs("\n");
573 ret_args = call_method(methname, flags & G_WANT);
578 if (ret_args) { /* copy results back to original stack */
579 EXTEND(sp, ret_args);
580 Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
584 LEAVE_with_name("call_tied_method");
588 #define tied_method0(a,b,c,d) \
589 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
590 #define tied_method1(a,b,c,d,e) \
591 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
592 #define tied_method2(a,b,c,d,e,f) \
593 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
606 GV * const gv = MUTABLE_GV(*++MARK);
608 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
609 DIE(aTHX_ PL_no_usym, "filehandle");
611 if ((io = GvIOp(gv))) {
613 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
616 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
617 "Opening dirhandle %"HEKf" also as a file",
618 HEKfARG(GvENAME_HEK(gv)));
620 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
622 /* Method's args are same as ours ... */
623 /* ... except handle is replaced by the object */
624 return Perl_tied_method(aTHX_ "OPEN", mark - 1, MUTABLE_SV(io), mg,
625 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
637 tmps = SvPV_const(sv, len);
638 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
641 PUSHi( (I32)PL_forkprocess );
642 else if (PL_forkprocess == 0) /* we are a new child */
653 MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
659 IO * const io = GvIO(gv);
661 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
663 return tied_method0("CLOSE", SP, MUTABLE_SV(io), mg);
667 PUSHs(boolSV(do_close(gv, TRUE)));
680 GV * const wgv = MUTABLE_GV(POPs);
681 GV * const rgv = MUTABLE_GV(POPs);
686 if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
687 DIE(aTHX_ PL_no_usym, "filehandle");
692 do_close(rgv, FALSE);
694 do_close(wgv, FALSE);
696 if (PerlProc_pipe(fd) < 0)
699 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
700 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
701 IoOFP(rstio) = IoIFP(rstio);
702 IoIFP(wstio) = IoOFP(wstio);
703 IoTYPE(rstio) = IoTYPE_RDONLY;
704 IoTYPE(wstio) = IoTYPE_WRONLY;
706 if (!IoIFP(rstio) || !IoOFP(wstio)) {
708 PerlIO_close(IoIFP(rstio));
710 PerlLIO_close(fd[0]);
712 PerlIO_close(IoOFP(wstio));
714 PerlLIO_close(fd[1]);
717 #if defined(HAS_FCNTL) && defined(F_SETFD)
718 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
719 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
726 DIE(aTHX_ PL_no_func, "pipe");
740 gv = MUTABLE_GV(POPs);
744 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
746 return tied_method0("FILENO", SP, MUTABLE_SV(io), mg);
749 if (!io || !(fp = IoIFP(io))) {
750 /* Can't do this because people seem to do things like
751 defined(fileno($foo)) to check whether $foo is a valid fh.
758 PUSHi(PerlIO_fileno(fp));
770 if (MAXARG < 1 || (!TOPs && !POPs)) {
771 anum = PerlLIO_umask(022);
772 /* setting it to 022 between the two calls to umask avoids
773 * to have a window where the umask is set to 0 -- meaning
774 * that another thread could create world-writeable files. */
776 (void)PerlLIO_umask(anum);
779 anum = PerlLIO_umask(POPi);
780 TAINT_PROPER("umask");
783 /* Only DIE if trying to restrict permissions on "user" (self).
784 * Otherwise it's harmless and more useful to just return undef
785 * since 'group' and 'other' concepts probably don't exist here. */
786 if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
787 DIE(aTHX_ "umask not implemented");
788 XPUSHs(&PL_sv_undef);
807 gv = MUTABLE_GV(POPs);
811 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
813 /* This takes advantage of the implementation of the varargs
814 function, which I don't think that the optimiser will be able to
815 figure out. Although, as it's a static function, in theory it
817 return Perl_tied_method(aTHX_ "BINMODE", SP, MUTABLE_SV(io), mg,
818 G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
819 discp ? 1 : 0, discp);
823 if (!io || !(fp = IoIFP(io))) {
825 SETERRNO(EBADF,RMS_IFI);
832 const char *d = NULL;
835 d = SvPV_const(discp, len);
836 mode = mode_from_discipline(d, len);
837 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
838 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
839 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
860 const I32 markoff = MARK - PL_stack_base;
861 const char *methname;
862 int how = PERL_MAGIC_tied;
866 switch(SvTYPE(varsv)) {
870 methname = "TIEHASH";
871 if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
872 HvLAZYDEL_off(varsv);
873 hv_free_ent((HV *)varsv, entry);
875 HvEITER_set(MUTABLE_HV(varsv), 0);
879 methname = "TIEARRAY";
880 if (!AvREAL(varsv)) {
882 Perl_croak(aTHX_ "Cannot tie unreifiable array");
883 av_clear((AV *)varsv);
890 if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
891 methname = "TIEHANDLE";
892 how = PERL_MAGIC_tiedscalar;
893 /* For tied filehandles, we apply tiedscalar magic to the IO
894 slot of the GP rather than the GV itself. AMS 20010812 */
896 GvIOp(varsv) = newIO();
897 varsv = MUTABLE_SV(GvIOp(varsv));
902 methname = "TIESCALAR";
903 how = PERL_MAGIC_tiedscalar;
907 if (sv_isobject(*MARK)) { /* Calls GET magic. */
908 ENTER_with_name("call_TIE");
909 PUSHSTACKi(PERLSI_MAGIC);
911 EXTEND(SP,(I32)items);
915 call_method(methname, G_SCALAR);
918 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
919 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
920 * wrong error message, and worse case, supreme action at a distance.
921 * (Sorry obfuscation writers. You're not going to be given this one.)
923 stash = gv_stashsv(*MARK, 0);
924 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
925 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
926 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
928 ENTER_with_name("call_TIE");
929 PUSHSTACKi(PERLSI_MAGIC);
931 EXTEND(SP,(I32)items);
935 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
941 if (sv_isobject(sv)) {
942 sv_unmagic(varsv, how);
943 /* Croak if a self-tie on an aggregate is attempted. */
944 if (varsv == SvRV(sv) &&
945 (SvTYPE(varsv) == SVt_PVAV ||
946 SvTYPE(varsv) == SVt_PVHV))
948 "Self-ties of arrays and hashes are not supported");
949 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
951 LEAVE_with_name("call_TIE");
952 SP = PL_stack_base + markoff;
962 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
963 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
965 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
968 if ((mg = SvTIED_mg(sv, how))) {
969 SV * const obj = SvRV(SvTIED_obj(sv, mg));
971 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
973 if (gv && isGV(gv) && (cv = GvCV(gv))) {
975 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
976 mXPUSHi(SvREFCNT(obj) - 1);
978 ENTER_with_name("call_UNTIE");
979 call_sv(MUTABLE_SV(cv), G_VOID);
980 LEAVE_with_name("call_UNTIE");
983 else if (mg && SvREFCNT(obj) > 1) {
984 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
985 "untie attempted while %"UVuf" inner references still exist",
986 (UV)SvREFCNT(obj) - 1 ) ;
990 sv_unmagic(sv, how) ;
1000 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1001 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1003 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1006 if ((mg = SvTIED_mg(sv, how))) {
1007 PUSHs(SvTIED_obj(sv, mg));
1020 HV * const hv = MUTABLE_HV(POPs);
1021 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1022 stash = gv_stashsv(sv, 0);
1023 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1025 require_pv("AnyDBM_File.pm");
1027 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1028 DIE(aTHX_ "No dbm on this machine");
1038 mPUSHu(O_RDWR|O_CREAT);
1042 if (!SvOK(right)) right = &PL_sv_no;
1046 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1049 if (!sv_isobject(TOPs)) {
1057 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1061 if (sv_isobject(TOPs)) {
1062 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1063 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1080 struct timeval timebuf;
1081 struct timeval *tbuf = &timebuf;
1084 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1089 # if BYTEORDER & 0xf0000
1090 # define ORDERBYTE (0x88888888 - BYTEORDER)
1092 # define ORDERBYTE (0x4444 - BYTEORDER)
1098 for (i = 1; i <= 3; i++) {
1099 SV * const sv = SP[i];
1104 sv_force_normal_flags(sv, 0);
1105 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1106 Perl_croak_no_modify();
1109 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1110 "Non-string passed as bitmask");
1111 SvPV_force_nomg_nolen(sv); /* force string conversion */
1118 /* little endians can use vecs directly */
1119 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1126 masksize = NFDBITS / NBBY;
1128 masksize = sizeof(long); /* documented int, everyone seems to use long */
1130 Zero(&fd_sets[0], 4, char*);
1133 # if SELECT_MIN_BITS == 1
1134 growsize = sizeof(fd_set);
1136 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1137 # undef SELECT_MIN_BITS
1138 # define SELECT_MIN_BITS __FD_SETSIZE
1140 /* If SELECT_MIN_BITS is greater than one we most probably will want
1141 * to align the sizes with SELECT_MIN_BITS/8 because for example
1142 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1143 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1144 * on (sets/tests/clears bits) is 32 bits. */
1145 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1153 timebuf.tv_sec = (long)value;
1154 value -= (NV)timebuf.tv_sec;
1155 timebuf.tv_usec = (long)(value * 1000000.0);
1160 for (i = 1; i <= 3; i++) {
1162 if (!SvOK(sv) || SvCUR(sv) == 0) {
1169 Sv_Grow(sv, growsize);
1173 while (++j <= growsize) {
1177 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1179 Newx(fd_sets[i], growsize, char);
1180 for (offset = 0; offset < growsize; offset += masksize) {
1181 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1182 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1185 fd_sets[i] = SvPVX(sv);
1189 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1190 /* Can't make just the (void*) conditional because that would be
1191 * cpp #if within cpp macro, and not all compilers like that. */
1192 nfound = PerlSock_select(
1194 (Select_fd_set_t) fd_sets[1],
1195 (Select_fd_set_t) fd_sets[2],
1196 (Select_fd_set_t) fd_sets[3],
1197 (void*) tbuf); /* Workaround for compiler bug. */
1199 nfound = PerlSock_select(
1201 (Select_fd_set_t) fd_sets[1],
1202 (Select_fd_set_t) fd_sets[2],
1203 (Select_fd_set_t) fd_sets[3],
1206 for (i = 1; i <= 3; i++) {
1209 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1211 for (offset = 0; offset < growsize; offset += masksize) {
1212 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1213 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1215 Safefree(fd_sets[i]);
1222 if (GIMME == G_ARRAY && tbuf) {
1223 value = (NV)(timebuf.tv_sec) +
1224 (NV)(timebuf.tv_usec) / 1000000.0;
1229 DIE(aTHX_ "select not implemented");
1234 =for apidoc setdefout
1236 Sets PL_defoutgv, the default file handle for output, to the passed in
1237 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1238 count of the passed in typeglob is increased by one, and the reference count
1239 of the typeglob that PL_defoutgv points to is decreased by one.
1245 Perl_setdefout(pTHX_ GV *gv)
1248 PERL_ARGS_ASSERT_SETDEFOUT;
1249 SvREFCNT_inc_simple_void_NN(gv);
1250 SvREFCNT_dec(PL_defoutgv);
1258 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1259 GV * egv = GvEGVx(PL_defoutgv);
1264 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1265 gvp = hv && HvENAME(hv)
1266 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1268 if (gvp && *gvp == egv) {
1269 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1273 mXPUSHs(newRV(MUTABLE_SV(egv)));
1277 if (!GvIO(newdefout))
1278 gv_IOadd(newdefout);
1279 setdefout(newdefout);
1289 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1290 IO *const io = GvIO(gv);
1296 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1298 const U32 gimme = GIMME_V;
1299 Perl_tied_method(aTHX_ "GETC", SP, MUTABLE_SV(io), mg, gimme, 0);
1300 if (gimme == G_SCALAR) {
1302 SvSetMagicSV_nosteal(TARG, TOPs);
1307 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1308 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1310 SETERRNO(EBADF,RMS_IFI);
1314 sv_setpvs(TARG, " ");
1315 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1316 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1317 /* Find out how many bytes the char needs */
1318 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1321 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1322 SvCUR_set(TARG,1+len);
1331 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1335 const I32 gimme = GIMME_V;
1337 PERL_ARGS_ASSERT_DOFORM;
1339 if (cv && CvCLONE(cv))
1340 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1345 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1346 PUSHFORMAT(cx, retop);
1347 if (CvDEPTH(cv) >= 2) {
1348 PERL_STACK_OVERFLOW_CHECK();
1349 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1352 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1354 setdefout(gv); /* locally select filehandle so $% et al work */
1373 gv = MUTABLE_GV(POPs);
1390 tmpsv = sv_newmortal();
1391 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1392 DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
1394 IoFLAGS(io) &= ~IOf_DIDTOP;
1395 RETURNOP(doform(cv,gv,PL_op->op_next));
1401 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1402 IO * const io = GvIOp(gv);
1410 if (!io || !(ofp = IoOFP(io)))
1413 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1414 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1416 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1417 PL_formtarget != PL_toptarget)
1421 if (!IoTOP_GV(io)) {
1424 if (!IoTOP_NAME(io)) {
1426 if (!IoFMT_NAME(io))
1427 IoFMT_NAME(io) = savepv(GvNAME(gv));
1428 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1429 HEKfARG(GvNAME_HEK(gv))));
1430 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1431 if ((topgv && GvFORM(topgv)) ||
1432 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1433 IoTOP_NAME(io) = savesvpv(topname);
1435 IoTOP_NAME(io) = savepvs("top");
1437 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1438 if (!topgv || !GvFORM(topgv)) {
1439 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1442 IoTOP_GV(io) = topgv;
1444 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1445 I32 lines = IoLINES_LEFT(io);
1446 const char *s = SvPVX_const(PL_formtarget);
1447 if (lines <= 0) /* Yow, header didn't even fit!!! */
1449 while (lines-- > 0) {
1450 s = strchr(s, '\n');
1456 const STRLEN save = SvCUR(PL_formtarget);
1457 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1458 do_print(PL_formtarget, ofp);
1459 SvCUR_set(PL_formtarget, save);
1460 sv_chop(PL_formtarget, s);
1461 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1464 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1465 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1466 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1468 PL_formtarget = PL_toptarget;
1469 IoFLAGS(io) |= IOf_DIDTOP;
1472 DIE(aTHX_ "bad top format reference");
1475 SV * const sv = sv_newmortal();
1476 gv_efullname4(sv, fgv, NULL, FALSE);
1477 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1479 return doform(cv, gv, PL_op);
1483 POPBLOCK(cx,PL_curpm);
1485 retop = cx->blk_sub.retop;
1486 SP = newsp; /* ignore retval of formline */
1489 if (!io || !(fp = IoOFP(io))) {
1490 if (io && IoIFP(io))
1491 report_wrongway_fh(gv, '<');
1497 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1498 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1500 if (!do_print(PL_formtarget, fp))
1503 FmLINES(PL_formtarget) = 0;
1504 SvCUR_set(PL_formtarget, 0);
1505 *SvEND(PL_formtarget) = '\0';
1506 if (IoFLAGS(io) & IOf_FLUSH)
1507 (void)PerlIO_flush(fp);
1511 PL_formtarget = PL_bodytarget;
1512 PERL_UNUSED_VAR(gimme);
1518 dVAR; dSP; dMARK; dORIGMARK;
1522 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1523 IO *const io = GvIO(gv);
1525 /* Treat empty list as "" */
1526 if (MARK == SP) XPUSHs(&PL_sv_no);
1529 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1531 if (MARK == ORIGMARK) {
1534 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1537 return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io),
1539 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1546 SETERRNO(EBADF,RMS_IFI);
1549 else if (!(fp = IoOFP(io))) {
1551 report_wrongway_fh(gv, '<');
1552 else if (ckWARN(WARN_CLOSED))
1554 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1558 SV *sv = sv_newmortal();
1559 do_sprintf(sv, SP - MARK, MARK + 1);
1560 if (!do_print(sv, fp))
1563 if (IoFLAGS(io) & IOf_FLUSH)
1564 if (PerlIO_flush(fp) == EOF)
1573 PUSHs(&PL_sv_undef);
1581 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1582 const int mode = POPi;
1583 SV * const sv = POPs;
1584 GV * const gv = MUTABLE_GV(POPs);
1587 /* Need TIEHANDLE method ? */
1588 const char * const tmps = SvPV_const(sv, len);
1589 /* FIXME? do_open should do const */
1590 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1591 IoLINES(GvIOp(gv)) = 0;
1595 PUSHs(&PL_sv_undef);
1602 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1616 bool charstart = FALSE;
1617 STRLEN charskip = 0;
1620 GV * const gv = MUTABLE_GV(*++MARK);
1621 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1622 && gv && (io = GvIO(gv)) )
1624 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1626 return Perl_tied_method(aTHX_ "READ", mark - 1, MUTABLE_SV(io), mg,
1627 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1636 sv_setpvs(bufsv, "");
1637 length = SvIVx(*++MARK);
1639 DIE(aTHX_ "Negative length");
1642 offset = SvIVx(*++MARK);
1646 if (!io || !IoIFP(io)) {
1648 SETERRNO(EBADF,RMS_IFI);
1651 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1652 buffer = SvPVutf8_force(bufsv, blen);
1653 /* UTF-8 may not have been set if they are all low bytes */
1658 buffer = SvPV_force(bufsv, blen);
1659 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1661 if (DO_UTF8(bufsv)) {
1662 blen = sv_len_utf8_nomg(bufsv);
1671 if (PL_op->op_type == OP_RECV) {
1672 Sock_size_t bufsize;
1673 char namebuf[MAXPATHLEN];
1674 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1675 bufsize = sizeof (struct sockaddr_in);
1677 bufsize = sizeof namebuf;
1679 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1683 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1684 /* 'offset' means 'flags' here */
1685 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1686 (struct sockaddr *)namebuf, &bufsize);
1689 /* MSG_TRUNC can give oversized count; quietly lose it */
1692 SvCUR_set(bufsv, count);
1693 *SvEND(bufsv) = '\0';
1694 (void)SvPOK_only(bufsv);
1698 /* This should not be marked tainted if the fp is marked clean */
1699 if (!(IoFLAGS(io) & IOf_UNTAINT))
1700 SvTAINTED_on(bufsv);
1702 sv_setpvn(TARG, namebuf, bufsize);
1708 if (-offset > (SSize_t)blen)
1709 DIE(aTHX_ "Offset outside string");
1712 if (DO_UTF8(bufsv)) {
1713 /* convert offset-as-chars to offset-as-bytes */
1714 if (offset >= (SSize_t)blen)
1715 offset += SvCUR(bufsv) - blen;
1717 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1720 orig_size = SvCUR(bufsv);
1721 /* Allocating length + offset + 1 isn't perfect in the case of reading
1722 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1724 (should be 2 * length + offset + 1, or possibly something longer if
1725 PL_encoding is true) */
1726 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1727 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1728 Zero(buffer+orig_size, offset-orig_size, char);
1730 buffer = buffer + offset;
1732 read_target = bufsv;
1734 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1735 concatenate it to the current buffer. */
1737 /* Truncate the existing buffer to the start of where we will be
1739 SvCUR_set(bufsv, offset);
1741 read_target = sv_newmortal();
1742 SvUPGRADE(read_target, SVt_PV);
1743 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1746 if (PL_op->op_type == OP_SYSREAD) {
1747 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1748 if (IoTYPE(io) == IoTYPE_SOCKET) {
1749 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1755 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1760 #ifdef HAS_SOCKET__bad_code_maybe
1761 if (IoTYPE(io) == IoTYPE_SOCKET) {
1762 Sock_size_t bufsize;
1763 char namebuf[MAXPATHLEN];
1764 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1765 bufsize = sizeof (struct sockaddr_in);
1767 bufsize = sizeof namebuf;
1769 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1770 (struct sockaddr *)namebuf, &bufsize);
1775 count = PerlIO_read(IoIFP(io), buffer, length);
1776 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1777 if (count == 0 && PerlIO_error(IoIFP(io)))
1781 if (IoTYPE(io) == IoTYPE_WRONLY)
1782 report_wrongway_fh(gv, '>');
1785 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1786 *SvEND(read_target) = '\0';
1787 (void)SvPOK_only(read_target);
1788 if (fp_utf8 && !IN_BYTES) {
1789 /* Look at utf8 we got back and count the characters */
1790 const char *bend = buffer + count;
1791 while (buffer < bend) {
1793 skip = UTF8SKIP(buffer);
1796 if (buffer - charskip + skip > bend) {
1797 /* partial character - try for rest of it */
1798 length = skip - (bend-buffer);
1799 offset = bend - SvPVX_const(bufsv);
1811 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1812 provided amount read (count) was what was requested (length)
1814 if (got < wanted && count == length) {
1815 length = wanted - got;
1816 offset = bend - SvPVX_const(bufsv);
1819 /* return value is character count */
1823 else if (buffer_utf8) {
1824 /* Let svcatsv upgrade the bytes we read in to utf8.
1825 The buffer is a mortal so will be freed soon. */
1826 sv_catsv_nomg(bufsv, read_target);
1829 /* This should not be marked tainted if the fp is marked clean */
1830 if (!(IoFLAGS(io) & IOf_UNTAINT))
1831 SvTAINTED_on(bufsv);
1843 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1848 STRLEN orig_blen_bytes;
1849 const int op_type = PL_op->op_type;
1852 GV *const gv = MUTABLE_GV(*++MARK);
1853 IO *const io = GvIO(gv);
1855 if (op_type == OP_SYSWRITE && io) {
1856 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1858 if (MARK == SP - 1) {
1860 mXPUSHi(sv_len(sv));
1864 return Perl_tied_method(aTHX_ "WRITE", mark - 1, MUTABLE_SV(io), mg,
1865 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1875 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1877 if (io && IoIFP(io))
1878 report_wrongway_fh(gv, '<');
1881 SETERRNO(EBADF,RMS_IFI);
1885 /* Do this first to trigger any overloading. */
1886 buffer = SvPV_const(bufsv, blen);
1887 orig_blen_bytes = blen;
1888 doing_utf8 = DO_UTF8(bufsv);
1890 if (PerlIO_isutf8(IoIFP(io))) {
1891 if (!SvUTF8(bufsv)) {
1892 /* We don't modify the original scalar. */
1893 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1894 buffer = (char *) tmpbuf;
1898 else if (doing_utf8) {
1899 STRLEN tmplen = blen;
1900 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1903 buffer = (char *) tmpbuf;
1907 assert((char *)result == buffer);
1908 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1913 if (op_type == OP_SEND) {
1914 const int flags = SvIVx(*++MARK);
1917 char * const sockbuf = SvPVx(*++MARK, mlen);
1918 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1919 flags, (struct sockaddr *)sockbuf, mlen);
1923 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1929 Size_t length = 0; /* This length is in characters. */
1935 /* The SV is bytes, and we've had to upgrade it. */
1936 blen_chars = orig_blen_bytes;
1938 /* The SV really is UTF-8. */
1939 /* Don't call sv_len_utf8 on a magical or overloaded
1940 scalar, as we might get back a different result. */
1941 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
1948 length = blen_chars;
1950 #if Size_t_size > IVSIZE
1951 length = (Size_t)SvNVx(*++MARK);
1953 length = (Size_t)SvIVx(*++MARK);
1955 if ((SSize_t)length < 0) {
1957 DIE(aTHX_ "Negative length");
1962 offset = SvIVx(*++MARK);
1964 if (-offset > (IV)blen_chars) {
1966 DIE(aTHX_ "Offset outside string");
1968 offset += blen_chars;
1969 } else if (offset > (IV)blen_chars) {
1971 DIE(aTHX_ "Offset outside string");
1975 if (length > blen_chars - offset)
1976 length = blen_chars - offset;
1978 /* Here we convert length from characters to bytes. */
1979 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1980 /* Either we had to convert the SV, or the SV is magical, or
1981 the SV has overloading, in which case we can't or mustn't
1982 or mustn't call it again. */
1984 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1985 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1987 /* It's a real UTF-8 SV, and it's not going to change under
1988 us. Take advantage of any cache. */
1990 I32 len_I32 = length;
1992 /* Convert the start and end character positions to bytes.
1993 Remember that the second argument to sv_pos_u2b is relative
1995 sv_pos_u2b(bufsv, &start, &len_I32);
2002 buffer = buffer+offset;
2004 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2005 if (IoTYPE(io) == IoTYPE_SOCKET) {
2006 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
2012 /* See the note at doio.c:do_print about filesize limits. --jhi */
2013 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2022 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2025 #if Size_t_size > IVSIZE
2045 * in Perl 5.12 and later, the additional parameter is a bitmask:
2048 * 2 = eof() <- ARGV magic
2050 * I'll rely on the compiler's trace flow analysis to decide whether to
2051 * actually assign this out here, or punt it into the only block where it is
2052 * used. Doing it out here is DRY on the condition logic.
2057 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2063 if (PL_op->op_flags & OPf_SPECIAL) {
2064 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2068 gv = PL_last_in_gv; /* eof */
2076 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2077 return tied_method1("EOF", SP, MUTABLE_SV(io), mg, newSVuv(which));
2080 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2081 if (io && !IoIFP(io)) {
2082 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2084 IoFLAGS(io) &= ~IOf_START;
2085 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2087 sv_setpvs(GvSV(gv), "-");
2089 GvSV(gv) = newSVpvs("-");
2090 SvSETMAGIC(GvSV(gv));
2092 else if (!nextargv(gv))
2097 PUSHs(boolSV(do_eof(gv)));
2107 if (MAXARG != 0 && (TOPs || POPs))
2108 PL_last_in_gv = MUTABLE_GV(POPs);
2115 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2117 return tied_method0("TELL", SP, MUTABLE_SV(io), mg);
2122 SETERRNO(EBADF,RMS_IFI);
2127 #if LSEEKSIZE > IVSIZE
2128 PUSHn( do_tell(gv) );
2130 PUSHi( do_tell(gv) );
2138 const int whence = POPi;
2139 #if LSEEKSIZE > IVSIZE
2140 const Off_t offset = (Off_t)SvNVx(POPs);
2142 const Off_t offset = (Off_t)SvIVx(POPs);
2145 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2146 IO *const io = GvIO(gv);
2149 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2151 #if LSEEKSIZE > IVSIZE
2152 SV *const offset_sv = newSVnv((NV) offset);
2154 SV *const offset_sv = newSViv(offset);
2157 return tied_method2("SEEK", SP, MUTABLE_SV(io), mg, offset_sv,
2162 if (PL_op->op_type == OP_SEEK)
2163 PUSHs(boolSV(do_seek(gv, offset, whence)));
2165 const Off_t sought = do_sysseek(gv, offset, whence);
2167 PUSHs(&PL_sv_undef);
2169 SV* const sv = sought ?
2170 #if LSEEKSIZE > IVSIZE
2175 : newSVpvn(zero_but_true, ZBTLEN);
2186 /* There seems to be no consensus on the length type of truncate()
2187 * and ftruncate(), both off_t and size_t have supporters. In
2188 * general one would think that when using large files, off_t is
2189 * at least as wide as size_t, so using an off_t should be okay. */
2190 /* XXX Configure probe for the length type of *truncate() needed XXX */
2193 #if Off_t_size > IVSIZE
2198 /* Checking for length < 0 is problematic as the type might or
2199 * might not be signed: if it is not, clever compilers will moan. */
2200 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2203 SV * const sv = POPs;
2208 if (PL_op->op_flags & OPf_SPECIAL
2209 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2210 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2217 TAINT_PROPER("truncate");
2218 if (!(fp = IoIFP(io))) {
2224 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2226 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2232 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2233 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2234 goto do_ftruncate_io;
2237 const char * const name = SvPV_nomg_const_nolen(sv);
2238 TAINT_PROPER("truncate");
2240 if (truncate(name, len) < 0)
2244 const int tmpfd = PerlLIO_open(name, O_RDWR);
2249 if (my_chsize(tmpfd, len) < 0)
2251 PerlLIO_close(tmpfd);
2260 SETERRNO(EBADF,RMS_IFI);
2268 SV * const argsv = POPs;
2269 const unsigned int func = POPu;
2270 const int optype = PL_op->op_type;
2271 GV * const gv = MUTABLE_GV(POPs);
2272 IO * const io = gv ? GvIOn(gv) : NULL;
2276 if (!io || !argsv || !IoIFP(io)) {
2278 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2282 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2285 s = SvPV_force(argsv, len);
2286 need = IOCPARM_LEN(func);
2288 s = Sv_Grow(argsv, need + 1);
2289 SvCUR_set(argsv, need);
2292 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2295 retval = SvIV(argsv);
2296 s = INT2PTR(char*,retval); /* ouch */
2299 TAINT_PROPER(PL_op_desc[optype]);
2301 if (optype == OP_IOCTL)
2303 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2305 DIE(aTHX_ "ioctl is not implemented");
2309 DIE(aTHX_ "fcntl is not implemented");
2311 #if defined(OS2) && defined(__EMX__)
2312 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2314 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2318 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2320 if (s[SvCUR(argsv)] != 17)
2321 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2323 s[SvCUR(argsv)] = 0; /* put our null back */
2324 SvSETMAGIC(argsv); /* Assume it has changed */
2333 PUSHp(zero_but_true, ZBTLEN);
2344 const int argtype = POPi;
2345 GV * const gv = MUTABLE_GV(POPs);
2346 IO *const io = GvIO(gv);
2347 PerlIO *const fp = io ? IoIFP(io) : NULL;
2349 /* XXX Looks to me like io is always NULL at this point */
2351 (void)PerlIO_flush(fp);
2352 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2357 SETERRNO(EBADF,RMS_IFI);
2362 DIE(aTHX_ PL_no_func, "flock()");
2373 const int protocol = POPi;
2374 const int type = POPi;
2375 const int domain = POPi;
2376 GV * const gv = MUTABLE_GV(POPs);
2377 IO * const io = gv ? GvIOn(gv) : NULL;
2382 if (io && IoIFP(io))
2383 do_close(gv, FALSE);
2384 SETERRNO(EBADF,LIB_INVARG);
2389 do_close(gv, FALSE);
2391 TAINT_PROPER("socket");
2392 fd = PerlSock_socket(domain, type, protocol);
2395 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2396 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2397 IoTYPE(io) = IoTYPE_SOCKET;
2398 if (!IoIFP(io) || !IoOFP(io)) {
2399 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2400 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2401 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2404 #if defined(HAS_FCNTL) && defined(F_SETFD)
2405 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2414 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2416 const int protocol = POPi;
2417 const int type = POPi;
2418 const int domain = POPi;
2419 GV * const gv2 = MUTABLE_GV(POPs);
2420 GV * const gv1 = MUTABLE_GV(POPs);
2421 IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2422 IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2426 report_evil_fh(gv1);
2428 report_evil_fh(gv2);
2430 if (io1 && IoIFP(io1))
2431 do_close(gv1, FALSE);
2432 if (io2 && IoIFP(io2))
2433 do_close(gv2, FALSE);
2438 TAINT_PROPER("socketpair");
2439 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2441 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2442 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2443 IoTYPE(io1) = IoTYPE_SOCKET;
2444 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2445 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2446 IoTYPE(io2) = IoTYPE_SOCKET;
2447 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2448 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2449 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2450 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2451 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2452 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2453 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2456 #if defined(HAS_FCNTL) && defined(F_SETFD)
2457 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2458 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2463 DIE(aTHX_ PL_no_sock_func, "socketpair");
2472 SV * const addrsv = POPs;
2473 /* OK, so on what platform does bind modify addr? */
2475 GV * const gv = MUTABLE_GV(POPs);
2476 IO * const io = GvIOn(gv);
2478 const int op_type = PL_op->op_type;
2480 if (!io || !IoIFP(io))
2483 addr = SvPV_const(addrsv, len);
2484 TAINT_PROPER(PL_op_desc[op_type]);
2485 if ((op_type == OP_BIND
2486 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2487 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2495 SETERRNO(EBADF,SS_IVCHAN);
2502 const int backlog = POPi;
2503 GV * const gv = MUTABLE_GV(POPs);
2504 IO * const io = gv ? GvIOn(gv) : NULL;
2506 if (!io || !IoIFP(io))
2509 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2516 SETERRNO(EBADF,SS_IVCHAN);
2525 char namebuf[MAXPATHLEN];
2526 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2527 Sock_size_t len = sizeof (struct sockaddr_in);
2529 Sock_size_t len = sizeof namebuf;
2531 GV * const ggv = MUTABLE_GV(POPs);
2532 GV * const ngv = MUTABLE_GV(POPs);
2541 if (!gstio || !IoIFP(gstio))
2545 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2548 /* Some platforms indicate zero length when an AF_UNIX client is
2549 * not bound. Simulate a non-zero-length sockaddr structure in
2551 namebuf[0] = 0; /* sun_len */
2552 namebuf[1] = AF_UNIX; /* sun_family */
2560 do_close(ngv, FALSE);
2561 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2562 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2563 IoTYPE(nstio) = IoTYPE_SOCKET;
2564 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2565 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2566 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2567 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2570 #if defined(HAS_FCNTL) && defined(F_SETFD)
2571 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2574 #ifdef __SCO_VERSION__
2575 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2578 PUSHp(namebuf, len);
2582 report_evil_fh(ggv);
2583 SETERRNO(EBADF,SS_IVCHAN);
2593 const int how = POPi;
2594 GV * const gv = MUTABLE_GV(POPs);
2595 IO * const io = GvIOn(gv);
2597 if (!io || !IoIFP(io))
2600 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2605 SETERRNO(EBADF,SS_IVCHAN);
2612 const int optype = PL_op->op_type;
2613 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2614 const unsigned int optname = (unsigned int) POPi;
2615 const unsigned int lvl = (unsigned int) POPi;
2616 GV * const gv = MUTABLE_GV(POPs);
2617 IO * const io = GvIOn(gv);
2621 if (!io || !IoIFP(io))
2624 fd = PerlIO_fileno(IoIFP(io));
2628 (void)SvPOK_only(sv);
2632 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2639 #if defined(__SYMBIAN32__)
2640 # define SETSOCKOPT_OPTION_VALUE_T void *
2642 # define SETSOCKOPT_OPTION_VALUE_T const char *
2644 /* XXX TODO: We need to have a proper type (a Configure probe,
2645 * etc.) for what the C headers think of the third argument of
2646 * setsockopt(), the option_value read-only buffer: is it
2647 * a "char *", or a "void *", const or not. Some compilers
2648 * don't take kindly to e.g. assuming that "char *" implicitly
2649 * promotes to a "void *", or to explicitly promoting/demoting
2650 * consts to non/vice versa. The "const void *" is the SUS
2651 * definition, but that does not fly everywhere for the above
2653 SETSOCKOPT_OPTION_VALUE_T buf;
2657 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2661 aint = (int)SvIV(sv);
2662 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2665 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2675 SETERRNO(EBADF,SS_IVCHAN);
2684 const int optype = PL_op->op_type;
2685 GV * const gv = MUTABLE_GV(POPs);
2686 IO * const io = GvIOn(gv);
2691 if (!io || !IoIFP(io))
2694 sv = sv_2mortal(newSV(257));
2695 (void)SvPOK_only(sv);
2699 fd = PerlIO_fileno(IoIFP(io));
2701 case OP_GETSOCKNAME:
2702 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2705 case OP_GETPEERNAME:
2706 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2708 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2710 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";
2711 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2712 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2713 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2714 sizeof(u_short) + sizeof(struct in_addr))) {
2721 #ifdef BOGUS_GETNAME_RETURN
2722 /* Interactive Unix, getpeername() and getsockname()
2723 does not return valid namelen */
2724 if (len == BOGUS_GETNAME_RETURN)
2725 len = sizeof(struct sockaddr);
2734 SETERRNO(EBADF,SS_IVCHAN);
2753 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2754 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2755 if (PL_op->op_type == OP_LSTAT) {
2756 if (gv != PL_defgv) {
2757 do_fstat_warning_check:
2758 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2759 "lstat() on filehandle%s%"SVf,
2762 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2764 } else if (PL_laststype != OP_LSTAT)
2765 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2766 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2769 if (gv != PL_defgv) {
2773 PL_laststype = OP_STAT;
2774 PL_statgv = gv ? gv : (GV *)io;
2775 sv_setpvs(PL_statname, "");
2782 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2784 } else if (IoDIRP(io)) {
2786 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2789 PL_laststatval = -1;
2792 else PL_laststatval = -1;
2793 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2796 if (PL_laststatval < 0) {
2801 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2802 io = MUTABLE_IO(SvRV(sv));
2803 if (PL_op->op_type == OP_LSTAT)
2804 goto do_fstat_warning_check;
2805 goto do_fstat_have_io;
2808 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2809 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2811 PL_laststype = PL_op->op_type;
2812 if (PL_op->op_type == OP_LSTAT)
2813 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2815 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2816 if (PL_laststatval < 0) {
2817 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2818 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2824 if (gimme != G_ARRAY) {
2825 if (gimme != G_VOID)
2826 XPUSHs(boolSV(max));
2832 mPUSHi(PL_statcache.st_dev);
2833 #if ST_INO_SIZE > IVSIZE
2834 mPUSHn(PL_statcache.st_ino);
2836 # if ST_INO_SIGN <= 0
2837 mPUSHi(PL_statcache.st_ino);
2839 mPUSHu(PL_statcache.st_ino);
2842 mPUSHu(PL_statcache.st_mode);
2843 mPUSHu(PL_statcache.st_nlink);
2844 #if Uid_t_size > IVSIZE
2845 mPUSHn(PL_statcache.st_uid);
2847 # if Uid_t_sign <= 0
2848 mPUSHi(PL_statcache.st_uid);
2850 mPUSHu(PL_statcache.st_uid);
2853 #if Gid_t_size > IVSIZE
2854 mPUSHn(PL_statcache.st_gid);
2856 # if Gid_t_sign <= 0
2857 mPUSHi(PL_statcache.st_gid);
2859 mPUSHu(PL_statcache.st_gid);
2862 #ifdef USE_STAT_RDEV
2863 mPUSHi(PL_statcache.st_rdev);
2865 PUSHs(newSVpvs_flags("", SVs_TEMP));
2867 #if Off_t_size > IVSIZE
2868 mPUSHn(PL_statcache.st_size);
2870 mPUSHi(PL_statcache.st_size);
2873 mPUSHn(PL_statcache.st_atime);
2874 mPUSHn(PL_statcache.st_mtime);
2875 mPUSHn(PL_statcache.st_ctime);
2877 mPUSHi(PL_statcache.st_atime);
2878 mPUSHi(PL_statcache.st_mtime);
2879 mPUSHi(PL_statcache.st_ctime);
2881 #ifdef USE_STAT_BLOCKS
2882 mPUSHu(PL_statcache.st_blksize);
2883 mPUSHu(PL_statcache.st_blocks);
2885 PUSHs(newSVpvs_flags("", SVs_TEMP));
2886 PUSHs(newSVpvs_flags("", SVs_TEMP));
2892 /* All filetest ops avoid manipulating the perl stack pointer in their main
2893 bodies (since commit d2c4d2d1e22d3125), and return using either
2894 S_ft_return_false() or S_ft_return_true(). These two helper functions are
2895 the only two which manipulate the perl stack. To ensure that no stack
2896 manipulation macros are used, the filetest ops avoid defining a local copy
2897 of the stack pointer with dSP. */
2899 /* If the next filetest is stacked up with this one
2900 (PL_op->op_private & OPpFT_STACKING), we leave
2901 the original argument on the stack for success,
2902 and skip the stacked operators on failure.
2903 The next few macros/functions take care of this.
2907 S_ft_return_false(pTHX_ SV *ret) {
2911 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
2915 if (PL_op->op_private & OPpFT_STACKING) {
2916 while (OP_IS_FILETEST(next->op_type)
2917 && next->op_private & OPpFT_STACKED)
2918 next = next->op_next;
2923 PERL_STATIC_INLINE OP *
2924 S_ft_return_true(pTHX_ SV *ret) {
2926 if (PL_op->op_flags & OPf_REF)
2927 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
2928 else if (!(PL_op->op_private & OPpFT_STACKING))
2934 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
2935 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
2936 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
2938 #define tryAMAGICftest_MG(chr) STMT_START { \
2939 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
2940 && PL_op->op_flags & OPf_KIDS) { \
2941 OP *next = S_try_amagic_ftest(aTHX_ chr); \
2942 if (next) return next; \
2947 S_try_amagic_ftest(pTHX_ char chr) {
2949 SV *const arg = *PL_stack_sp;
2952 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
2956 const char tmpchr = chr;
2957 SV * const tmpsv = amagic_call(arg,
2958 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2959 ftest_amg, AMGf_unary);
2964 return SvTRUE(tmpsv)
2965 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
2975 /* Not const, because things tweak this below. Not bool, because there's
2976 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2977 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2978 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2979 /* Giving some sort of initial value silences compilers. */
2981 int access_mode = R_OK;
2983 int access_mode = 0;
2986 /* access_mode is never used, but leaving use_access in makes the
2987 conditional compiling below much clearer. */
2990 Mode_t stat_mode = S_IRUSR;
2992 bool effective = FALSE;
2995 switch (PL_op->op_type) {
2996 case OP_FTRREAD: opchar = 'R'; break;
2997 case OP_FTRWRITE: opchar = 'W'; break;
2998 case OP_FTREXEC: opchar = 'X'; break;
2999 case OP_FTEREAD: opchar = 'r'; break;
3000 case OP_FTEWRITE: opchar = 'w'; break;
3001 case OP_FTEEXEC: opchar = 'x'; break;
3003 tryAMAGICftest_MG(opchar);
3005 switch (PL_op->op_type) {
3007 #if !(defined(HAS_ACCESS) && defined(R_OK))
3013 #if defined(HAS_ACCESS) && defined(W_OK)
3018 stat_mode = S_IWUSR;
3022 #if defined(HAS_ACCESS) && defined(X_OK)
3027 stat_mode = S_IXUSR;
3031 #ifdef PERL_EFF_ACCESS
3034 stat_mode = S_IWUSR;
3038 #ifndef PERL_EFF_ACCESS
3045 #ifdef PERL_EFF_ACCESS
3050 stat_mode = S_IXUSR;
3056 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3057 const char *name = SvPV_nolen(*PL_stack_sp);
3059 # ifdef PERL_EFF_ACCESS
3060 result = PERL_EFF_ACCESS(name, access_mode);
3062 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3068 result = access(name, access_mode);
3070 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3081 result = my_stat_flags(0);
3084 if (cando(stat_mode, effective, &PL_statcache))
3093 const int op_type = PL_op->op_type;
3097 case OP_FTIS: opchar = 'e'; break;
3098 case OP_FTSIZE: opchar = 's'; break;
3099 case OP_FTMTIME: opchar = 'M'; break;
3100 case OP_FTCTIME: opchar = 'C'; break;
3101 case OP_FTATIME: opchar = 'A'; break;
3103 tryAMAGICftest_MG(opchar);
3105 result = my_stat_flags(0);
3108 if (op_type == OP_FTIS)
3111 /* You can't dTARGET inside OP_FTIS, because you'll get
3112 "panic: pad_sv po" - the op is not flagged to have a target. */
3116 #if Off_t_size > IVSIZE
3117 sv_setnv(TARG, (NV)PL_statcache.st_size);
3119 sv_setiv(TARG, (IV)PL_statcache.st_size);
3124 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3128 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3132 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3136 return SvTRUE_nomg(TARG)
3137 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3147 switch (PL_op->op_type) {
3148 case OP_FTROWNED: opchar = 'O'; break;
3149 case OP_FTEOWNED: opchar = 'o'; break;
3150 case OP_FTZERO: opchar = 'z'; break;
3151 case OP_FTSOCK: opchar = 'S'; break;
3152 case OP_FTCHR: opchar = 'c'; break;
3153 case OP_FTBLK: opchar = 'b'; break;
3154 case OP_FTFILE: opchar = 'f'; break;
3155 case OP_FTDIR: opchar = 'd'; break;
3156 case OP_FTPIPE: opchar = 'p'; break;
3157 case OP_FTSUID: opchar = 'u'; break;
3158 case OP_FTSGID: opchar = 'g'; break;
3159 case OP_FTSVTX: opchar = 'k'; break;
3161 tryAMAGICftest_MG(opchar);
3163 /* I believe that all these three are likely to be defined on most every
3164 system these days. */
3166 if(PL_op->op_type == OP_FTSUID) {
3171 if(PL_op->op_type == OP_FTSGID) {
3176 if(PL_op->op_type == OP_FTSVTX) {
3181 result = my_stat_flags(0);
3184 switch (PL_op->op_type) {
3186 if (PL_statcache.st_uid == PerlProc_getuid())
3190 if (PL_statcache.st_uid == PerlProc_geteuid())
3194 if (PL_statcache.st_size == 0)
3198 if (S_ISSOCK(PL_statcache.st_mode))
3202 if (S_ISCHR(PL_statcache.st_mode))
3206 if (S_ISBLK(PL_statcache.st_mode))
3210 if (S_ISREG(PL_statcache.st_mode))
3214 if (S_ISDIR(PL_statcache.st_mode))
3218 if (S_ISFIFO(PL_statcache.st_mode))
3223 if (PL_statcache.st_mode & S_ISUID)
3229 if (PL_statcache.st_mode & S_ISGID)
3235 if (PL_statcache.st_mode & S_ISVTX)
3248 tryAMAGICftest_MG('l');
3249 result = my_lstat_flags(0);
3253 if (S_ISLNK(PL_statcache.st_mode))
3266 tryAMAGICftest_MG('t');
3268 if (PL_op->op_flags & OPf_REF)
3271 SV *tmpsv = *PL_stack_sp;
3272 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3273 name = SvPV_nomg(tmpsv, namelen);
3274 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3278 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3279 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3280 else if (name && isDIGIT(*name))
3284 if (PerlLIO_isatty(fd))
3302 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3304 if (PL_op->op_flags & OPf_REF)
3306 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3311 gv = MAYBE_DEREF_GV_nomg(sv);
3315 if (gv == PL_defgv) {
3317 io = SvTYPE(PL_statgv) == SVt_PVIO
3321 goto really_filename;
3326 sv_setpvs(PL_statname, "");
3327 io = GvIO(PL_statgv);
3329 PL_laststatval = -1;
3330 PL_laststype = OP_STAT;
3331 if (io && IoIFP(io)) {
3332 if (! PerlIO_has_base(IoIFP(io)))
3333 DIE(aTHX_ "-T and -B not implemented on filehandles");
3334 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3335 if (PL_laststatval < 0)
3337 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3338 if (PL_op->op_type == OP_FTTEXT)
3343 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3344 i = PerlIO_getc(IoIFP(io));
3346 (void)PerlIO_ungetc(IoIFP(io),i);
3348 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3350 len = PerlIO_get_bufsiz(IoIFP(io));
3351 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3352 /* sfio can have large buffers - limit to 512 */
3357 SETERRNO(EBADF,RMS_IFI);
3359 SETERRNO(EBADF,RMS_IFI);
3364 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3367 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3369 PL_laststatval = -1;
3370 PL_laststype = OP_STAT;
3372 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3374 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3377 PL_laststype = OP_STAT;
3378 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3379 if (PL_laststatval < 0) {
3380 (void)PerlIO_close(fp);
3383 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3384 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3385 (void)PerlIO_close(fp);
3387 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3388 FT_RETURNNO; /* special case NFS directories */
3389 FT_RETURNYES; /* null file is anything */
3394 /* now scan s to look for textiness */
3395 /* XXX ASCII dependent code */
3397 #if defined(DOSISH) || defined(USEMYBINMODE)
3398 /* ignore trailing ^Z on short files */
3399 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3403 for (i = 0; i < len; i++, s++) {
3404 if (!*s) { /* null never allowed in text */
3409 else if (!(isPRINT(*s) || isSPACE(*s)))
3412 else if (*s & 128) {
3414 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3417 /* utf8 characters don't count as odd */
3418 if (UTF8_IS_START(*s)) {
3419 int ulen = UTF8SKIP(s);
3420 if (ulen < len - i) {
3422 for (j = 1; j < ulen; j++) {
3423 if (!UTF8_IS_CONTINUATION(s[j]))
3426 --ulen; /* loop does extra increment */
3436 *s != '\n' && *s != '\r' && *s != '\b' &&
3437 *s != '\t' && *s != '\f' && *s != 27)
3442 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3453 const char *tmps = NULL;
3457 SV * const sv = POPs;
3458 if (PL_op->op_flags & OPf_SPECIAL) {
3459 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3461 else if (!(gv = MAYBE_DEREF_GV(sv)))
3462 tmps = SvPV_nomg_const_nolen(sv);
3465 if( !gv && (!tmps || !*tmps) ) {
3466 HV * const table = GvHVn(PL_envgv);
3469 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3470 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3472 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3477 deprecate("chdir('') or chdir(undef) as chdir()");
3478 tmps = SvPV_nolen_const(*svp);
3482 TAINT_PROPER("chdir");
3487 TAINT_PROPER("chdir");
3490 IO* const io = GvIO(gv);
3493 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3494 } else if (IoIFP(io)) {
3495 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3499 SETERRNO(EBADF, RMS_IFI);
3505 SETERRNO(EBADF,RMS_IFI);
3509 DIE(aTHX_ PL_no_func, "fchdir");
3513 PUSHi( PerlDir_chdir(tmps) >= 0 );
3515 /* Clear the DEFAULT element of ENV so we'll get the new value
3517 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3524 dVAR; dSP; dMARK; dTARGET;
3525 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3536 char * const tmps = POPpx;
3537 TAINT_PROPER("chroot");
3538 PUSHi( chroot(tmps) >= 0 );
3541 DIE(aTHX_ PL_no_func, "chroot");
3549 const char * const tmps2 = POPpconstx;
3550 const char * const tmps = SvPV_nolen_const(TOPs);
3551 TAINT_PROPER("rename");
3553 anum = PerlLIO_rename(tmps, tmps2);
3555 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3556 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3559 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3560 (void)UNLINK(tmps2);
3561 if (!(anum = link(tmps, tmps2)))
3562 anum = UNLINK(tmps);
3570 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3574 const int op_type = PL_op->op_type;
3578 if (op_type == OP_LINK)
3579 DIE(aTHX_ PL_no_func, "link");
3581 # ifndef HAS_SYMLINK
3582 if (op_type == OP_SYMLINK)
3583 DIE(aTHX_ PL_no_func, "symlink");
3587 const char * const tmps2 = POPpconstx;
3588 const char * const tmps = SvPV_nolen_const(TOPs);
3589 TAINT_PROPER(PL_op_desc[op_type]);
3591 # if defined(HAS_LINK)
3592 # if defined(HAS_SYMLINK)
3593 /* Both present - need to choose which. */
3594 (op_type == OP_LINK) ?
3595 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3597 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3598 PerlLIO_link(tmps, tmps2);
3601 # if defined(HAS_SYMLINK)
3602 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3603 symlink(tmps, tmps2);
3608 SETi( result >= 0 );
3615 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3626 char buf[MAXPATHLEN];
3629 #ifndef INCOMPLETE_TAINTS
3633 len = readlink(tmps, buf, sizeof(buf) - 1);
3640 RETSETUNDEF; /* just pretend it's a normal file */
3644 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3646 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3648 char * const save_filename = filename;
3653 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3655 PERL_ARGS_ASSERT_DOONELINER;
3657 Newx(cmdline, size, char);
3658 my_strlcpy(cmdline, cmd, size);
3659 my_strlcat(cmdline, " ", size);
3660 for (s = cmdline + strlen(cmdline); *filename; ) {
3664 if (s - cmdline < size)
3665 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3666 myfp = PerlProc_popen(cmdline, "r");
3670 SV * const tmpsv = sv_newmortal();
3671 /* Need to save/restore 'PL_rs' ?? */
3672 s = sv_gets(tmpsv, myfp, 0);
3673 (void)PerlProc_pclose(myfp);
3677 #ifdef HAS_SYS_ERRLIST
3682 /* you don't see this */
3683 const char * const errmsg =
3684 #ifdef HAS_SYS_ERRLIST
3692 if (instr(s, errmsg)) {
3699 #define EACCES EPERM
3701 if (instr(s, "cannot make"))
3702 SETERRNO(EEXIST,RMS_FEX);
3703 else if (instr(s, "existing file"))
3704 SETERRNO(EEXIST,RMS_FEX);
3705 else if (instr(s, "ile exists"))
3706 SETERRNO(EEXIST,RMS_FEX);
3707 else if (instr(s, "non-exist"))
3708 SETERRNO(ENOENT,RMS_FNF);
3709 else if (instr(s, "does not exist"))
3710 SETERRNO(ENOENT,RMS_FNF);
3711 else if (instr(s, "not empty"))
3712 SETERRNO(EBUSY,SS_DEVOFFLINE);
3713 else if (instr(s, "cannot access"))
3714 SETERRNO(EACCES,RMS_PRV);
3716 SETERRNO(EPERM,RMS_PRV);
3719 else { /* some mkdirs return no failure indication */
3720 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3721 if (PL_op->op_type == OP_RMDIR)
3726 SETERRNO(EACCES,RMS_PRV); /* a guess */
3735 /* This macro removes trailing slashes from a directory name.
3736 * Different operating and file systems take differently to
3737 * trailing slashes. According to POSIX 1003.1 1996 Edition
3738 * any number of trailing slashes should be allowed.
3739 * Thusly we snip them away so that even non-conforming
3740 * systems are happy.
3741 * We should probably do this "filtering" for all
3742 * the functions that expect (potentially) directory names:
3743 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3744 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3746 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3747 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3750 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3751 (tmps) = savepvn((tmps), (len)); \
3761 const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3763 TRIMSLASHES(tmps,len,copy);
3765 TAINT_PROPER("mkdir");
3767 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3771 SETi( dooneliner("mkdir", tmps) );
3772 oldumask = PerlLIO_umask(0);
3773 PerlLIO_umask(oldumask);
3774 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3789 TRIMSLASHES(tmps,len,copy);
3790 TAINT_PROPER("rmdir");
3792 SETi( PerlDir_rmdir(tmps) >= 0 );
3794 SETi( dooneliner("rmdir", tmps) );
3801 /* Directory calls. */
3805 #if defined(Direntry_t) && defined(HAS_READDIR)
3807 const char * const dirname = POPpconstx;
3808 GV * const gv = MUTABLE_GV(POPs);
3809 IO * const io = GvIOn(gv);
3814 if ((IoIFP(io) || IoOFP(io)))
3815 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3816 "Opening filehandle %"HEKf" also as a directory",
3817 HEKfARG(GvENAME_HEK(gv)) );
3819 PerlDir_close(IoDIRP(io));
3820 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3826 SETERRNO(EBADF,RMS_DIR);
3829 DIE(aTHX_ PL_no_dir_func, "opendir");
3835 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3836 DIE(aTHX_ PL_no_dir_func, "readdir");
3838 #if !defined(I_DIRENT) && !defined(VMS)
3839 Direntry_t *readdir (DIR *);
3845 const I32 gimme = GIMME;
3846 GV * const gv = MUTABLE_GV(POPs);
3847 const Direntry_t *dp;
3848 IO * const io = GvIOn(gv);
3850 if (!io || !IoDIRP(io)) {
3851 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3852 "readdir() attempted on invalid dirhandle %"HEKf,
3853 HEKfARG(GvENAME_HEK(gv)));
3858 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3862 sv = newSVpvn(dp->d_name, dp->d_namlen);
3864 sv = newSVpv(dp->d_name, 0);
3866 #ifndef INCOMPLETE_TAINTS
3867 if (!(IoFLAGS(io) & IOf_UNTAINT))
3871 } while (gimme == G_ARRAY);
3873 if (!dp && gimme != G_ARRAY)
3880 SETERRNO(EBADF,RMS_ISI);
3881 if (GIMME == G_ARRAY)
3890 #if defined(HAS_TELLDIR) || defined(telldir)
3892 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3893 /* XXX netbsd still seemed to.
3894 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3895 --JHI 1999-Feb-02 */
3896 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3897 long telldir (DIR *);
3899 GV * const gv = MUTABLE_GV(POPs);
3900 IO * const io = GvIOn(gv);
3902 if (!io || !IoDIRP(io)) {
3903 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3904 "telldir() attempted on invalid dirhandle %"HEKf,
3905 HEKfARG(GvENAME_HEK(gv)));
3909 PUSHi( PerlDir_tell(IoDIRP(io)) );
3913 SETERRNO(EBADF,RMS_ISI);
3916 DIE(aTHX_ PL_no_dir_func, "telldir");
3922 #if defined(HAS_SEEKDIR) || defined(seekdir)
3924 const long along = POPl;
3925 GV * const gv = MUTABLE_GV(POPs);
3926 IO * const io = GvIOn(gv);
3928 if (!io || !IoDIRP(io)) {
3929 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3930 "seekdir() attempted on invalid dirhandle %"HEKf,
3931 HEKfARG(GvENAME_HEK(gv)));
3934 (void)PerlDir_seek(IoDIRP(io), along);
3939 SETERRNO(EBADF,RMS_ISI);
3942 DIE(aTHX_ PL_no_dir_func, "seekdir");
3948 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3950 GV * const gv = MUTABLE_GV(POPs);
3951 IO * const io = GvIOn(gv);
3953 if (!io || !IoDIRP(io)) {
3954 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3955 "rewinddir() attempted on invalid dirhandle %"HEKf,
3956 HEKfARG(GvENAME_HEK(gv)));
3959 (void)PerlDir_rewind(IoDIRP(io));
3963 SETERRNO(EBADF,RMS_ISI);
3966 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3972 #if defined(Direntry_t) && defined(HAS_READDIR)
3974 GV * const gv = MUTABLE_GV(POPs);
3975 IO * const io = GvIOn(gv);
3977 if (!io || !IoDIRP(io)) {
3978 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3979 "closedir() attempted on invalid dirhandle %"HEKf,
3980 HEKfARG(GvENAME_HEK(gv)));
3983 #ifdef VOID_CLOSEDIR
3984 PerlDir_close(IoDIRP(io));
3986 if (PerlDir_close(IoDIRP(io)) < 0) {
3987 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3996 SETERRNO(EBADF,RMS_IFI);
3999 DIE(aTHX_ PL_no_dir_func, "closedir");
4003 /* Process control. */
4010 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4011 sigset_t oldmask, newmask;
4015 PERL_FLUSHALL_FOR_CHILD;
4016 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4017 sigfillset(&newmask);
4018 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4020 childpid = PerlProc_fork();
4021 if (childpid == 0) {
4025 for (sig = 1; sig < SIG_SIZE; sig++)
4026 PL_psig_pend[sig] = 0;
4028 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4031 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4038 #ifdef PERL_USES_PL_PIDSTATUS
4039 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4045 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4050 PERL_FLUSHALL_FOR_CHILD;
4051 childpid = PerlProc_fork();
4057 DIE(aTHX_ PL_no_func, "fork");
4064 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4069 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4070 childpid = wait4pid(-1, &argflags, 0);
4072 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4077 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4078 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4079 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4081 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4086 DIE(aTHX_ PL_no_func, "wait");
4092 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4094 const int optype = POPi;
4095 const Pid_t pid = TOPi;
4099 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4100 result = wait4pid(pid, &argflags, optype);
4102 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4107 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4108 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4109 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4111 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4116 DIE(aTHX_ PL_no_func, "waitpid");
4122 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4123 #if defined(__LIBCATAMOUNT__)
4124 PL_statusvalue = -1;
4133 while (++MARK <= SP) {
4134 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4139 TAINT_PROPER("system");
4141 PERL_FLUSHALL_FOR_CHILD;
4142 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4147 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4148 sigset_t newset, oldset;
4151 if (PerlProc_pipe(pp) >= 0)
4153 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4154 sigemptyset(&newset);
4155 sigaddset(&newset, SIGCHLD);
4156 sigprocmask(SIG_BLOCK, &newset, &oldset);
4158 while ((childpid = PerlProc_fork()) == -1) {
4159 if (errno != EAGAIN) {
4164 PerlLIO_close(pp[0]);
4165 PerlLIO_close(pp[1]);
4167 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4168 sigprocmask(SIG_SETMASK, &oldset, NULL);
4175 Sigsave_t ihand,qhand; /* place to save signals during system() */
4179 PerlLIO_close(pp[1]);
4181 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4182 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4185 result = wait4pid(childpid, &status, 0);
4186 } while (result == -1 && errno == EINTR);
4188 #ifdef HAS_SIGPROCMASK
4189 sigprocmask(SIG_SETMASK, &oldset, NULL);
4191 (void)rsignal_restore(SIGINT, &ihand);
4192 (void)rsignal_restore(SIGQUIT, &qhand);
4194 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4195 do_execfree(); /* free any memory child malloced on fork */
4202 while (n < sizeof(int)) {
4203 n1 = PerlLIO_read(pp[0],
4204 (void*)(((char*)&errkid)+n),
4210 PerlLIO_close(pp[0]);
4211 if (n) { /* Error */
4212 if (n != sizeof(int))
4213 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4214 errno = errkid; /* Propagate errno from kid */
4215 STATUS_NATIVE_CHILD_SET(-1);
4218 XPUSHi(STATUS_CURRENT);
4221 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4222 sigprocmask(SIG_SETMASK, &oldset, NULL);
4225 PerlLIO_close(pp[0]);
4226 #if defined(HAS_FCNTL) && defined(F_SETFD)
4227 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4230 if (PL_op->op_flags & OPf_STACKED) {
4231 SV * const really = *++MARK;
4232 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4234 else if (SP - MARK != 1)
4235 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4237 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4241 #else /* ! FORK or VMS or OS/2 */
4244 if (PL_op->op_flags & OPf_STACKED) {
4245 SV * const really = *++MARK;
4246 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4247 value = (I32)do_aspawn(really, MARK, SP);
4249 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4252 else if (SP - MARK != 1) {
4253 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4254 value = (I32)do_aspawn(NULL, MARK, SP);
4256 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4260 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4262 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4264 STATUS_NATIVE_CHILD_SET(value);
4267 XPUSHi(result ? value : STATUS_CURRENT);
4268 #endif /* !FORK or VMS or OS/2 */
4275 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4280 while (++MARK <= SP) {
4281 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4286 TAINT_PROPER("exec");
4288 PERL_FLUSHALL_FOR_CHILD;
4289 if (PL_op->op_flags & OPf_STACKED) {
4290 SV * const really = *++MARK;
4291 value = (I32)do_aexec(really, MARK, SP);
4293 else if (SP - MARK != 1)
4295 value = (I32)vms_do_aexec(NULL, MARK, SP);
4297 value = (I32)do_aexec(NULL, MARK, SP);
4301 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4303 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4316 XPUSHi( getppid() );
4319 DIE(aTHX_ PL_no_func, "getppid");
4329 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4332 pgrp = (I32)BSD_GETPGRP(pid);
4334 if (pid != 0 && pid != PerlProc_getpid())
4335 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4341 DIE(aTHX_ PL_no_func, "getpgrp()");
4351 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4352 if (MAXARG > 0) pid = TOPs && TOPi;
4358 TAINT_PROPER("setpgrp");
4360 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4362 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4363 || (pid != 0 && pid != PerlProc_getpid()))
4365 DIE(aTHX_ "setpgrp can't take arguments");
4367 SETi( setpgrp() >= 0 );
4368 #endif /* USE_BSDPGRP */
4371 DIE(aTHX_ PL_no_func, "setpgrp()");
4375 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4376 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4378 # define PRIORITY_WHICH_T(which) which
4383 #ifdef HAS_GETPRIORITY
4385 const int who = POPi;
4386 const int which = TOPi;
4387 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4390 DIE(aTHX_ PL_no_func, "getpriority()");
4396 #ifdef HAS_SETPRIORITY
4398 const int niceval = POPi;
4399 const int who = POPi;
4400 const int which = TOPi;
4401 TAINT_PROPER("setpriority");
4402 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4405 DIE(aTHX_ PL_no_func, "setpriority()");
4409 #undef PRIORITY_WHICH_T
4417 XPUSHn( time(NULL) );
4419 XPUSHi( time(NULL) );
4431 (void)PerlProc_times(&PL_timesbuf);
4433 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4434 /* struct tms, though same data */
4438 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4439 if (GIMME == G_ARRAY) {
4440 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4441 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4442 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4450 if (GIMME == G_ARRAY) {
4457 DIE(aTHX_ "times not implemented");
4459 #endif /* HAS_TIMES */
4462 /* The 32 bit int year limits the times we can represent to these
4463 boundaries with a few days wiggle room to account for time zone
4466 /* Sat Jan 3 00:00:00 -2147481748 */
4467 #define TIME_LOWER_BOUND -67768100567755200.0
4468 /* Sun Dec 29 12:00:00 2147483647 */
4469 #define TIME_UPPER_BOUND 67767976233316800.0
4478 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4479 static const char * const dayname[] =
4480 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4481 static const char * const monname[] =
4482 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4483 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4485 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4488 when = (Time64_T)now;
4491 NV input = Perl_floor(POPn);
4492 when = (Time64_T)input;
4493 if (when != input) {
4494 /* diag_listed_as: gmtime(%f) too large */
4495 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4496 "%s(%.0" NVff ") too large", opname, input);
4500 if ( TIME_LOWER_BOUND > when ) {
4501 /* diag_listed_as: gmtime(%f) too small */
4502 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4503 "%s(%.0" NVff ") too small", opname, when);
4506 else if( when > TIME_UPPER_BOUND ) {
4507 /* diag_listed_as: gmtime(%f) too small */
4508 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4509 "%s(%.0" NVff ") too large", opname, when);
4513 if (PL_op->op_type == OP_LOCALTIME)
4514 err = S_localtime64_r(&when, &tmbuf);
4516 err = S_gmtime64_r(&when, &tmbuf);
4520 /* XXX %lld broken for quads */
4521 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4522 "%s(%.0" NVff ") failed", opname, when);
4525 if (GIMME != G_ARRAY) { /* scalar context */
4527 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4528 double year = (double)tmbuf.tm_year + 1900;
4535 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4536 dayname[tmbuf.tm_wday],
4537 monname[tmbuf.tm_mon],
4545 else { /* list context */
4551 mPUSHi(tmbuf.tm_sec);
4552 mPUSHi(tmbuf.tm_min);
4553 mPUSHi(tmbuf.tm_hour);
4554 mPUSHi(tmbuf.tm_mday);
4555 mPUSHi(tmbuf.tm_mon);
4556 mPUSHn(tmbuf.tm_year);
4557 mPUSHi(tmbuf.tm_wday);
4558 mPUSHi(tmbuf.tm_yday);
4559 mPUSHi(tmbuf.tm_isdst);
4570 anum = alarm((unsigned int)anum);
4576 DIE(aTHX_ PL_no_func, "alarm");
4587 (void)time(&lasttime);
4588 if (MAXARG < 1 || (!TOPs && !POPs))
4592 PerlProc_sleep((unsigned int)duration);
4595 XPUSHi(when - lasttime);
4599 /* Shared memory. */
4600 /* Merged with some message passing. */
4604 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4605 dVAR; dSP; dMARK; dTARGET;
4606 const int op_type = PL_op->op_type;
4611 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4614 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4617 value = (I32)(do_semop(MARK, SP) >= 0);
4620 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4628 return Perl_pp_semget(aTHX);
4636 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4637 dVAR; dSP; dMARK; dTARGET;
4638 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4645 DIE(aTHX_ "System V IPC is not implemented on this machine");
4651 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4652 dVAR; dSP; dMARK; dTARGET;
4653 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4661 PUSHp(zero_but_true, ZBTLEN);
4665 return Perl_pp_semget(aTHX);
4669 /* I can't const this further without getting warnings about the types of
4670 various arrays passed in from structures. */
4672 S_space_join_names_mortal(pTHX_ char *const *array)
4676 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4678 if (array && *array) {
4679 target = newSVpvs_flags("", SVs_TEMP);
4681 sv_catpv(target, *array);
4684 sv_catpvs(target, " ");
4687 target = sv_mortalcopy(&PL_sv_no);
4692 /* Get system info. */
4696 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4698 I32 which = PL_op->op_type;
4701 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4702 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4703 struct hostent *gethostbyname(Netdb_name_t);
4704 struct hostent *gethostent(void);
4706 struct hostent *hent = NULL;
4710 if (which == OP_GHBYNAME) {
4711 #ifdef HAS_GETHOSTBYNAME
4712 const char* const name = POPpbytex;
4713 hent = PerlSock_gethostbyname(name);
4715 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4718 else if (which == OP_GHBYADDR) {
4719 #ifdef HAS_GETHOSTBYADDR
4720 const int addrtype = POPi;
4721 SV * const addrsv = POPs;
4723 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4725 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4727 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4731 #ifdef HAS_GETHOSTENT
4732 hent = PerlSock_gethostent();
4734 DIE(aTHX_ PL_no_sock_func, "gethostent");
4737 #ifdef HOST_NOT_FOUND
4739 #ifdef USE_REENTRANT_API
4740 # ifdef USE_GETHOSTENT_ERRNO
4741 h_errno = PL_reentrant_buffer->_gethostent_errno;
4744 STATUS_UNIX_SET(h_errno);
4748 if (GIMME != G_ARRAY) {
4749 PUSHs(sv = sv_newmortal());
4751 if (which == OP_GHBYNAME) {
4753 sv_setpvn(sv, hent->h_addr, hent->h_length);
4756 sv_setpv(sv, (char*)hent->h_name);
4762 mPUSHs(newSVpv((char*)hent->h_name, 0));
4763 PUSHs(space_join_names_mortal(hent->h_aliases));
4764 mPUSHi(hent->h_addrtype);
4765 len = hent->h_length;
4768 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4769 mXPUSHp(*elem, len);
4773 mPUSHp(hent->h_addr, len);
4775 PUSHs(sv_mortalcopy(&PL_sv_no));
4780 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4786 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4788 I32 which = PL_op->op_type;
4790 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4791 struct netent *getnetbyaddr(Netdb_net_t, int);
4792 struct netent *getnetbyname(Netdb_name_t);
4793 struct netent *getnetent(void);
4795 struct netent *nent;
4797 if (which == OP_GNBYNAME){
4798 #ifdef HAS_GETNETBYNAME
4799 const char * const name = POPpbytex;
4800 nent = PerlSock_getnetbyname(name);
4802 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4805 else if (which == OP_GNBYADDR) {
4806 #ifdef HAS_GETNETBYADDR
4807 const int addrtype = POPi;
4808 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4809 nent = PerlSock_getnetbyaddr(addr, addrtype);
4811 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4815 #ifdef HAS_GETNETENT
4816 nent = PerlSock_getnetent();
4818 DIE(aTHX_ PL_no_sock_func, "getnetent");
4821 #ifdef HOST_NOT_FOUND
4823 #ifdef USE_REENTRANT_API
4824 # ifdef USE_GETNETENT_ERRNO
4825 h_errno = PL_reentrant_buffer->_getnetent_errno;
4828 STATUS_UNIX_SET(h_errno);
4833 if (GIMME != G_ARRAY) {
4834 PUSHs(sv = sv_newmortal());
4836 if (which == OP_GNBYNAME)
4837 sv_setiv(sv, (IV)nent->n_net);
4839 sv_setpv(sv, nent->n_name);
4845 mPUSHs(newSVpv(nent->n_name, 0));
4846 PUSHs(space_join_names_mortal(nent->n_aliases));
4847 mPUSHi(nent->n_addrtype);
4848 mPUSHi(nent->n_net);
4853 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4859 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4861 I32 which = PL_op->op_type;
4863 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4864 struct protoent *getprotobyname(Netdb_name_t);
4865 struct protoent *getprotobynumber(int);
4866 struct protoent *getprotoent(void);
4868 struct protoent *pent;
4870 if (which == OP_GPBYNAME) {
4871 #ifdef HAS_GETPROTOBYNAME
4872 const char* const name = POPpbytex;
4873 pent = PerlSock_getprotobyname(name);
4875 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4878 else if (which == OP_GPBYNUMBER) {
4879 #ifdef HAS_GETPROTOBYNUMBER
4880 const int number = POPi;
4881 pent = PerlSock_getprotobynumber(number);
4883 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4887 #ifdef HAS_GETPROTOENT
4888 pent = PerlSock_getprotoent();
4890 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4894 if (GIMME != G_ARRAY) {
4895 PUSHs(sv = sv_newmortal());
4897 if (which == OP_GPBYNAME)
4898 sv_setiv(sv, (IV)pent->p_proto);
4900 sv_setpv(sv, pent->p_name);
4906 mPUSHs(newSVpv(pent->p_name, 0));
4907 PUSHs(space_join_names_mortal(pent->p_aliases));
4908 mPUSHi(pent->p_proto);
4913 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4919 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4921 I32 which = PL_op->op_type;
4923 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4924 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4925 struct servent *getservbyport(int, Netdb_name_t);
4926 struct servent *getservent(void);
4928 struct servent *sent;
4930 if (which == OP_GSBYNAME) {
4931 #ifdef HAS_GETSERVBYNAME
4932 const char * const proto = POPpbytex;
4933 const char * const name = POPpbytex;
4934 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4936 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4939 else if (which == OP_GSBYPORT) {
4940 #ifdef HAS_GETSERVBYPORT
4941 const char * const proto = POPpbytex;
4942 unsigned short port = (unsigned short)POPu;
4944 port = PerlSock_htons(port);
4946 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4948 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4952 #ifdef HAS_GETSERVENT
4953 sent = PerlSock_getservent();
4955 DIE(aTHX_ PL_no_sock_func, "getservent");
4959 if (GIMME != G_ARRAY) {
4960 PUSHs(sv = sv_newmortal());
4962 if (which == OP_GSBYNAME) {
4964 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4966 sv_setiv(sv, (IV)(sent->s_port));
4970 sv_setpv(sv, sent->s_name);
4976 mPUSHs(newSVpv(sent->s_name, 0));
4977 PUSHs(space_join_names_mortal(sent->s_aliases));
4979 mPUSHi(PerlSock_ntohs(sent->s_port));
4981 mPUSHi(sent->s_port);
4983 mPUSHs(newSVpv(sent->s_proto, 0));
4988 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4995 const int stayopen = TOPi;
4996 switch(PL_op->op_type) {
4998 #ifdef HAS_SETHOSTENT
4999 PerlSock_sethostent(stayopen);
5001 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5004 #ifdef HAS_SETNETENT
5006 PerlSock_setnetent(stayopen);
5008 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5012 #ifdef HAS_SETPROTOENT
5013 PerlSock_setprotoent(stayopen);
5015 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5019 #ifdef HAS_SETSERVENT
5020 PerlSock_setservent(stayopen);
5022 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5032 switch(PL_op->op_type) {
5034 #ifdef HAS_ENDHOSTENT
5035 PerlSock_endhostent();
5037 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5041 #ifdef HAS_ENDNETENT
5042 PerlSock_endnetent();
5044 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5048 #ifdef HAS_ENDPROTOENT
5049 PerlSock_endprotoent();
5051 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5055 #ifdef HAS_ENDSERVENT
5056 PerlSock_endservent();
5058 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5062 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5065 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5069 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5072 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5076 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5079 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5083 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5086 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5098 I32 which = PL_op->op_type;
5100 struct passwd *pwent = NULL;
5102 * We currently support only the SysV getsp* shadow password interface.
5103 * The interface is declared in <shadow.h> and often one needs to link
5104 * with -lsecurity or some such.
5105 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5108 * AIX getpwnam() is clever enough to return the encrypted password
5109 * only if the caller (euid?) is root.
5111 * There are at least three other shadow password APIs. Many platforms
5112 * seem to contain more than one interface for accessing the shadow
5113 * password databases, possibly for compatibility reasons.
5114 * The getsp*() is by far he simplest one, the other two interfaces
5115 * are much more complicated, but also very similar to each other.
5120 * struct pr_passwd *getprpw*();
5121 * The password is in
5122 * char getprpw*(...).ufld.fd_encrypt[]
5123 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5128 * struct es_passwd *getespw*();
5129 * The password is in
5130 * char *(getespw*(...).ufld.fd_encrypt)
5131 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5134 * struct userpw *getuserpw();
5135 * The password is in
5136 * char *(getuserpw(...)).spw_upw_passwd
5137 * (but the de facto standard getpwnam() should work okay)
5139 * Mention I_PROT here so that Configure probes for it.
5141 * In HP-UX for getprpw*() the manual page claims that one should include
5142 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5143 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5144 * and pp_sys.c already includes <shadow.h> if there is such.
5146 * Note that <sys/security.h> is already probed for, but currently
5147 * it is only included in special cases.
5149 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5150 * be preferred interface, even though also the getprpw*() interface
5151 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5152 * One also needs to call set_auth_parameters() in main() before
5153 * doing anything else, whether one is using getespw*() or getprpw*().
5155 * Note that accessing the shadow databases can be magnitudes
5156 * slower than accessing the standard databases.
5161 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5162 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5163 * the pw_comment is left uninitialized. */
5164 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5170 const char* const name = POPpbytex;
5171 pwent = getpwnam(name);
5177 pwent = getpwuid(uid);
5181 # ifdef HAS_GETPWENT
5183 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5184 if (pwent) pwent = getpwnam(pwent->pw_name);
5187 DIE(aTHX_ PL_no_func, "getpwent");
5193 if (GIMME != G_ARRAY) {
5194 PUSHs(sv = sv_newmortal());
5196 if (which == OP_GPWNAM)
5197 # if Uid_t_sign <= 0
5198 sv_setiv(sv, (IV)pwent->pw_uid);
5200 sv_setuv(sv, (UV)pwent->pw_uid);
5203 sv_setpv(sv, pwent->pw_name);
5209 mPUSHs(newSVpv(pwent->pw_name, 0));
5213 /* If we have getspnam(), we try to dig up the shadow
5214 * password. If we are underprivileged, the shadow
5215 * interface will set the errno to EACCES or similar,
5216 * and return a null pointer. If this happens, we will
5217 * use the dummy password (usually "*" or "x") from the
5218 * standard password database.
5220 * In theory we could skip the shadow call completely
5221 * if euid != 0 but in practice we cannot know which
5222 * security measures are guarding the shadow databases
5223 * on a random platform.
5225 * Resist the urge to use additional shadow interfaces.
5226 * Divert the urge to writing an extension instead.
5229 /* Some AIX setups falsely(?) detect some getspnam(), which
5230 * has a different API than the Solaris/IRIX one. */
5231 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5234 const struct spwd * const spwent = getspnam(pwent->pw_name);
5235 /* Save and restore errno so that
5236 * underprivileged attempts seem
5237 * to have never made the unsuccessful
5238 * attempt to retrieve the shadow password. */
5240 if (spwent && spwent->sp_pwdp)
5241 sv_setpv(sv, spwent->sp_pwdp);
5245 if (!SvPOK(sv)) /* Use the standard password, then. */
5246 sv_setpv(sv, pwent->pw_passwd);
5249 # ifndef INCOMPLETE_TAINTS
5250 /* passwd is tainted because user himself can diddle with it.
5251 * admittedly not much and in a very limited way, but nevertheless. */
5255 # if Uid_t_sign <= 0
5256 mPUSHi(pwent->pw_uid);
5258 mPUSHu(pwent->pw_uid);
5261 # if Uid_t_sign <= 0
5262 mPUSHi(pwent->pw_gid);
5264 mPUSHu(pwent->pw_gid);
5266 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5267 * because of the poor interface of the Perl getpw*(),
5268 * not because there's some standard/convention saying so.
5269 * A better interface would have been to return a hash,
5270 * but we are accursed by our history, alas. --jhi. */
5272 mPUSHi(pwent->pw_change);
5275 mPUSHi(pwent->pw_quota);
5278 mPUSHs(newSVpv(pwent->pw_age, 0));
5280 /* I think that you can never get this compiled, but just in case. */
5281 PUSHs(sv_mortalcopy(&PL_sv_no));
5286 /* pw_class and pw_comment are mutually exclusive--.
5287 * see the above note for pw_change, pw_quota, and pw_age. */
5289 mPUSHs(newSVpv(pwent->pw_class, 0));
5292 mPUSHs(newSVpv(pwent->pw_comment, 0));
5294 /* I think that you can never get this compiled, but just in case. */
5295 PUSHs(sv_mortalcopy(&PL_sv_no));
5300 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5302 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5304 # ifndef INCOMPLETE_TAINTS
5305 /* pw_gecos is tainted because user himself can diddle with it. */
5309 mPUSHs(newSVpv(pwent->pw_dir, 0));
5311 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5312 # ifndef INCOMPLETE_TAINTS
5313 /* pw_shell is tainted because user himself can diddle with it. */
5318 mPUSHi(pwent->pw_expire);
5323 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5331 const I32 which = PL_op->op_type;
5332 const struct group *grent;
5334 if (which == OP_GGRNAM) {
5335 const char* const name = POPpbytex;
5336 grent = (const struct group *)getgrnam(name);
5338 else if (which == OP_GGRGID) {
5339 const Gid_t gid = POPi;
5340 grent = (const struct group *)getgrgid(gid);
5344 grent = (struct group *)getgrent();
5346 DIE(aTHX_ PL_no_func, "getgrent");
5350 if (GIMME != G_ARRAY) {
5351 SV * const sv = sv_newmortal();
5355 if (which == OP_GGRNAM)
5357 sv_setiv(sv, (IV)grent->gr_gid);
5359 sv_setuv(sv, (UV)grent->gr_gid);
5362 sv_setpv(sv, grent->gr_name);
5368 mPUSHs(newSVpv(grent->gr_name, 0));
5371 mPUSHs(newSVpv(grent->gr_passwd, 0));
5373 PUSHs(sv_mortalcopy(&PL_sv_no));
5377 mPUSHi(grent->gr_gid);
5379 mPUSHu(grent->gr_gid);
5382 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5383 /* In UNICOS/mk (_CRAYMPP) the multithreading
5384 * versions (getgrnam_r, getgrgid_r)
5385 * seem to return an illegal pointer
5386 * as the group members list, gr_mem.
5387 * getgrent() doesn't even have a _r version
5388 * but the gr_mem is poisonous anyway.
5389 * So yes, you cannot get the list of group
5390 * members if building multithreaded in UNICOS/mk. */
5391 PUSHs(space_join_names_mortal(grent->gr_mem));
5397 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5407 if (!(tmps = PerlProc_getlogin()))
5409 sv_setpv_mg(TARG, tmps);
5413 DIE(aTHX_ PL_no_func, "getlogin");
5417 /* Miscellaneous. */
5422 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5423 I32 items = SP - MARK;
5424 unsigned long a[20];
5429 while (++MARK <= SP) {
5430 if (SvTAINTED(*MARK)) {
5436 TAINT_PROPER("syscall");
5439 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5440 * or where sizeof(long) != sizeof(char*). But such machines will
5441 * not likely have syscall implemented either, so who cares?
5443 while (++MARK <= SP) {
5444 if (SvNIOK(*MARK) || !i)
5445 a[i++] = SvIV(*MARK);
5446 else if (*MARK == &PL_sv_undef)
5449 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5455 DIE(aTHX_ "Too many args to syscall");
5457 DIE(aTHX_ "Too few args to syscall");
5459 retval = syscall(a[0]);
5462 retval = syscall(a[0],a[1]);
5465 retval = syscall(a[0],a[1],a[2]);
5468 retval = syscall(a[0],a[1],a[2],a[3]);
5471 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5474 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5477 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5480 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5487 DIE(aTHX_ PL_no_func, "syscall");
5491 #ifdef FCNTL_EMULATE_FLOCK
5493 /* XXX Emulate flock() with fcntl().
5494 What's really needed is a good file locking module.
5498 fcntl_emulate_flock(int fd, int operation)
5503 switch (operation & ~LOCK_NB) {
5505 flock.l_type = F_RDLCK;
5508 flock.l_type = F_WRLCK;
5511 flock.l_type = F_UNLCK;
5517 flock.l_whence = SEEK_SET;
5518 flock.l_start = flock.l_len = (Off_t)0;
5520 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5521 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5522 errno = EWOULDBLOCK;
5526 #endif /* FCNTL_EMULATE_FLOCK */
5528 #ifdef LOCKF_EMULATE_FLOCK
5530 /* XXX Emulate flock() with lockf(). This is just to increase
5531 portability of scripts. The calls are not completely
5532 interchangeable. What's really needed is a good file
5536 /* The lockf() constants might have been defined in <unistd.h>.
5537 Unfortunately, <unistd.h> causes troubles on some mixed
5538 (BSD/POSIX) systems, such as SunOS 4.1.3.
5540 Further, the lockf() constants aren't POSIX, so they might not be
5541 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5542 just stick in the SVID values and be done with it. Sigh.
5546 # define F_ULOCK 0 /* Unlock a previously locked region */
5549 # define F_LOCK 1 /* Lock a region for exclusive use */
5552 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5555 # define F_TEST 3 /* Test a region for other processes locks */
5559 lockf_emulate_flock(int fd, int operation)
5565 /* flock locks entire file so for lockf we need to do the same */
5566 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5567 if (pos > 0) /* is seekable and needs to be repositioned */
5568 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5569 pos = -1; /* seek failed, so don't seek back afterwards */
5572 switch (operation) {
5574 /* LOCK_SH - get a shared lock */
5576 /* LOCK_EX - get an exclusive lock */
5578 i = lockf (fd, F_LOCK, 0);
5581 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5582 case LOCK_SH|LOCK_NB:
5583 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5584 case LOCK_EX|LOCK_NB:
5585 i = lockf (fd, F_TLOCK, 0);
5587 if ((errno == EAGAIN) || (errno == EACCES))
5588 errno = EWOULDBLOCK;
5591 /* LOCK_UN - unlock (non-blocking is a no-op) */
5593 case LOCK_UN|LOCK_NB:
5594 i = lockf (fd, F_ULOCK, 0);
5597 /* Default - can't decipher operation */
5604 if (pos > 0) /* need to restore position of the handle */
5605 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5610 #endif /* LOCKF_EMULATE_FLOCK */
5614 * c-indentation-style: bsd
5616 * indent-tabs-mode: nil
5619 * ex: set ts=8 sts=4 sw=4 et: