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
35 /* Shadow password support for solaris - pdo@cs.umd.edu
36 * Not just Solaris: at least HP-UX, IRIX, Linux.
37 * The API is from SysV.
39 * There are at least two more shadow interfaces,
40 * see the comments in pp_gpwent().
44 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
45 * and another MAXINT from "perl.h" <- <sys/param.h>. */
52 # include <sys/resource.h>
61 # include <sys/select.h>
65 /* XXX Configure test needed.
66 h_errno might not be a simple 'int', especially for multi-threaded
67 applications, see "extern int errno in perl.h". Creating such
68 a test requires taking into account the differences between
69 compiling multithreaded and singlethreaded ($ccflags et al).
70 HOST_NOT_FOUND is typically defined in <netdb.h>.
72 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
81 struct passwd *getpwnam (char *);
82 struct passwd *getpwuid (Uid_t);
87 struct passwd *getpwent (void);
88 #elif defined (VMS) && defined (my_getpwent)
89 struct passwd *Perl_my_getpwent (pTHX);
98 struct group *getgrnam (char *);
99 struct group *getgrgid (Gid_t);
103 struct group *getgrent (void);
109 # if defined(_MSC_VER) || defined(__MINGW32__)
110 # include <sys/utime.h>
117 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
120 # define my_chsize PerlLIO_chsize
123 # define my_chsize PerlLIO_chsize
125 I32 my_chsize(int fd, Off_t length);
131 #else /* no flock() */
133 /* fcntl.h might not have been included, even if it exists, because
134 the current Configure only sets I_FCNTL if it's needed to pick up
135 the *_OK constants. Make sure it has been included before testing
136 the fcntl() locking constants. */
137 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
141 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
142 # define FLOCK fcntl_emulate_flock
143 # define FCNTL_EMULATE_FLOCK
144 # else /* no flock() or fcntl(F_SETLK,...) */
146 # define FLOCK lockf_emulate_flock
147 # define LOCKF_EMULATE_FLOCK
149 # endif /* no flock() or fcntl(F_SETLK,...) */
152 static int FLOCK (int, int);
155 * These are the flock() constants. Since this sytems doesn't have
156 * flock(), the values of the constants are probably not available.
170 # endif /* emulating flock() */
172 #endif /* no flock() */
175 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
177 #if defined(I_SYS_ACCESS) && !defined(R_OK)
178 # include <sys/access.h>
184 /* Missing protos on LynxOS */
185 void sethostent(int);
186 void endhostent(void);
188 void endnetent(void);
189 void setprotoent(int);
190 void endprotoent(void);
191 void setservent(int);
192 void endservent(void);
195 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
197 /* F_OK unused: if stat() cannot find it... */
199 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
200 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
201 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
204 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
205 # ifdef I_SYS_SECURITY
206 # include <sys/security.h>
210 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
213 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
217 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
219 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
223 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
224 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
225 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
228 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
230 const Uid_t ruid = getuid();
231 const Uid_t euid = geteuid();
232 const Gid_t rgid = getgid();
233 const Gid_t egid = getegid();
236 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
237 Perl_croak(aTHX_ "switching effective uid is not implemented");
240 if (setreuid(euid, ruid))
243 if (setresuid(euid, ruid, (Uid_t)-1))
246 /* diag_listed_as: entering effective %s failed */
247 Perl_croak(aTHX_ "entering effective uid failed");
250 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
251 Perl_croak(aTHX_ "switching effective gid is not implemented");
254 if (setregid(egid, rgid))
257 if (setresgid(egid, rgid, (Gid_t)-1))
260 /* diag_listed_as: entering effective %s failed */
261 Perl_croak(aTHX_ "entering effective gid failed");
264 res = access(path, mode);
267 if (setreuid(ruid, euid))
270 if (setresuid(ruid, euid, (Uid_t)-1))
273 /* diag_listed_as: leaving effective %s failed */
274 Perl_croak(aTHX_ "leaving effective uid failed");
277 if (setregid(rgid, egid))
280 if (setresgid(rgid, egid, (Gid_t)-1))
283 /* diag_listed_as: leaving effective %s failed */
284 Perl_croak(aTHX_ "leaving effective gid failed");
288 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
295 const char * const tmps = POPpconstx;
296 const I32 gimme = GIMME_V;
297 const char *mode = "r";
300 if (PL_op->op_private & OPpOPEN_IN_RAW)
302 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
304 fp = PerlProc_popen(tmps, mode);
306 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
308 PerlIO_apply_layers(aTHX_ fp,mode,type);
310 if (gimme == G_VOID) {
312 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
315 else if (gimme == G_SCALAR) {
316 ENTER_with_name("backtick");
318 PL_rs = &PL_sv_undef;
319 sv_setpvs(TARG, ""); /* note that this preserves previous buffer */
320 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
322 LEAVE_with_name("backtick");
328 SV * const sv = newSV(79);
329 if (sv_gets(sv, fp, 0) == NULL) {
334 if (SvLEN(sv) - SvCUR(sv) > 20) {
335 SvPV_shrink_to_cur(sv);
340 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
341 TAINT; /* "I believe that this is not gratuitous!" */
344 STATUS_NATIVE_CHILD_SET(-1);
345 if (gimme == G_SCALAR)
356 GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs;
360 /* make a copy of the pattern if it is gmagical, to ensure that magic
361 * is called once and only once */
362 if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs));
364 tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL));
366 if (PL_op->op_flags & OPf_SPECIAL) {
367 /* call Perl-level glob function instead. Stack args are:
369 * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
378 /* Note that we only ever get here if File::Glob fails to load
379 * without at the same time croaking, for some reason, or if
380 * perl was built with PERL_EXTERNAL_GLOB */
382 ENTER_with_name("glob");
387 * The external globbing program may use things we can't control,
388 * so for security reasons we must assume the worst.
391 taint_proper(PL_no_security, "glob");
395 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
398 SAVESPTR(PL_rs); /* This is not permanent, either. */
399 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
402 *SvPVX(PL_rs) = '\n';
406 result = do_readline();
407 LEAVE_with_name("glob");
413 PL_last_in_gv = cGVOP_gv;
414 return do_readline();
424 do_join(TARG, &PL_sv_no, MARK, SP);
428 else if (SP == MARK) {
435 if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
438 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
439 /* well-formed exception supplied */
442 SV * const errsv = ERRSV;
445 if (SvGMAGICAL(errsv)) {
446 exsv = sv_newmortal();
447 sv_setsv_nomg(exsv, errsv);
451 else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) {
452 exsv = sv_newmortal();
453 sv_setsv_nomg(exsv, errsv);
454 sv_catpvs(exsv, "\t...caught");
457 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
460 if (SvROK(exsv) && !PL_warnhook)
461 Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
473 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
475 if (SP - MARK != 1) {
477 do_join(TARG, &PL_sv_no, MARK, SP);
485 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
486 /* well-formed exception supplied */
489 SV * const errsv = ERRSV;
493 if (sv_isobject(exsv)) {
494 HV * const stash = SvSTASH(SvRV(exsv));
495 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
497 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
498 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
505 call_sv(MUTABLE_SV(GvCV(gv)),
506 G_SCALAR|G_EVAL|G_KEEPERR);
507 exsv = sv_mortalcopy(*PL_stack_sp--);
511 else if (SvPOK(errsv) && SvCUR(errsv)) {
512 exsv = sv_mortalcopy(errsv);
513 sv_catpvs(exsv, "\t...propagated");
516 exsv = newSVpvs_flags("Died", SVs_TEMP);
520 NOT_REACHED; /* NOTREACHED */
521 return NULL; /* avoid missing return from non-void function warning */
527 Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv,
528 const MAGIC *const mg, const U32 flags, U32 argc, ...)
533 PERL_ARGS_ASSERT_TIED_METHOD;
535 /* Ensure that our flag bits do not overlap. */
536 STATIC_ASSERT_STMT((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
537 STATIC_ASSERT_STMT((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
538 STATIC_ASSERT_STMT((TIED_METHOD_SAY & G_WANT) == 0);
540 PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
541 PUSHSTACKi(PERLSI_MAGIC);
542 EXTEND(SP, argc+1); /* object + args */
544 PUSHs(SvTIED_obj(sv, mg));
545 if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
546 Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
550 const U32 mortalize_not_needed
551 = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
553 va_start(args, argc);
555 SV *const arg = va_arg(args, SV *);
556 if(mortalize_not_needed)
565 ENTER_with_name("call_tied_method");
566 if (flags & TIED_METHOD_SAY) {
567 /* local $\ = "\n" */
568 SAVEGENERICSV(PL_ors_sv);
569 PL_ors_sv = newSVpvs("\n");
571 ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED);
576 if (ret_args) { /* copy results back to original stack */
577 EXTEND(sp, ret_args);
578 Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
582 LEAVE_with_name("call_tied_method");
586 #define tied_method0(a,b,c,d) \
587 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
588 #define tied_method1(a,b,c,d,e) \
589 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
590 #define tied_method2(a,b,c,d,e,f) \
591 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
604 GV * const gv = MUTABLE_GV(*++MARK);
606 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
607 DIE(aTHX_ PL_no_usym, "filehandle");
609 if ((io = GvIOp(gv))) {
611 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
614 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
615 "Opening dirhandle %"HEKf" also as a file",
616 HEKfARG(GvENAME_HEK(gv)));
618 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
620 /* Method's args are same as ours ... */
621 /* ... except handle is replaced by the object */
622 return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg,
623 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
635 tmps = SvPV_const(sv, len);
636 ok = do_open6(gv, tmps, len, NULL, MARK+1, (SP-MARK));
639 PUSHi( (I32)PL_forkprocess );
640 else if (PL_forkprocess == 0) /* we are a new child */
651 MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
657 IO * const io = GvIO(gv);
659 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
661 return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg);
665 PUSHs(boolSV(do_close(gv, TRUE)));
677 GV * const wgv = MUTABLE_GV(POPs);
678 GV * const rgv = MUTABLE_GV(POPs);
680 assert (isGV_with_GP(rgv));
681 assert (isGV_with_GP(wgv));
684 do_close(rgv, FALSE);
688 do_close(wgv, FALSE);
690 if (PerlProc_pipe(fd) < 0)
693 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
694 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
695 IoOFP(rstio) = IoIFP(rstio);
696 IoIFP(wstio) = IoOFP(wstio);
697 IoTYPE(rstio) = IoTYPE_RDONLY;
698 IoTYPE(wstio) = IoTYPE_WRONLY;
700 if (!IoIFP(rstio) || !IoOFP(wstio)) {
702 PerlIO_close(IoIFP(rstio));
704 PerlLIO_close(fd[0]);
706 PerlIO_close(IoOFP(wstio));
708 PerlLIO_close(fd[1]);
711 #if defined(HAS_FCNTL) && defined(F_SETFD)
712 /* ensure close-on-exec */
713 if ((fcntl(fd[0], F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
714 (fcntl(fd[1], F_SETFD,fd[1] > PL_maxsysfd) < 0))
722 DIE(aTHX_ PL_no_func, "pipe");
736 gv = MUTABLE_GV(POPs);
740 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
742 return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg);
745 if (io && IoDIRP(io)) {
746 #if defined(HAS_DIRFD) || defined(HAS_DIR_DD_FD)
747 PUSHi(my_dirfd(IoDIRP(io)));
749 #elif defined(ENOTSUP)
750 errno = ENOTSUP; /* Operation not supported */
752 #elif defined(EOPNOTSUPP)
753 errno = EOPNOTSUPP; /* Operation not supported on socket */
756 errno = EINVAL; /* Invalid argument */
761 if (!io || !(fp = IoIFP(io))) {
762 /* Can't do this because people seem to do things like
763 defined(fileno($foo)) to check whether $foo is a valid fh.
770 PUSHi(PerlIO_fileno(fp));
781 if (MAXARG < 1 || (!TOPs && !POPs)) {
782 anum = PerlLIO_umask(022);
783 /* setting it to 022 between the two calls to umask avoids
784 * to have a window where the umask is set to 0 -- meaning
785 * that another thread could create world-writeable files. */
787 (void)PerlLIO_umask(anum);
790 anum = PerlLIO_umask(POPi);
791 TAINT_PROPER("umask");
794 /* Only DIE if trying to restrict permissions on "user" (self).
795 * Otherwise it's harmless and more useful to just return undef
796 * since 'group' and 'other' concepts probably don't exist here. */
797 if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
798 DIE(aTHX_ "umask not implemented");
799 XPUSHs(&PL_sv_undef);
818 gv = MUTABLE_GV(POPs);
822 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
824 /* This takes advantage of the implementation of the varargs
825 function, which I don't think that the optimiser will be able to
826 figure out. Although, as it's a static function, in theory it
828 return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg,
829 G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
830 discp ? 1 : 0, discp);
834 if (!io || !(fp = IoIFP(io))) {
836 SETERRNO(EBADF,RMS_IFI);
843 const char *d = NULL;
846 d = SvPV_const(discp, len);
847 mode = mode_from_discipline(d, len);
848 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
849 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
850 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
871 const I32 markoff = MARK - PL_stack_base;
872 const char *methname;
873 int how = PERL_MAGIC_tied;
877 switch(SvTYPE(varsv)) {
881 methname = "TIEHASH";
882 if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
883 HvLAZYDEL_off(varsv);
884 hv_free_ent((HV *)varsv, entry);
886 HvEITER_set(MUTABLE_HV(varsv), 0);
890 methname = "TIEARRAY";
891 if (!AvREAL(varsv)) {
893 Perl_croak(aTHX_ "Cannot tie unreifiable array");
894 av_clear((AV *)varsv);
901 if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
902 methname = "TIEHANDLE";
903 how = PERL_MAGIC_tiedscalar;
904 /* For tied filehandles, we apply tiedscalar magic to the IO
905 slot of the GP rather than the GV itself. AMS 20010812 */
907 GvIOp(varsv) = newIO();
908 varsv = MUTABLE_SV(GvIOp(varsv));
911 if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
912 vivify_defelem(varsv);
913 varsv = LvTARG(varsv);
917 methname = "TIESCALAR";
918 how = PERL_MAGIC_tiedscalar;
922 if (sv_isobject(*MARK)) { /* Calls GET magic. */
923 ENTER_with_name("call_TIE");
924 PUSHSTACKi(PERLSI_MAGIC);
926 EXTEND(SP,(I32)items);
930 call_method(methname, G_SCALAR);
933 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
934 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
935 * wrong error message, and worse case, supreme action at a distance.
936 * (Sorry obfuscation writers. You're not going to be given this one.)
938 stash = gv_stashsv(*MARK, 0);
939 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
940 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
941 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
943 ENTER_with_name("call_TIE");
944 PUSHSTACKi(PERLSI_MAGIC);
946 EXTEND(SP,(I32)items);
950 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
956 if (sv_isobject(sv)) {
957 sv_unmagic(varsv, how);
958 /* Croak if a self-tie on an aggregate is attempted. */
959 if (varsv == SvRV(sv) &&
960 (SvTYPE(varsv) == SVt_PVAV ||
961 SvTYPE(varsv) == SVt_PVHV))
963 "Self-ties of arrays and hashes are not supported");
964 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
966 LEAVE_with_name("call_TIE");
967 SP = PL_stack_base + markoff;
973 /* also used for: pp_dbmclose() */
980 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
981 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
983 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
986 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
987 !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
989 if ((mg = SvTIED_mg(sv, how))) {
990 SV * const obj = SvRV(SvTIED_obj(sv, mg));
992 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
994 if (gv && isGV(gv) && (cv = GvCV(gv))) {
996 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
997 mXPUSHi(SvREFCNT(obj) - 1);
999 ENTER_with_name("call_UNTIE");
1000 call_sv(MUTABLE_SV(cv), G_VOID);
1001 LEAVE_with_name("call_UNTIE");
1004 else if (mg && SvREFCNT(obj) > 1) {
1005 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
1006 "untie attempted while %"UVuf" inner references still exist",
1007 (UV)SvREFCNT(obj) - 1 ) ;
1011 sv_unmagic(sv, how) ;
1020 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1021 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1023 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1026 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1027 !(sv = defelem_target(sv, NULL))) goto ret_undef;
1029 if ((mg = SvTIED_mg(sv, how))) {
1030 SETs(SvTIED_obj(sv, mg));
1031 return NORMAL; /* PUTBACK not needed, pp_tied never moves SP */
1045 HV * const hv = MUTABLE_HV(POPs);
1046 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1047 stash = gv_stashsv(sv, 0);
1048 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1050 require_pv("AnyDBM_File.pm");
1052 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1053 DIE(aTHX_ "No dbm on this machine");
1063 mPUSHu(O_RDWR|O_CREAT);
1067 if (!SvOK(right)) right = &PL_sv_no;
1071 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1074 if (!sv_isobject(TOPs)) {
1082 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1084 if (sv_isobject(TOPs))
1089 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1090 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1107 struct timeval timebuf;
1108 struct timeval *tbuf = &timebuf;
1111 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1116 # if BYTEORDER & 0xf0000
1117 # define ORDERBYTE (0x88888888 - BYTEORDER)
1119 # define ORDERBYTE (0x4444 - BYTEORDER)
1125 for (i = 1; i <= 3; i++) {
1126 SV * const sv = SP[i];
1130 if (SvREADONLY(sv)) {
1131 if (!(SvPOK(sv) && SvCUR(sv) == 0))
1132 Perl_croak_no_modify();
1134 else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
1137 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1138 "Non-string passed as bitmask");
1139 SvPV_force_nomg_nolen(sv); /* force string conversion */
1146 /* little endians can use vecs directly */
1147 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1154 masksize = NFDBITS / NBBY;
1156 masksize = sizeof(long); /* documented int, everyone seems to use long */
1158 Zero(&fd_sets[0], 4, char*);
1161 # if SELECT_MIN_BITS == 1
1162 growsize = sizeof(fd_set);
1164 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1165 # undef SELECT_MIN_BITS
1166 # define SELECT_MIN_BITS __FD_SETSIZE
1168 /* If SELECT_MIN_BITS is greater than one we most probably will want
1169 * to align the sizes with SELECT_MIN_BITS/8 because for example
1170 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1171 * UNIX, Solaris, Darwin) the smallest quantum select() operates
1172 * on (sets/tests/clears bits) is 32 bits. */
1173 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1179 value = SvNV_nomg(sv);
1182 timebuf.tv_sec = (long)value;
1183 value -= (NV)timebuf.tv_sec;
1184 timebuf.tv_usec = (long)(value * 1000000.0);
1189 for (i = 1; i <= 3; i++) {
1191 if (!SvOK(sv) || SvCUR(sv) == 0) {
1198 Sv_Grow(sv, growsize);
1202 while (++j <= growsize) {
1206 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1208 Newx(fd_sets[i], growsize, char);
1209 for (offset = 0; offset < growsize; offset += masksize) {
1210 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1211 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1214 fd_sets[i] = SvPVX(sv);
1218 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1219 /* Can't make just the (void*) conditional because that would be
1220 * cpp #if within cpp macro, and not all compilers like that. */
1221 nfound = PerlSock_select(
1223 (Select_fd_set_t) fd_sets[1],
1224 (Select_fd_set_t) fd_sets[2],
1225 (Select_fd_set_t) fd_sets[3],
1226 (void*) tbuf); /* Workaround for compiler bug. */
1228 nfound = PerlSock_select(
1230 (Select_fd_set_t) fd_sets[1],
1231 (Select_fd_set_t) fd_sets[2],
1232 (Select_fd_set_t) fd_sets[3],
1235 for (i = 1; i <= 3; i++) {
1238 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1240 for (offset = 0; offset < growsize; offset += masksize) {
1241 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1242 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1244 Safefree(fd_sets[i]);
1251 if (GIMME_V == G_ARRAY && tbuf) {
1252 value = (NV)(timebuf.tv_sec) +
1253 (NV)(timebuf.tv_usec) / 1000000.0;
1258 DIE(aTHX_ "select not implemented");
1266 =for apidoc setdefout
1268 Sets PL_defoutgv, the default file handle for output, to the passed in
1269 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1270 count of the passed in typeglob is increased by one, and the reference count
1271 of the typeglob that PL_defoutgv points to is decreased by one.
1277 Perl_setdefout(pTHX_ GV *gv)
1279 PERL_ARGS_ASSERT_SETDEFOUT;
1280 SvREFCNT_inc_simple_void_NN(gv);
1281 SvREFCNT_dec(PL_defoutgv);
1289 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1290 GV * egv = GvEGVx(PL_defoutgv);
1295 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1296 gvp = hv && HvENAME(hv)
1297 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1299 if (gvp && *gvp == egv) {
1300 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1304 mXPUSHs(newRV(MUTABLE_SV(egv)));
1308 if (!GvIO(newdefout))
1309 gv_IOadd(newdefout);
1310 setdefout(newdefout);
1320 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1321 IO *const io = GvIO(gv);
1327 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1329 const U32 gimme = GIMME_V;
1330 Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1331 if (gimme == G_SCALAR) {
1333 SvSetMagicSV_nosteal(TARG, TOPs);
1338 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1339 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1341 SETERRNO(EBADF,RMS_IFI);
1345 sv_setpvs(TARG, " ");
1346 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1347 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1348 /* Find out how many bytes the char needs */
1349 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1352 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1353 SvCUR_set(TARG,1+len);
1357 else SvUTF8_off(TARG);
1363 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1366 const I32 gimme = GIMME_V;
1368 PERL_ARGS_ASSERT_DOFORM;
1371 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1376 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1377 PUSHFORMAT(cx, retop);
1378 if (CvDEPTH(cv) >= 2) {
1379 PERL_STACK_OVERFLOW_CHECK();
1380 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1383 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1385 setdefout(gv); /* locally select filehandle so $% et al work */
1403 gv = MUTABLE_GV(POPs);
1420 tmpsv = sv_newmortal();
1421 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1422 DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
1424 IoFLAGS(io) &= ~IOf_DIDTOP;
1425 RETURNOP(doform(cv,gv,PL_op->op_next));
1431 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1432 IO * const io = GvIOp(gv);
1439 bool is_return = cBOOL(PL_op->op_type == OP_RETURN);
1441 if (is_return || !io || !(ofp = IoOFP(io)))
1444 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1445 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1447 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1448 PL_formtarget != PL_toptarget)
1452 if (!IoTOP_GV(io)) {
1455 if (!IoTOP_NAME(io)) {
1457 if (!IoFMT_NAME(io))
1458 IoFMT_NAME(io) = savepv(GvNAME(gv));
1459 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1460 HEKfARG(GvNAME_HEK(gv))));
1461 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1462 if ((topgv && GvFORM(topgv)) ||
1463 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1464 IoTOP_NAME(io) = savesvpv(topname);
1466 IoTOP_NAME(io) = savepvs("top");
1468 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1469 if (!topgv || !GvFORM(topgv)) {
1470 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1473 IoTOP_GV(io) = topgv;
1475 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1476 I32 lines = IoLINES_LEFT(io);
1477 const char *s = SvPVX_const(PL_formtarget);
1478 if (lines <= 0) /* Yow, header didn't even fit!!! */
1480 while (lines-- > 0) {
1481 s = strchr(s, '\n');
1487 const STRLEN save = SvCUR(PL_formtarget);
1488 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1489 do_print(PL_formtarget, ofp);
1490 SvCUR_set(PL_formtarget, save);
1491 sv_chop(PL_formtarget, s);
1492 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1495 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1496 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1497 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1499 PL_formtarget = PL_toptarget;
1500 IoFLAGS(io) |= IOf_DIDTOP;
1502 assert(fgv); /* IoTOP_GV(io) should have been set above */
1505 SV * const sv = sv_newmortal();
1506 gv_efullname4(sv, fgv, NULL, FALSE);
1507 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1509 return doform(cv, gv, PL_op);
1513 POPBLOCK(cx,PL_curpm);
1514 retop = cx->blk_sub.retop;
1516 SP = newsp; /* ignore retval of formline */
1520 /* XXX the semantics of doing 'return' in a format aren't documented.
1521 * Currently we ignore any args to 'return' and just return
1522 * a single undef in both scalar and list contexts
1524 PUSHs(&PL_sv_undef);
1525 else if (!io || !(fp = IoOFP(io))) {
1526 if (io && IoIFP(io))
1527 report_wrongway_fh(gv, '<');
1533 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1534 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1536 if (!do_print(PL_formtarget, fp))
1539 FmLINES(PL_formtarget) = 0;
1540 SvCUR_set(PL_formtarget, 0);
1541 *SvEND(PL_formtarget) = '\0';
1542 if (IoFLAGS(io) & IOf_FLUSH)
1543 (void)PerlIO_flush(fp);
1547 PL_formtarget = PL_bodytarget;
1548 PERL_UNUSED_VAR(gimme);
1554 dSP; dMARK; dORIGMARK;
1558 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1559 IO *const io = GvIO(gv);
1561 /* Treat empty list as "" */
1562 if (MARK == SP) XPUSHs(&PL_sv_no);
1565 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1567 if (MARK == ORIGMARK) {
1570 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1573 return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1575 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1582 SETERRNO(EBADF,RMS_IFI);
1585 else if (!(fp = IoOFP(io))) {
1587 report_wrongway_fh(gv, '<');
1588 else if (ckWARN(WARN_CLOSED))
1590 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1594 SV *sv = sv_newmortal();
1595 do_sprintf(sv, SP - MARK, MARK + 1);
1596 if (!do_print(sv, fp))
1599 if (IoFLAGS(io) & IOf_FLUSH)
1600 if (PerlIO_flush(fp) == EOF)
1609 PUSHs(&PL_sv_undef);
1616 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1617 const int mode = POPi;
1618 SV * const sv = POPs;
1619 GV * const gv = MUTABLE_GV(POPs);
1622 /* Need TIEHANDLE method ? */
1623 const char * const tmps = SvPV_const(sv, len);
1624 if (do_open_raw(gv, tmps, len, mode, perm)) {
1625 IoLINES(GvIOp(gv)) = 0;
1629 PUSHs(&PL_sv_undef);
1635 /* also used for: pp_read() and pp_recv() (where supported) */
1639 dSP; dMARK; dORIGMARK; dTARGET;
1653 bool charstart = FALSE;
1654 STRLEN charskip = 0;
1656 GV * const gv = MUTABLE_GV(*++MARK);
1659 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1660 && gv && (io = GvIO(gv)) )
1662 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1664 return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1665 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1674 sv_setpvs(bufsv, "");
1675 length = SvIVx(*++MARK);
1677 DIE(aTHX_ "Negative length");
1680 offset = SvIVx(*++MARK);
1684 if (!io || !IoIFP(io)) {
1686 SETERRNO(EBADF,RMS_IFI);
1690 /* Note that fd can here validly be -1, don't check it yet. */
1691 fd = PerlIO_fileno(IoIFP(io));
1693 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1694 buffer = SvPVutf8_force(bufsv, blen);
1695 /* UTF-8 may not have been set if they are all low bytes */
1700 buffer = SvPV_force(bufsv, blen);
1701 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1703 if (DO_UTF8(bufsv)) {
1704 blen = sv_len_utf8_nomg(bufsv);
1713 if (PL_op->op_type == OP_RECV) {
1714 Sock_size_t bufsize;
1715 char namebuf[MAXPATHLEN];
1717 SETERRNO(EBADF,SS_IVCHAN);
1720 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1721 bufsize = sizeof (struct sockaddr_in);
1723 bufsize = sizeof namebuf;
1725 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1729 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1730 /* 'offset' means 'flags' here */
1731 count = PerlSock_recvfrom(fd, buffer, length, offset,
1732 (struct sockaddr *)namebuf, &bufsize);
1735 /* MSG_TRUNC can give oversized count; quietly lose it */
1738 SvCUR_set(bufsv, count);
1739 *SvEND(bufsv) = '\0';
1740 (void)SvPOK_only(bufsv);
1744 /* This should not be marked tainted if the fp is marked clean */
1745 if (!(IoFLAGS(io) & IOf_UNTAINT))
1746 SvTAINTED_on(bufsv);
1748 #if defined(__CYGWIN__)
1749 /* recvfrom() on cygwin doesn't set bufsize at all for
1750 connected sockets, leaving us with trash in the returned
1751 name, so use the same test as the Win32 code to check if it
1752 wasn't set, and set it [perl #118843] */
1753 if (bufsize == sizeof namebuf)
1756 sv_setpvn(TARG, namebuf, bufsize);
1762 if (-offset > (SSize_t)blen)
1763 DIE(aTHX_ "Offset outside string");
1766 if (DO_UTF8(bufsv)) {
1767 /* convert offset-as-chars to offset-as-bytes */
1768 if (offset >= (SSize_t)blen)
1769 offset += SvCUR(bufsv) - blen;
1771 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1775 /* Reestablish the fd in case it shifted from underneath us. */
1776 fd = PerlIO_fileno(IoIFP(io));
1778 orig_size = SvCUR(bufsv);
1779 /* Allocating length + offset + 1 isn't perfect in the case of reading
1780 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1782 (should be 2 * length + offset + 1, or possibly something longer if
1783 IN_ENCODING Is true) */
1784 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1785 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1786 Zero(buffer+orig_size, offset-orig_size, char);
1788 buffer = buffer + offset;
1790 read_target = bufsv;
1792 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1793 concatenate it to the current buffer. */
1795 /* Truncate the existing buffer to the start of where we will be
1797 SvCUR_set(bufsv, offset);
1799 read_target = sv_newmortal();
1800 SvUPGRADE(read_target, SVt_PV);
1801 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1804 if (PL_op->op_type == OP_SYSREAD) {
1805 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1806 if (IoTYPE(io) == IoTYPE_SOCKET) {
1808 SETERRNO(EBADF,SS_IVCHAN);
1812 count = PerlSock_recv(fd, buffer, length, 0);
1818 SETERRNO(EBADF,RMS_IFI);
1822 count = PerlLIO_read(fd, buffer, length);
1827 count = PerlIO_read(IoIFP(io), buffer, length);
1828 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1829 if (count == 0 && PerlIO_error(IoIFP(io)))
1833 if (IoTYPE(io) == IoTYPE_WRONLY)
1834 report_wrongway_fh(gv, '>');
1837 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1838 *SvEND(read_target) = '\0';
1839 (void)SvPOK_only(read_target);
1840 if (fp_utf8 && !IN_BYTES) {
1841 /* Look at utf8 we got back and count the characters */
1842 const char *bend = buffer + count;
1843 while (buffer < bend) {
1845 skip = UTF8SKIP(buffer);
1848 if (buffer - charskip + skip > bend) {
1849 /* partial character - try for rest of it */
1850 length = skip - (bend-buffer);
1851 offset = bend - SvPVX_const(bufsv);
1863 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1864 provided amount read (count) was what was requested (length)
1866 if (got < wanted && count == length) {
1867 length = wanted - got;
1868 offset = bend - SvPVX_const(bufsv);
1871 /* return value is character count */
1875 else if (buffer_utf8) {
1876 /* Let svcatsv upgrade the bytes we read in to utf8.
1877 The buffer is a mortal so will be freed soon. */
1878 sv_catsv_nomg(bufsv, read_target);
1881 /* This should not be marked tainted if the fp is marked clean */
1882 if (!(IoFLAGS(io) & IOf_UNTAINT))
1883 SvTAINTED_on(bufsv);
1894 /* also used for: pp_send() where defined */
1898 dSP; dMARK; dORIGMARK; dTARGET;
1903 STRLEN orig_blen_bytes;
1904 const int op_type = PL_op->op_type;
1907 GV *const gv = MUTABLE_GV(*++MARK);
1908 IO *const io = GvIO(gv);
1911 if (op_type == OP_SYSWRITE && io) {
1912 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1914 if (MARK == SP - 1) {
1916 mXPUSHi(sv_len(sv));
1920 return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1921 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1931 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1933 if (io && IoIFP(io))
1934 report_wrongway_fh(gv, '<');
1937 SETERRNO(EBADF,RMS_IFI);
1940 fd = PerlIO_fileno(IoIFP(io));
1942 SETERRNO(EBADF,SS_IVCHAN);
1947 /* Do this first to trigger any overloading. */
1948 buffer = SvPV_const(bufsv, blen);
1949 orig_blen_bytes = blen;
1950 doing_utf8 = DO_UTF8(bufsv);
1952 if (PerlIO_isutf8(IoIFP(io))) {
1953 if (!SvUTF8(bufsv)) {
1954 /* We don't modify the original scalar. */
1955 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1956 buffer = (char *) tmpbuf;
1960 else if (doing_utf8) {
1961 STRLEN tmplen = blen;
1962 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1965 buffer = (char *) tmpbuf;
1969 assert((char *)result == buffer);
1970 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1975 if (op_type == OP_SEND) {
1976 const int flags = SvIVx(*++MARK);
1979 char * const sockbuf = SvPVx(*++MARK, mlen);
1980 retval = PerlSock_sendto(fd, buffer, blen,
1981 flags, (struct sockaddr *)sockbuf, mlen);
1984 retval = PerlSock_send(fd, buffer, blen, flags);
1990 Size_t length = 0; /* This length is in characters. */
1996 /* The SV is bytes, and we've had to upgrade it. */
1997 blen_chars = orig_blen_bytes;
1999 /* The SV really is UTF-8. */
2000 /* Don't call sv_len_utf8 on a magical or overloaded
2001 scalar, as we might get back a different result. */
2002 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
2009 length = blen_chars;
2011 #if Size_t_size > IVSIZE
2012 length = (Size_t)SvNVx(*++MARK);
2014 length = (Size_t)SvIVx(*++MARK);
2016 if ((SSize_t)length < 0) {
2018 DIE(aTHX_ "Negative length");
2023 offset = SvIVx(*++MARK);
2025 if (-offset > (IV)blen_chars) {
2027 DIE(aTHX_ "Offset outside string");
2029 offset += blen_chars;
2030 } else if (offset > (IV)blen_chars) {
2032 DIE(aTHX_ "Offset outside string");
2036 if (length > blen_chars - offset)
2037 length = blen_chars - offset;
2039 /* Here we convert length from characters to bytes. */
2040 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
2041 /* Either we had to convert the SV, or the SV is magical, or
2042 the SV has overloading, in which case we can't or mustn't
2043 or mustn't call it again. */
2045 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
2046 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
2048 /* It's a real UTF-8 SV, and it's not going to change under
2049 us. Take advantage of any cache. */
2051 I32 len_I32 = length;
2053 /* Convert the start and end character positions to bytes.
2054 Remember that the second argument to sv_pos_u2b is relative
2056 sv_pos_u2b(bufsv, &start, &len_I32);
2063 buffer = buffer+offset;
2065 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2066 if (IoTYPE(io) == IoTYPE_SOCKET) {
2067 retval = PerlSock_send(fd, buffer, length, 0);
2072 /* See the note at doio.c:do_print about filesize limits. --jhi */
2073 retval = PerlLIO_write(fd, buffer, length);
2081 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2084 #if Size_t_size > IVSIZE
2104 * in Perl 5.12 and later, the additional parameter is a bitmask:
2107 * 2 = eof() <- ARGV magic
2109 * I'll rely on the compiler's trace flow analysis to decide whether to
2110 * actually assign this out here, or punt it into the only block where it is
2111 * used. Doing it out here is DRY on the condition logic.
2116 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2122 if (PL_op->op_flags & OPf_SPECIAL) {
2123 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2127 gv = PL_last_in_gv; /* eof */
2135 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2136 return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2139 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2140 if (io && !IoIFP(io)) {
2141 if ((IoFLAGS(io) & IOf_START) && av_tindex(GvAVn(gv)) < 0) {
2144 IoFLAGS(io) &= ~IOf_START;
2145 do_open6(gv, "-", 1, NULL, NULL, 0);
2153 *svp = newSVpvs("-");
2155 else if (!nextargv(gv, FALSE))
2160 PUSHs(boolSV(do_eof(gv)));
2170 if (MAXARG != 0 && (TOPs || POPs))
2171 PL_last_in_gv = MUTABLE_GV(POPs);
2178 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2180 return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2185 SETERRNO(EBADF,RMS_IFI);
2190 #if LSEEKSIZE > IVSIZE
2191 PUSHn( do_tell(gv) );
2193 PUSHi( do_tell(gv) );
2199 /* also used for: pp_seek() */
2204 const int whence = POPi;
2205 #if LSEEKSIZE > IVSIZE
2206 const Off_t offset = (Off_t)SvNVx(POPs);
2208 const Off_t offset = (Off_t)SvIVx(POPs);
2211 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2212 IO *const io = GvIO(gv);
2215 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2217 #if LSEEKSIZE > IVSIZE
2218 SV *const offset_sv = newSVnv((NV) offset);
2220 SV *const offset_sv = newSViv(offset);
2223 return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2228 if (PL_op->op_type == OP_SEEK)
2229 PUSHs(boolSV(do_seek(gv, offset, whence)));
2231 const Off_t sought = do_sysseek(gv, offset, whence);
2233 PUSHs(&PL_sv_undef);
2235 SV* const sv = sought ?
2236 #if LSEEKSIZE > IVSIZE
2241 : newSVpvn(zero_but_true, ZBTLEN);
2251 /* There seems to be no consensus on the length type of truncate()
2252 * and ftruncate(), both off_t and size_t have supporters. In
2253 * general one would think that when using large files, off_t is
2254 * at least as wide as size_t, so using an off_t should be okay. */
2255 /* XXX Configure probe for the length type of *truncate() needed XXX */
2258 #if Off_t_size > IVSIZE
2263 /* Checking for length < 0 is problematic as the type might or
2264 * might not be signed: if it is not, clever compilers will moan. */
2265 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2268 SV * const sv = POPs;
2273 if (PL_op->op_flags & OPf_SPECIAL
2274 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2275 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2282 TAINT_PROPER("truncate");
2283 if (!(fp = IoIFP(io))) {
2287 int fd = PerlIO_fileno(fp);
2289 SETERRNO(EBADF,RMS_IFI);
2293 SETERRNO(EINVAL, LIB_INVARG);
2298 if (ftruncate(fd, len) < 0)
2300 if (my_chsize(fd, len) < 0)
2308 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2309 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2310 goto do_ftruncate_io;
2313 const char * const name = SvPV_nomg_const_nolen(sv);
2314 TAINT_PROPER("truncate");
2316 if (truncate(name, len) < 0)
2323 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
2324 mode |= O_LARGEFILE; /* Transparently largefiley. */
2327 /* On open(), the Win32 CRT tries to seek around text
2328 * files using 32-bit offsets, which causes the open()
2329 * to fail on large files, so open in binary mode.
2333 tmpfd = PerlLIO_open(name, mode);
2338 if (my_chsize(tmpfd, len) < 0)
2340 PerlLIO_close(tmpfd);
2349 SETERRNO(EBADF,RMS_IFI);
2355 /* also used for: pp_fcntl() */
2360 SV * const argsv = POPs;
2361 const unsigned int func = POPu;
2363 GV * const gv = MUTABLE_GV(POPs);
2364 IO * const io = GvIOn(gv);
2370 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2374 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2377 s = SvPV_force(argsv, len);
2378 need = IOCPARM_LEN(func);
2380 s = Sv_Grow(argsv, need + 1);
2381 SvCUR_set(argsv, need);
2384 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2387 retval = SvIV(argsv);
2388 s = INT2PTR(char*,retval); /* ouch */
2391 optype = PL_op->op_type;
2392 TAINT_PROPER(PL_op_desc[optype]);
2394 if (optype == OP_IOCTL)
2396 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2398 DIE(aTHX_ "ioctl is not implemented");
2402 DIE(aTHX_ "fcntl is not implemented");
2404 #if defined(OS2) && defined(__EMX__)
2405 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2407 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2411 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2413 if (s[SvCUR(argsv)] != 17)
2414 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2416 s[SvCUR(argsv)] = 0; /* put our null back */
2417 SvSETMAGIC(argsv); /* Assume it has changed */
2426 PUSHp(zero_but_true, ZBTLEN);
2437 const int argtype = POPi;
2438 GV * const gv = MUTABLE_GV(POPs);
2439 IO *const io = GvIO(gv);
2440 PerlIO *const fp = io ? IoIFP(io) : NULL;
2442 /* XXX Looks to me like io is always NULL at this point */
2444 (void)PerlIO_flush(fp);
2445 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2450 SETERRNO(EBADF,RMS_IFI);
2455 DIE(aTHX_ PL_no_func, "flock");
2466 const int protocol = POPi;
2467 const int type = POPi;
2468 const int domain = POPi;
2469 GV * const gv = MUTABLE_GV(POPs);
2470 IO * const io = GvIOn(gv);
2474 do_close(gv, FALSE);
2476 TAINT_PROPER("socket");
2477 fd = PerlSock_socket(domain, type, protocol);
2479 SETERRNO(EBADF,RMS_IFI);
2482 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2483 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2484 IoTYPE(io) = IoTYPE_SOCKET;
2485 if (!IoIFP(io) || !IoOFP(io)) {
2486 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2487 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2488 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2491 #if defined(HAS_FCNTL) && defined(F_SETFD)
2492 if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) /* ensure close-on-exec */
2502 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2505 const int protocol = POPi;
2506 const int type = POPi;
2507 const int domain = POPi;
2509 GV * const gv2 = MUTABLE_GV(POPs);
2510 IO * const io2 = GvIOn(gv2);
2511 GV * const gv1 = MUTABLE_GV(POPs);
2512 IO * const io1 = GvIOn(gv1);
2515 do_close(gv1, FALSE);
2517 do_close(gv2, FALSE);
2519 TAINT_PROPER("socketpair");
2520 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2522 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2523 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2524 IoTYPE(io1) = IoTYPE_SOCKET;
2525 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2526 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2527 IoTYPE(io2) = IoTYPE_SOCKET;
2528 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2529 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2530 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2531 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2532 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2533 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2534 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2537 #if defined(HAS_FCNTL) && defined(F_SETFD)
2538 /* ensure close-on-exec */
2539 if ((fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
2540 (fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd) < 0))
2546 DIE(aTHX_ PL_no_sock_func, "socketpair");
2552 /* also used for: pp_connect() */
2557 SV * const addrsv = POPs;
2558 /* OK, so on what platform does bind modify addr? */
2560 GV * const gv = MUTABLE_GV(POPs);
2561 IO * const io = GvIOn(gv);
2568 fd = PerlIO_fileno(IoIFP(io));
2572 addr = SvPV_const(addrsv, len);
2573 op_type = PL_op->op_type;
2574 TAINT_PROPER(PL_op_desc[op_type]);
2575 if ((op_type == OP_BIND
2576 ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
2577 : PerlSock_connect(fd, (struct sockaddr *)addr, len))
2585 SETERRNO(EBADF,SS_IVCHAN);
2592 const int backlog = POPi;
2593 GV * const gv = MUTABLE_GV(POPs);
2594 IO * const io = GvIOn(gv);
2599 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2606 SETERRNO(EBADF,SS_IVCHAN);
2614 char namebuf[MAXPATHLEN];
2615 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2616 Sock_size_t len = sizeof (struct sockaddr_in);
2618 Sock_size_t len = sizeof namebuf;
2620 GV * const ggv = MUTABLE_GV(POPs);
2621 GV * const ngv = MUTABLE_GV(POPs);
2624 IO * const gstio = GvIO(ggv);
2625 if (!gstio || !IoIFP(gstio))
2629 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2632 /* Some platforms indicate zero length when an AF_UNIX client is
2633 * not bound. Simulate a non-zero-length sockaddr structure in
2635 namebuf[0] = 0; /* sun_len */
2636 namebuf[1] = AF_UNIX; /* sun_family */
2644 do_close(ngv, FALSE);
2645 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2646 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2647 IoTYPE(nstio) = IoTYPE_SOCKET;
2648 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2649 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2650 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2651 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2654 #if defined(HAS_FCNTL) && defined(F_SETFD)
2655 if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) /* ensure close-on-exec */
2659 #ifdef __SCO_VERSION__
2660 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2663 PUSHp(namebuf, len);
2667 report_evil_fh(ggv);
2668 SETERRNO(EBADF,SS_IVCHAN);
2678 const int how = POPi;
2679 GV * const gv = MUTABLE_GV(POPs);
2680 IO * const io = GvIOn(gv);
2685 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2690 SETERRNO(EBADF,SS_IVCHAN);
2695 /* also used for: pp_gsockopt() */
2700 const int optype = PL_op->op_type;
2701 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2702 const unsigned int optname = (unsigned int) POPi;
2703 const unsigned int lvl = (unsigned int) POPi;
2704 GV * const gv = MUTABLE_GV(POPs);
2705 IO * const io = GvIOn(gv);
2712 fd = PerlIO_fileno(IoIFP(io));
2718 (void)SvPOK_only(sv);
2722 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2725 /* XXX Configure test: does getsockopt set the length properly? */
2734 #if defined(__SYMBIAN32__)
2735 # define SETSOCKOPT_OPTION_VALUE_T void *
2737 # define SETSOCKOPT_OPTION_VALUE_T const char *
2739 /* XXX TODO: We need to have a proper type (a Configure probe,
2740 * etc.) for what the C headers think of the third argument of
2741 * setsockopt(), the option_value read-only buffer: is it
2742 * a "char *", or a "void *", const or not. Some compilers
2743 * don't take kindly to e.g. assuming that "char *" implicitly
2744 * promotes to a "void *", or to explicitly promoting/demoting
2745 * consts to non/vice versa. The "const void *" is the SUS
2746 * definition, but that does not fly everywhere for the above
2748 SETSOCKOPT_OPTION_VALUE_T buf;
2752 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2756 aint = (int)SvIV(sv);
2757 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2760 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2770 SETERRNO(EBADF,SS_IVCHAN);
2777 /* also used for: pp_getsockname() */
2782 const int optype = PL_op->op_type;
2783 GV * const gv = MUTABLE_GV(POPs);
2784 IO * const io = GvIOn(gv);
2792 sv = sv_2mortal(newSV(257));
2793 (void)SvPOK_only(sv);
2797 fd = PerlIO_fileno(IoIFP(io));
2801 case OP_GETSOCKNAME:
2802 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2805 case OP_GETPEERNAME:
2806 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2808 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2810 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";
2811 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2812 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2813 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2814 sizeof(u_short) + sizeof(struct in_addr))) {
2821 #ifdef BOGUS_GETNAME_RETURN
2822 /* Interactive Unix, getpeername() and getsockname()
2823 does not return valid namelen */
2824 if (len == BOGUS_GETNAME_RETURN)
2825 len = sizeof(struct sockaddr);
2834 SETERRNO(EBADF,SS_IVCHAN);
2843 /* also used for: pp_lstat() */
2854 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2855 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2856 if (PL_op->op_type == OP_LSTAT) {
2857 if (gv != PL_defgv) {
2858 do_fstat_warning_check:
2859 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2860 "lstat() on filehandle%s%"SVf,
2863 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2865 } else if (PL_laststype != OP_LSTAT)
2866 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2867 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2870 if (gv != PL_defgv) {
2874 PL_laststype = OP_STAT;
2875 PL_statgv = gv ? gv : (GV *)io;
2876 sv_setpvs(PL_statname, "");
2882 int fd = PerlIO_fileno(IoIFP(io));
2884 PL_laststatval = -1;
2885 SETERRNO(EBADF,RMS_IFI);
2887 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
2890 } else if (IoDIRP(io)) {
2892 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2895 PL_laststatval = -1;
2898 else PL_laststatval = -1;
2899 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2902 if (PL_laststatval < 0) {
2908 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2909 io = MUTABLE_IO(SvRV(sv));
2910 if (PL_op->op_type == OP_LSTAT)
2911 goto do_fstat_warning_check;
2912 goto do_fstat_have_io;
2915 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2916 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2918 PL_laststype = PL_op->op_type;
2919 file = SvPV_nolen_const(PL_statname);
2920 if (PL_op->op_type == OP_LSTAT)
2921 PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
2923 PL_laststatval = PerlLIO_stat(file, &PL_statcache);
2924 if (PL_laststatval < 0) {
2925 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
2926 /* PL_warn_nl is constant */
2927 GCC_DIAG_IGNORE(-Wformat-nonliteral);
2928 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2936 if (gimme != G_ARRAY) {
2937 if (gimme != G_VOID)
2938 XPUSHs(boolSV(max));
2944 mPUSHi(PL_statcache.st_dev);
2945 #if ST_INO_SIZE > IVSIZE
2946 mPUSHn(PL_statcache.st_ino);
2948 # if ST_INO_SIGN <= 0
2949 mPUSHi(PL_statcache.st_ino);
2951 mPUSHu(PL_statcache.st_ino);
2954 mPUSHu(PL_statcache.st_mode);
2955 mPUSHu(PL_statcache.st_nlink);
2957 sv_setuid(PUSHmortal, PL_statcache.st_uid);
2958 sv_setgid(PUSHmortal, PL_statcache.st_gid);
2960 #ifdef USE_STAT_RDEV
2961 mPUSHi(PL_statcache.st_rdev);
2963 PUSHs(newSVpvs_flags("", SVs_TEMP));
2965 #if Off_t_size > IVSIZE
2966 mPUSHn(PL_statcache.st_size);
2968 mPUSHi(PL_statcache.st_size);
2971 mPUSHn(PL_statcache.st_atime);
2972 mPUSHn(PL_statcache.st_mtime);
2973 mPUSHn(PL_statcache.st_ctime);
2975 mPUSHi(PL_statcache.st_atime);
2976 mPUSHi(PL_statcache.st_mtime);
2977 mPUSHi(PL_statcache.st_ctime);
2979 #ifdef USE_STAT_BLOCKS
2980 mPUSHu(PL_statcache.st_blksize);
2981 mPUSHu(PL_statcache.st_blocks);
2983 PUSHs(newSVpvs_flags("", SVs_TEMP));
2984 PUSHs(newSVpvs_flags("", SVs_TEMP));
2990 /* All filetest ops avoid manipulating the perl stack pointer in their main
2991 bodies (since commit d2c4d2d1e22d3125), and return using either
2992 S_ft_return_false() or S_ft_return_true(). These two helper functions are
2993 the only two which manipulate the perl stack. To ensure that no stack
2994 manipulation macros are used, the filetest ops avoid defining a local copy
2995 of the stack pointer with dSP. */
2997 /* If the next filetest is stacked up with this one
2998 (PL_op->op_private & OPpFT_STACKING), we leave
2999 the original argument on the stack for success,
3000 and skip the stacked operators on failure.
3001 The next few macros/functions take care of this.
3005 S_ft_return_false(pTHX_ SV *ret) {
3009 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
3013 if (PL_op->op_private & OPpFT_STACKING) {
3014 while (OP_IS_FILETEST(next->op_type)
3015 && next->op_private & OPpFT_STACKED)
3016 next = next->op_next;
3021 PERL_STATIC_INLINE OP *
3022 S_ft_return_true(pTHX_ SV *ret) {
3024 if (PL_op->op_flags & OPf_REF)
3025 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
3026 else if (!(PL_op->op_private & OPpFT_STACKING))
3032 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
3033 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
3034 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
3036 #define tryAMAGICftest_MG(chr) STMT_START { \
3037 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
3038 && PL_op->op_flags & OPf_KIDS) { \
3039 OP *next = S_try_amagic_ftest(aTHX_ chr); \
3040 if (next) return next; \
3045 S_try_amagic_ftest(pTHX_ char chr) {
3046 SV *const arg = *PL_stack_sp;
3049 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
3053 const char tmpchr = chr;
3054 SV * const tmpsv = amagic_call(arg,
3055 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
3056 ftest_amg, AMGf_unary);
3061 return SvTRUE(tmpsv)
3062 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
3068 /* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec()
3074 /* Not const, because things tweak this below. Not bool, because there's
3075 no guarantee that OPpFT_ACCESS is <= CHAR_MAX */
3076 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3077 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3078 /* Giving some sort of initial value silences compilers. */
3080 int access_mode = R_OK;
3082 int access_mode = 0;
3085 /* access_mode is never used, but leaving use_access in makes the
3086 conditional compiling below much clearer. */
3089 Mode_t stat_mode = S_IRUSR;
3091 bool effective = FALSE;
3094 switch (PL_op->op_type) {
3095 case OP_FTRREAD: opchar = 'R'; break;
3096 case OP_FTRWRITE: opchar = 'W'; break;
3097 case OP_FTREXEC: opchar = 'X'; break;
3098 case OP_FTEREAD: opchar = 'r'; break;
3099 case OP_FTEWRITE: opchar = 'w'; break;
3100 case OP_FTEEXEC: opchar = 'x'; break;
3102 tryAMAGICftest_MG(opchar);
3104 switch (PL_op->op_type) {
3106 #if !(defined(HAS_ACCESS) && defined(R_OK))
3112 #if defined(HAS_ACCESS) && defined(W_OK)
3117 stat_mode = S_IWUSR;
3121 #if defined(HAS_ACCESS) && defined(X_OK)
3126 stat_mode = S_IXUSR;
3130 #ifdef PERL_EFF_ACCESS
3133 stat_mode = S_IWUSR;
3137 #ifndef PERL_EFF_ACCESS
3144 #ifdef PERL_EFF_ACCESS
3149 stat_mode = S_IXUSR;
3155 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3156 const char *name = SvPV_nolen(*PL_stack_sp);
3158 # ifdef PERL_EFF_ACCESS
3159 result = PERL_EFF_ACCESS(name, access_mode);
3161 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3167 result = access(name, access_mode);
3169 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3180 result = my_stat_flags(0);
3183 if (cando(stat_mode, effective, &PL_statcache))
3189 /* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */
3194 const int op_type = PL_op->op_type;
3198 case OP_FTIS: opchar = 'e'; break;
3199 case OP_FTSIZE: opchar = 's'; break;
3200 case OP_FTMTIME: opchar = 'M'; break;
3201 case OP_FTCTIME: opchar = 'C'; break;
3202 case OP_FTATIME: opchar = 'A'; break;
3204 tryAMAGICftest_MG(opchar);
3206 result = my_stat_flags(0);
3209 if (op_type == OP_FTIS)
3212 /* You can't dTARGET inside OP_FTIS, because you'll get
3213 "panic: pad_sv po" - the op is not flagged to have a target. */
3217 #if Off_t_size > IVSIZE
3218 sv_setnv(TARG, (NV)PL_statcache.st_size);
3220 sv_setiv(TARG, (IV)PL_statcache.st_size);
3225 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3229 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3233 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3237 return SvTRUE_nomg(TARG)
3238 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3243 /* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned()
3244 * pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock()
3245 * pp_ftsuid() pp_ftsvtx() pp_ftzero() */
3252 switch (PL_op->op_type) {
3253 case OP_FTROWNED: opchar = 'O'; break;
3254 case OP_FTEOWNED: opchar = 'o'; break;
3255 case OP_FTZERO: opchar = 'z'; break;
3256 case OP_FTSOCK: opchar = 'S'; break;
3257 case OP_FTCHR: opchar = 'c'; break;
3258 case OP_FTBLK: opchar = 'b'; break;
3259 case OP_FTFILE: opchar = 'f'; break;
3260 case OP_FTDIR: opchar = 'd'; break;
3261 case OP_FTPIPE: opchar = 'p'; break;
3262 case OP_FTSUID: opchar = 'u'; break;
3263 case OP_FTSGID: opchar = 'g'; break;
3264 case OP_FTSVTX: opchar = 'k'; break;
3266 tryAMAGICftest_MG(opchar);
3268 /* I believe that all these three are likely to be defined on most every
3269 system these days. */
3271 if(PL_op->op_type == OP_FTSUID) {
3276 if(PL_op->op_type == OP_FTSGID) {
3281 if(PL_op->op_type == OP_FTSVTX) {
3286 result = my_stat_flags(0);
3289 switch (PL_op->op_type) {
3291 if (PL_statcache.st_uid == PerlProc_getuid())
3295 if (PL_statcache.st_uid == PerlProc_geteuid())
3299 if (PL_statcache.st_size == 0)
3303 if (S_ISSOCK(PL_statcache.st_mode))
3307 if (S_ISCHR(PL_statcache.st_mode))
3311 if (S_ISBLK(PL_statcache.st_mode))
3315 if (S_ISREG(PL_statcache.st_mode))
3319 if (S_ISDIR(PL_statcache.st_mode))
3323 if (S_ISFIFO(PL_statcache.st_mode))
3328 if (PL_statcache.st_mode & S_ISUID)
3334 if (PL_statcache.st_mode & S_ISGID)
3340 if (PL_statcache.st_mode & S_ISVTX)
3352 tryAMAGICftest_MG('l');
3353 result = my_lstat_flags(0);
3357 if (S_ISLNK(PL_statcache.st_mode))
3370 tryAMAGICftest_MG('t');
3372 if (PL_op->op_flags & OPf_REF)
3375 SV *tmpsv = *PL_stack_sp;
3376 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3377 name = SvPV_nomg(tmpsv, namelen);
3378 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3382 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3383 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3384 else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX)
3389 SETERRNO(EBADF,RMS_IFI);
3392 if (PerlLIO_isatty(fd))
3398 /* also used for: pp_ftbinary() */
3412 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3414 if (PL_op->op_flags & OPf_REF)
3416 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3421 gv = MAYBE_DEREF_GV_nomg(sv);
3425 if (gv == PL_defgv) {
3427 io = SvTYPE(PL_statgv) == SVt_PVIO
3431 goto really_filename;
3436 sv_setpvs(PL_statname, "");
3437 io = GvIO(PL_statgv);
3439 PL_laststatval = -1;
3440 PL_laststype = OP_STAT;
3441 if (io && IoIFP(io)) {
3443 if (! PerlIO_has_base(IoIFP(io)))
3444 DIE(aTHX_ "-T and -B not implemented on filehandles");
3445 fd = PerlIO_fileno(IoIFP(io));
3447 SETERRNO(EBADF,RMS_IFI);
3450 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3451 if (PL_laststatval < 0)
3453 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3454 if (PL_op->op_type == OP_FTTEXT)
3459 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3460 i = PerlIO_getc(IoIFP(io));
3462 (void)PerlIO_ungetc(IoIFP(io),i);
3464 /* null file is anything */
3467 len = PerlIO_get_bufsiz(IoIFP(io));
3468 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3469 /* sfio can have large buffers - limit to 512 */
3474 SETERRNO(EBADF,RMS_IFI);
3476 SETERRNO(EBADF,RMS_IFI);
3485 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3487 file = SvPVX_const(PL_statname);
3489 if (!(fp = PerlIO_open(file, "r"))) {
3491 PL_laststatval = -1;
3492 PL_laststype = OP_STAT;
3494 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
3495 /* PL_warn_nl is constant */
3496 GCC_DIAG_IGNORE(-Wformat-nonliteral);
3497 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3502 PL_laststype = OP_STAT;
3503 fd = PerlIO_fileno(fp);
3505 (void)PerlIO_close(fp);
3506 SETERRNO(EBADF,RMS_IFI);
3509 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3510 if (PL_laststatval < 0) {
3511 (void)PerlIO_close(fp);
3512 SETERRNO(EBADF,RMS_IFI);
3515 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3516 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3517 (void)PerlIO_close(fp);
3519 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3520 FT_RETURNNO; /* special case NFS directories */
3521 FT_RETURNYES; /* null file is anything */
3526 /* now scan s to look for textiness */
3528 #if defined(DOSISH) || defined(USEMYBINMODE)
3529 /* ignore trailing ^Z on short files */
3530 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3535 if (! is_invariant_string((U8 *) s, len)) {
3538 /* Here contains a variant under UTF-8 . See if the entire string is
3539 * UTF-8. But the buffer may end in a partial character, so consider
3540 * it UTF-8 if the first non-UTF8 char is an ending partial */
3541 if (is_utf8_string_loc((U8 *) s, len, &ep)
3542 || ep + UTF8SKIP(ep) > (U8 *) (s + len))
3544 if (PL_op->op_type == OP_FTTEXT) {
3553 /* Here, is not UTF-8 or is entirely ASCII. Look through the buffer for
3554 * things that wouldn't be in ASCII text or rich ASCII text. Count these
3556 for (i = 0; i < len; i++, s++) {
3557 if (!*s) { /* null never allowed in text */
3561 #ifdef USE_LOCALE_CTYPE
3562 if (IN_LC_RUNTIME(LC_CTYPE)) {
3563 if ( isPRINT_LC(*s) || isSPACE_LC(*s)) {
3570 /* VT occurs so rarely in text, that we consider it odd */
3571 || (isSPACE_A(*s) && *s != VT_NATIVE)
3573 /* But there is a fair amount of backspaces and escapes in
3576 || *s == ESC_NATIVE)
3583 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3594 const char *tmps = NULL;
3598 SV * const sv = POPs;
3599 if (PL_op->op_flags & OPf_SPECIAL) {
3600 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3602 if (ckWARN(WARN_UNOPENED)) {
3603 Perl_warner(aTHX_ packWARN(WARN_UNOPENED),
3604 "chdir() on unopened filehandle %" SVf, sv);
3606 SETERRNO(EBADF,RMS_IFI);
3608 TAINT_PROPER("chdir");
3612 else if (!(gv = MAYBE_DEREF_GV(sv)))
3613 tmps = SvPV_nomg_const_nolen(sv);
3616 HV * const table = GvHVn(PL_envgv);
3619 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3620 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3622 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3626 tmps = SvPV_nolen_const(*svp);
3630 SETERRNO(EINVAL, LIB_INVARG);
3631 TAINT_PROPER("chdir");
3636 TAINT_PROPER("chdir");
3639 IO* const io = GvIO(gv);
3642 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3643 } else if (IoIFP(io)) {
3644 int fd = PerlIO_fileno(IoIFP(io));
3648 PUSHi(fchdir(fd) >= 0);
3658 DIE(aTHX_ PL_no_func, "fchdir");
3662 PUSHi( PerlDir_chdir(tmps) >= 0 );
3664 /* Clear the DEFAULT element of ENV so we'll get the new value
3666 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3673 SETERRNO(EBADF,RMS_IFI);
3680 /* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */
3684 dSP; dMARK; dTARGET;
3685 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3696 char * const tmps = POPpx;
3697 TAINT_PROPER("chroot");
3698 PUSHi( chroot(tmps) >= 0 );
3701 DIE(aTHX_ PL_no_func, "chroot");
3709 const char * const tmps2 = POPpconstx;
3710 const char * const tmps = SvPV_nolen_const(TOPs);
3711 TAINT_PROPER("rename");
3713 anum = PerlLIO_rename(tmps, tmps2);
3715 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3716 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3719 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3720 (void)UNLINK(tmps2);
3721 if (!(anum = link(tmps, tmps2)))
3722 anum = UNLINK(tmps);
3731 /* also used for: pp_symlink() */
3733 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3737 const int op_type = PL_op->op_type;
3741 if (op_type == OP_LINK)
3742 DIE(aTHX_ PL_no_func, "link");
3744 # ifndef HAS_SYMLINK
3745 if (op_type == OP_SYMLINK)
3746 DIE(aTHX_ PL_no_func, "symlink");
3750 const char * const tmps2 = POPpconstx;
3751 const char * const tmps = SvPV_nolen_const(TOPs);
3752 TAINT_PROPER(PL_op_desc[op_type]);
3754 # if defined(HAS_LINK)
3755 # if defined(HAS_SYMLINK)
3756 /* Both present - need to choose which. */
3757 (op_type == OP_LINK) ?
3758 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3760 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3761 PerlLIO_link(tmps, tmps2);
3764 # if defined(HAS_SYMLINK)
3765 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3766 symlink(tmps, tmps2);
3771 SETi( result >= 0 );
3776 /* also used for: pp_symlink() */
3781 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3791 char buf[MAXPATHLEN];
3796 /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
3797 * it is impossible to know whether the result was truncated. */
3798 len = readlink(tmps, buf, sizeof(buf) - 1);
3807 RETSETUNDEF; /* just pretend it's a normal file */
3811 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3813 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3815 char * const save_filename = filename;
3820 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3822 PERL_ARGS_ASSERT_DOONELINER;
3824 Newx(cmdline, size, char);
3825 my_strlcpy(cmdline, cmd, size);
3826 my_strlcat(cmdline, " ", size);
3827 for (s = cmdline + strlen(cmdline); *filename; ) {
3831 if (s - cmdline < size)
3832 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3833 myfp = PerlProc_popen(cmdline, "r");
3837 SV * const tmpsv = sv_newmortal();
3838 /* Need to save/restore 'PL_rs' ?? */
3839 s = sv_gets(tmpsv, myfp, 0);
3840 (void)PerlProc_pclose(myfp);
3844 #ifdef HAS_SYS_ERRLIST
3849 /* you don't see this */
3850 const char * const errmsg = Strerror(e) ;
3853 if (instr(s, errmsg)) {
3860 #define EACCES EPERM
3862 if (instr(s, "cannot make"))
3863 SETERRNO(EEXIST,RMS_FEX);
3864 else if (instr(s, "existing file"))
3865 SETERRNO(EEXIST,RMS_FEX);
3866 else if (instr(s, "ile exists"))
3867 SETERRNO(EEXIST,RMS_FEX);
3868 else if (instr(s, "non-exist"))
3869 SETERRNO(ENOENT,RMS_FNF);
3870 else if (instr(s, "does not exist"))
3871 SETERRNO(ENOENT,RMS_FNF);
3872 else if (instr(s, "not empty"))
3873 SETERRNO(EBUSY,SS_DEVOFFLINE);
3874 else if (instr(s, "cannot access"))
3875 SETERRNO(EACCES,RMS_PRV);
3877 SETERRNO(EPERM,RMS_PRV);
3880 else { /* some mkdirs return no failure indication */
3881 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3882 if (PL_op->op_type == OP_RMDIR)
3887 SETERRNO(EACCES,RMS_PRV); /* a guess */
3896 /* This macro removes trailing slashes from a directory name.
3897 * Different operating and file systems take differently to
3898 * trailing slashes. According to POSIX 1003.1 1996 Edition
3899 * any number of trailing slashes should be allowed.
3900 * Thusly we snip them away so that even non-conforming
3901 * systems are happy.
3902 * We should probably do this "filtering" for all
3903 * the functions that expect (potentially) directory names:
3904 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3905 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3907 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3908 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3911 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3912 (tmps) = savepvn((tmps), (len)); \
3922 const unsigned int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPu : 0777;
3924 TRIMSLASHES(tmps,len,copy);
3926 TAINT_PROPER("mkdir");
3928 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3932 SETi( dooneliner("mkdir", tmps) );
3933 oldumask = PerlLIO_umask(0);
3934 PerlLIO_umask(oldumask);
3935 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3950 TRIMSLASHES(tmps,len,copy);
3951 TAINT_PROPER("rmdir");
3953 SETi( PerlDir_rmdir(tmps) >= 0 );
3955 SETi( dooneliner("rmdir", tmps) );
3962 /* Directory calls. */
3966 #if defined(Direntry_t) && defined(HAS_READDIR)
3968 const char * const dirname = POPpconstx;
3969 GV * const gv = MUTABLE_GV(POPs);
3970 IO * const io = GvIOn(gv);
3972 if ((IoIFP(io) || IoOFP(io)))
3973 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3974 "Opening filehandle %"HEKf" also as a directory",
3975 HEKfARG(GvENAME_HEK(gv)) );
3977 PerlDir_close(IoDIRP(io));
3978 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3984 SETERRNO(EBADF,RMS_DIR);
3987 DIE(aTHX_ PL_no_dir_func, "opendir");
3993 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3994 DIE(aTHX_ PL_no_dir_func, "readdir");
3996 #if !defined(I_DIRENT) && !defined(VMS)
3997 Direntry_t *readdir (DIR *);
4002 const I32 gimme = GIMME_V;
4003 GV * const gv = MUTABLE_GV(POPs);
4004 const Direntry_t *dp;
4005 IO * const io = GvIOn(gv);
4008 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4009 "readdir() attempted on invalid dirhandle %"HEKf,
4010 HEKfARG(GvENAME_HEK(gv)));
4015 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
4019 sv = newSVpvn(dp->d_name, dp->d_namlen);
4021 sv = newSVpv(dp->d_name, 0);
4023 if (!(IoFLAGS(io) & IOf_UNTAINT))
4026 } while (gimme == G_ARRAY);
4028 if (!dp && gimme != G_ARRAY)
4035 SETERRNO(EBADF,RMS_ISI);
4036 if (gimme == G_ARRAY)
4045 #if defined(HAS_TELLDIR) || defined(telldir)
4047 /* XXX does _anyone_ need this? --AD 2/20/1998 */
4048 /* XXX netbsd still seemed to.
4049 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
4050 --JHI 1999-Feb-02 */
4051 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
4052 long telldir (DIR *);
4054 GV * const gv = MUTABLE_GV(POPs);
4055 IO * const io = GvIOn(gv);
4058 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4059 "telldir() attempted on invalid dirhandle %"HEKf,
4060 HEKfARG(GvENAME_HEK(gv)));
4064 PUSHi( PerlDir_tell(IoDIRP(io)) );
4068 SETERRNO(EBADF,RMS_ISI);
4071 DIE(aTHX_ PL_no_dir_func, "telldir");
4077 #if defined(HAS_SEEKDIR) || defined(seekdir)
4079 const long along = POPl;
4080 GV * const gv = MUTABLE_GV(POPs);
4081 IO * const io = GvIOn(gv);
4084 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4085 "seekdir() attempted on invalid dirhandle %"HEKf,
4086 HEKfARG(GvENAME_HEK(gv)));
4089 (void)PerlDir_seek(IoDIRP(io), along);
4094 SETERRNO(EBADF,RMS_ISI);
4097 DIE(aTHX_ PL_no_dir_func, "seekdir");
4103 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4105 GV * const gv = MUTABLE_GV(POPs);
4106 IO * const io = GvIOn(gv);
4109 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4110 "rewinddir() attempted on invalid dirhandle %"HEKf,
4111 HEKfARG(GvENAME_HEK(gv)));
4114 (void)PerlDir_rewind(IoDIRP(io));
4118 SETERRNO(EBADF,RMS_ISI);
4121 DIE(aTHX_ PL_no_dir_func, "rewinddir");
4127 #if defined(Direntry_t) && defined(HAS_READDIR)
4129 GV * const gv = MUTABLE_GV(POPs);
4130 IO * const io = GvIOn(gv);
4133 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4134 "closedir() attempted on invalid dirhandle %"HEKf,
4135 HEKfARG(GvENAME_HEK(gv)));
4138 #ifdef VOID_CLOSEDIR
4139 PerlDir_close(IoDIRP(io));
4141 if (PerlDir_close(IoDIRP(io)) < 0) {
4142 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4151 SETERRNO(EBADF,RMS_IFI);
4154 DIE(aTHX_ PL_no_dir_func, "closedir");
4158 /* Process control. */
4165 #ifdef HAS_SIGPROCMASK
4166 sigset_t oldmask, newmask;
4170 PERL_FLUSHALL_FOR_CHILD;
4171 #ifdef HAS_SIGPROCMASK
4172 sigfillset(&newmask);
4173 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4175 childpid = PerlProc_fork();
4176 if (childpid == 0) {
4180 for (sig = 1; sig < SIG_SIZE; sig++)
4181 PL_psig_pend[sig] = 0;
4183 #ifdef HAS_SIGPROCMASK
4186 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4193 #ifdef PERL_USES_PL_PIDSTATUS
4194 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4200 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4205 PERL_FLUSHALL_FOR_CHILD;
4206 childpid = PerlProc_fork();
4212 DIE(aTHX_ PL_no_func, "fork");
4219 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4224 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4225 childpid = wait4pid(-1, &argflags, 0);
4227 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4232 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4233 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4234 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4236 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4241 DIE(aTHX_ PL_no_func, "wait");
4247 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4249 const int optype = POPi;
4250 const Pid_t pid = TOPi;
4254 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4255 result = wait4pid(pid, &argflags, optype);
4257 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4262 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4263 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4264 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4266 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4271 DIE(aTHX_ PL_no_func, "waitpid");
4277 dSP; dMARK; dORIGMARK; dTARGET;
4278 #if defined(__LIBCATAMOUNT__)
4279 PL_statusvalue = -1;
4288 while (++MARK <= SP) {
4289 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4294 TAINT_PROPER("system");
4296 PERL_FLUSHALL_FOR_CHILD;
4297 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4302 #ifdef HAS_SIGPROCMASK
4303 sigset_t newset, oldset;
4306 if (PerlProc_pipe(pp) >= 0)
4308 #ifdef HAS_SIGPROCMASK
4309 sigemptyset(&newset);
4310 sigaddset(&newset, SIGCHLD);
4311 sigprocmask(SIG_BLOCK, &newset, &oldset);
4313 while ((childpid = PerlProc_fork()) == -1) {
4314 if (errno != EAGAIN) {
4319 PerlLIO_close(pp[0]);
4320 PerlLIO_close(pp[1]);
4322 #ifdef HAS_SIGPROCMASK
4323 sigprocmask(SIG_SETMASK, &oldset, NULL);
4330 Sigsave_t ihand,qhand; /* place to save signals during system() */
4334 PerlLIO_close(pp[1]);
4336 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4337 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4340 result = wait4pid(childpid, &status, 0);
4341 } while (result == -1 && errno == EINTR);
4343 #ifdef HAS_SIGPROCMASK
4344 sigprocmask(SIG_SETMASK, &oldset, NULL);
4346 (void)rsignal_restore(SIGINT, &ihand);
4347 (void)rsignal_restore(SIGQUIT, &qhand);
4349 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4350 do_execfree(); /* free any memory child malloced on fork */
4357 while (n < sizeof(int)) {
4358 n1 = PerlLIO_read(pp[0],
4359 (void*)(((char*)&errkid)+n),
4365 PerlLIO_close(pp[0]);
4366 if (n) { /* Error */
4367 if (n != sizeof(int))
4368 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4369 errno = errkid; /* Propagate errno from kid */
4370 STATUS_NATIVE_CHILD_SET(-1);
4373 XPUSHi(STATUS_CURRENT);
4376 #ifdef HAS_SIGPROCMASK
4377 sigprocmask(SIG_SETMASK, &oldset, NULL);
4380 PerlLIO_close(pp[0]);
4381 #if defined(HAS_FCNTL) && defined(F_SETFD)
4382 if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
4386 if (PL_op->op_flags & OPf_STACKED) {
4387 SV * const really = *++MARK;
4388 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4390 else if (SP - MARK != 1)
4391 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4393 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4397 #else /* ! FORK or VMS or OS/2 */
4400 if (PL_op->op_flags & OPf_STACKED) {
4401 SV * const really = *++MARK;
4402 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4403 value = (I32)do_aspawn(really, MARK, SP);
4405 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4408 else if (SP - MARK != 1) {
4409 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4410 value = (I32)do_aspawn(NULL, MARK, SP);
4412 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4416 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4418 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4420 STATUS_NATIVE_CHILD_SET(value);
4423 XPUSHi(result ? value : STATUS_CURRENT);
4424 #endif /* !FORK or VMS or OS/2 */
4431 dSP; dMARK; dORIGMARK; dTARGET;
4436 while (++MARK <= SP) {
4437 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4442 TAINT_PROPER("exec");
4444 PERL_FLUSHALL_FOR_CHILD;
4445 if (PL_op->op_flags & OPf_STACKED) {
4446 SV * const really = *++MARK;
4447 value = (I32)do_aexec(really, MARK, SP);
4449 else if (SP - MARK != 1)
4451 value = (I32)vms_do_aexec(NULL, MARK, SP);
4453 value = (I32)do_aexec(NULL, MARK, SP);
4457 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4459 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4472 XPUSHi( getppid() );
4475 DIE(aTHX_ PL_no_func, "getppid");
4485 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4488 pgrp = (I32)BSD_GETPGRP(pid);
4490 if (pid != 0 && pid != PerlProc_getpid())
4491 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4497 DIE(aTHX_ PL_no_func, "getpgrp");
4507 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4508 if (MAXARG > 0) pid = TOPs ? TOPi : 0;
4515 TAINT_PROPER("setpgrp");
4517 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4519 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4520 || (pid != 0 && pid != PerlProc_getpid()))
4522 DIE(aTHX_ "setpgrp can't take arguments");
4524 SETi( setpgrp() >= 0 );
4525 #endif /* USE_BSDPGRP */
4528 DIE(aTHX_ PL_no_func, "setpgrp");
4532 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4533 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4535 # define PRIORITY_WHICH_T(which) which
4540 #ifdef HAS_GETPRIORITY
4542 const int who = POPi;
4543 const int which = TOPi;
4544 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4547 DIE(aTHX_ PL_no_func, "getpriority");
4553 #ifdef HAS_SETPRIORITY
4555 const int niceval = POPi;
4556 const int who = POPi;
4557 const int which = TOPi;
4558 TAINT_PROPER("setpriority");
4559 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4562 DIE(aTHX_ PL_no_func, "setpriority");
4566 #undef PRIORITY_WHICH_T
4574 XPUSHn( time(NULL) );
4576 XPUSHi( time(NULL) );
4585 struct tms timesbuf;
4588 (void)PerlProc_times(×buf);
4590 mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
4591 if (GIMME_V == G_ARRAY) {
4592 mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
4593 mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
4594 mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
4602 if (GIMME_V == G_ARRAY) {
4609 DIE(aTHX_ "times not implemented");
4611 #endif /* HAS_TIMES */
4614 /* The 32 bit int year limits the times we can represent to these
4615 boundaries with a few days wiggle room to account for time zone
4618 /* Sat Jan 3 00:00:00 -2147481748 */
4619 #define TIME_LOWER_BOUND -67768100567755200.0
4620 /* Sun Dec 29 12:00:00 2147483647 */
4621 #define TIME_UPPER_BOUND 67767976233316800.0
4624 /* also used for: pp_localtime() */
4632 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4633 static const char * const dayname[] =
4634 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4635 static const char * const monname[] =
4636 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4637 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4639 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4642 when = (Time64_T)now;
4645 NV input = Perl_floor(POPn);
4646 const bool pl_isnan = Perl_isnan(input);
4647 when = (Time64_T)input;
4648 if (UNLIKELY(pl_isnan || when != input)) {
4649 /* diag_listed_as: gmtime(%f) too large */
4650 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4651 "%s(%.0" NVff ") too large", opname, input);
4659 if ( TIME_LOWER_BOUND > when ) {
4660 /* diag_listed_as: gmtime(%f) too small */
4661 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4662 "%s(%.0" NVff ") too small", opname, when);
4665 else if( when > TIME_UPPER_BOUND ) {
4666 /* diag_listed_as: gmtime(%f) too small */
4667 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4668 "%s(%.0" NVff ") too large", opname, when);
4672 if (PL_op->op_type == OP_LOCALTIME)
4673 err = Perl_localtime64_r(&when, &tmbuf);
4675 err = Perl_gmtime64_r(&when, &tmbuf);
4679 /* diag_listed_as: gmtime(%f) failed */
4680 /* XXX %lld broken for quads */
4682 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4683 "%s(%.0" NVff ") failed", opname, when);
4686 if (GIMME_V != G_ARRAY) { /* scalar context */
4693 Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %"IVdf,
4694 dayname[tmbuf.tm_wday],
4695 monname[tmbuf.tm_mon],
4700 (IV)tmbuf.tm_year + 1900);
4703 else { /* list context */
4709 mPUSHi(tmbuf.tm_sec);
4710 mPUSHi(tmbuf.tm_min);
4711 mPUSHi(tmbuf.tm_hour);
4712 mPUSHi(tmbuf.tm_mday);
4713 mPUSHi(tmbuf.tm_mon);
4714 mPUSHn(tmbuf.tm_year);
4715 mPUSHi(tmbuf.tm_wday);
4716 mPUSHi(tmbuf.tm_yday);
4717 mPUSHi(tmbuf.tm_isdst);
4726 /* alarm() takes an unsigned int number of seconds, and return the
4727 * unsigned int number of seconds remaining in the previous alarm
4728 * (alarms don't stack). Therefore negative return values are not
4732 /* Note that while the C library function alarm() as such has
4733 * no errors defined (or in other words, properly behaving client
4734 * code shouldn't expect any), alarm() being obsoleted by
4735 * setitimer() and often being implemented in terms of
4736 * setitimer(), can fail. */
4737 /* diag_listed_as: %s() with negative argument */
4738 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4739 "alarm() with negative argument");
4740 SETERRNO(EINVAL, LIB_INVARG);
4744 unsigned int retval = alarm(anum);
4745 if ((int)retval < 0) /* Strictly speaking "cannot happen". */
4751 DIE(aTHX_ PL_no_func, "alarm");
4762 (void)time(&lasttime);
4763 if (MAXARG < 1 || (!TOPs && !POPs))
4768 /* diag_listed_as: %s() with negative argument */
4769 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4770 "sleep() with negative argument");
4771 SETERRNO(EINVAL, LIB_INVARG);
4775 PerlProc_sleep((unsigned int)duration);
4779 XPUSHi(when - lasttime);
4783 /* Shared memory. */
4784 /* Merged with some message passing. */
4786 /* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */
4790 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4791 dSP; dMARK; dTARGET;
4792 const int op_type = PL_op->op_type;
4797 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4800 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4803 value = (I32)(do_semop(MARK, SP) >= 0);
4806 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4814 return Perl_pp_semget(aTHX);
4820 /* also used for: pp_msgget() pp_shmget() */
4824 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4825 dSP; dMARK; dTARGET;
4826 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4833 DIE(aTHX_ "System V IPC is not implemented on this machine");
4837 /* also used for: pp_msgctl() pp_shmctl() */
4841 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4842 dSP; dMARK; dTARGET;
4843 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4851 PUSHp(zero_but_true, ZBTLEN);
4855 return Perl_pp_semget(aTHX);
4859 /* I can't const this further without getting warnings about the types of
4860 various arrays passed in from structures. */
4862 S_space_join_names_mortal(pTHX_ char *const *array)
4866 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4869 target = newSVpvs_flags("", SVs_TEMP);
4871 sv_catpv(target, *array);
4874 sv_catpvs(target, " ");
4877 target = sv_mortalcopy(&PL_sv_no);
4882 /* Get system info. */
4884 /* also used for: pp_ghbyaddr() pp_ghbyname() */
4888 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4890 I32 which = PL_op->op_type;
4893 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4894 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4895 struct hostent *gethostbyname(Netdb_name_t);
4896 struct hostent *gethostent(void);
4898 struct hostent *hent = NULL;
4902 if (which == OP_GHBYNAME) {
4903 #ifdef HAS_GETHOSTBYNAME
4904 const char* const name = POPpbytex;
4905 hent = PerlSock_gethostbyname(name);
4907 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4910 else if (which == OP_GHBYADDR) {
4911 #ifdef HAS_GETHOSTBYADDR
4912 const int addrtype = POPi;
4913 SV * const addrsv = POPs;
4915 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4917 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4919 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4923 #ifdef HAS_GETHOSTENT
4924 hent = PerlSock_gethostent();
4926 DIE(aTHX_ PL_no_sock_func, "gethostent");
4929 #ifdef HOST_NOT_FOUND
4931 #ifdef USE_REENTRANT_API
4932 # ifdef USE_GETHOSTENT_ERRNO
4933 h_errno = PL_reentrant_buffer->_gethostent_errno;
4936 STATUS_UNIX_SET(h_errno);
4940 if (GIMME_V != G_ARRAY) {
4941 PUSHs(sv = sv_newmortal());
4943 if (which == OP_GHBYNAME) {
4945 sv_setpvn(sv, hent->h_addr, hent->h_length);
4948 sv_setpv(sv, (char*)hent->h_name);
4954 mPUSHs(newSVpv((char*)hent->h_name, 0));
4955 PUSHs(space_join_names_mortal(hent->h_aliases));
4956 mPUSHi(hent->h_addrtype);
4957 len = hent->h_length;
4960 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4961 mXPUSHp(*elem, len);
4965 mPUSHp(hent->h_addr, len);
4967 PUSHs(sv_mortalcopy(&PL_sv_no));
4972 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4976 /* also used for: pp_gnbyaddr() pp_gnbyname() */
4980 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4982 I32 which = PL_op->op_type;
4984 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4985 struct netent *getnetbyaddr(Netdb_net_t, int);
4986 struct netent *getnetbyname(Netdb_name_t);
4987 struct netent *getnetent(void);
4989 struct netent *nent;
4991 if (which == OP_GNBYNAME){
4992 #ifdef HAS_GETNETBYNAME
4993 const char * const name = POPpbytex;
4994 nent = PerlSock_getnetbyname(name);
4996 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4999 else if (which == OP_GNBYADDR) {
5000 #ifdef HAS_GETNETBYADDR
5001 const int addrtype = POPi;
5002 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
5003 nent = PerlSock_getnetbyaddr(addr, addrtype);
5005 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
5009 #ifdef HAS_GETNETENT
5010 nent = PerlSock_getnetent();
5012 DIE(aTHX_ PL_no_sock_func, "getnetent");
5015 #ifdef HOST_NOT_FOUND
5017 #ifdef USE_REENTRANT_API
5018 # ifdef USE_GETNETENT_ERRNO
5019 h_errno = PL_reentrant_buffer->_getnetent_errno;
5022 STATUS_UNIX_SET(h_errno);
5027 if (GIMME_V != G_ARRAY) {
5028 PUSHs(sv = sv_newmortal());
5030 if (which == OP_GNBYNAME)
5031 sv_setiv(sv, (IV)nent->n_net);
5033 sv_setpv(sv, nent->n_name);
5039 mPUSHs(newSVpv(nent->n_name, 0));
5040 PUSHs(space_join_names_mortal(nent->n_aliases));
5041 mPUSHi(nent->n_addrtype);
5042 mPUSHi(nent->n_net);
5047 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5052 /* also used for: pp_gpbyname() pp_gpbynumber() */
5056 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
5058 I32 which = PL_op->op_type;
5060 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
5061 struct protoent *getprotobyname(Netdb_name_t);
5062 struct protoent *getprotobynumber(int);
5063 struct protoent *getprotoent(void);
5065 struct protoent *pent;
5067 if (which == OP_GPBYNAME) {
5068 #ifdef HAS_GETPROTOBYNAME
5069 const char* const name = POPpbytex;
5070 pent = PerlSock_getprotobyname(name);
5072 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
5075 else if (which == OP_GPBYNUMBER) {
5076 #ifdef HAS_GETPROTOBYNUMBER
5077 const int number = POPi;
5078 pent = PerlSock_getprotobynumber(number);
5080 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
5084 #ifdef HAS_GETPROTOENT
5085 pent = PerlSock_getprotoent();
5087 DIE(aTHX_ PL_no_sock_func, "getprotoent");
5091 if (GIMME_V != G_ARRAY) {
5092 PUSHs(sv = sv_newmortal());
5094 if (which == OP_GPBYNAME)
5095 sv_setiv(sv, (IV)pent->p_proto);
5097 sv_setpv(sv, pent->p_name);
5103 mPUSHs(newSVpv(pent->p_name, 0));
5104 PUSHs(space_join_names_mortal(pent->p_aliases));
5105 mPUSHi(pent->p_proto);
5110 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5115 /* also used for: pp_gsbyname() pp_gsbyport() */
5119 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
5121 I32 which = PL_op->op_type;
5123 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
5124 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
5125 struct servent *getservbyport(int, Netdb_name_t);
5126 struct servent *getservent(void);
5128 struct servent *sent;
5130 if (which == OP_GSBYNAME) {
5131 #ifdef HAS_GETSERVBYNAME
5132 const char * const proto = POPpbytex;
5133 const char * const name = POPpbytex;
5134 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5136 DIE(aTHX_ PL_no_sock_func, "getservbyname");
5139 else if (which == OP_GSBYPORT) {
5140 #ifdef HAS_GETSERVBYPORT
5141 const char * const proto = POPpbytex;
5142 unsigned short port = (unsigned short)POPu;
5143 port = PerlSock_htons(port);
5144 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5146 DIE(aTHX_ PL_no_sock_func, "getservbyport");
5150 #ifdef HAS_GETSERVENT
5151 sent = PerlSock_getservent();
5153 DIE(aTHX_ PL_no_sock_func, "getservent");
5157 if (GIMME_V != G_ARRAY) {
5158 PUSHs(sv = sv_newmortal());
5160 if (which == OP_GSBYNAME) {
5161 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5164 sv_setpv(sv, sent->s_name);
5170 mPUSHs(newSVpv(sent->s_name, 0));
5171 PUSHs(space_join_names_mortal(sent->s_aliases));
5172 mPUSHi(PerlSock_ntohs(sent->s_port));
5173 mPUSHs(newSVpv(sent->s_proto, 0));
5178 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5183 /* also used for: pp_snetent() pp_sprotoent() pp_sservent() */
5188 const int stayopen = TOPi;
5189 switch(PL_op->op_type) {
5191 #ifdef HAS_SETHOSTENT
5192 PerlSock_sethostent(stayopen);
5194 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5197 #ifdef HAS_SETNETENT
5199 PerlSock_setnetent(stayopen);
5201 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5205 #ifdef HAS_SETPROTOENT
5206 PerlSock_setprotoent(stayopen);
5208 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5212 #ifdef HAS_SETSERVENT
5213 PerlSock_setservent(stayopen);
5215 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5223 /* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent()
5224 * pp_eservent() pp_sgrent() pp_spwent() */
5229 switch(PL_op->op_type) {
5231 #ifdef HAS_ENDHOSTENT
5232 PerlSock_endhostent();
5234 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5238 #ifdef HAS_ENDNETENT
5239 PerlSock_endnetent();
5241 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5245 #ifdef HAS_ENDPROTOENT
5246 PerlSock_endprotoent();
5248 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5252 #ifdef HAS_ENDSERVENT
5253 PerlSock_endservent();
5255 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5259 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5262 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5266 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5269 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5273 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5276 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5280 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5283 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5292 /* also used for: pp_gpwnam() pp_gpwuid() */
5298 I32 which = PL_op->op_type;
5300 struct passwd *pwent = NULL;
5302 * We currently support only the SysV getsp* shadow password interface.
5303 * The interface is declared in <shadow.h> and often one needs to link
5304 * with -lsecurity or some such.
5305 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5308 * AIX getpwnam() is clever enough to return the encrypted password
5309 * only if the caller (euid?) is root.
5311 * There are at least three other shadow password APIs. Many platforms
5312 * seem to contain more than one interface for accessing the shadow
5313 * password databases, possibly for compatibility reasons.
5314 * The getsp*() is by far he simplest one, the other two interfaces
5315 * are much more complicated, but also very similar to each other.
5320 * struct pr_passwd *getprpw*();
5321 * The password is in
5322 * char getprpw*(...).ufld.fd_encrypt[]
5323 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5328 * struct es_passwd *getespw*();
5329 * The password is in
5330 * char *(getespw*(...).ufld.fd_encrypt)
5331 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5334 * struct userpw *getuserpw();
5335 * The password is in
5336 * char *(getuserpw(...)).spw_upw_passwd
5337 * (but the de facto standard getpwnam() should work okay)
5339 * Mention I_PROT here so that Configure probes for it.
5341 * In HP-UX for getprpw*() the manual page claims that one should include
5342 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5343 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5344 * and pp_sys.c already includes <shadow.h> if there is such.
5346 * Note that <sys/security.h> is already probed for, but currently
5347 * it is only included in special cases.
5349 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5350 * be preferred interface, even though also the getprpw*() interface
5351 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5352 * One also needs to call set_auth_parameters() in main() before
5353 * doing anything else, whether one is using getespw*() or getprpw*().
5355 * Note that accessing the shadow databases can be magnitudes
5356 * slower than accessing the standard databases.
5361 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5362 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5363 * the pw_comment is left uninitialized. */
5364 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5370 const char* const name = POPpbytex;
5371 pwent = getpwnam(name);
5377 pwent = getpwuid(uid);
5381 # ifdef HAS_GETPWENT
5383 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5384 if (pwent) pwent = getpwnam(pwent->pw_name);
5387 DIE(aTHX_ PL_no_func, "getpwent");
5393 if (GIMME_V != G_ARRAY) {
5394 PUSHs(sv = sv_newmortal());
5396 if (which == OP_GPWNAM)
5397 sv_setuid(sv, pwent->pw_uid);
5399 sv_setpv(sv, pwent->pw_name);
5405 mPUSHs(newSVpv(pwent->pw_name, 0));
5409 /* If we have getspnam(), we try to dig up the shadow
5410 * password. If we are underprivileged, the shadow
5411 * interface will set the errno to EACCES or similar,
5412 * and return a null pointer. If this happens, we will
5413 * use the dummy password (usually "*" or "x") from the
5414 * standard password database.
5416 * In theory we could skip the shadow call completely
5417 * if euid != 0 but in practice we cannot know which
5418 * security measures are guarding the shadow databases
5419 * on a random platform.
5421 * Resist the urge to use additional shadow interfaces.
5422 * Divert the urge to writing an extension instead.
5425 /* Some AIX setups falsely(?) detect some getspnam(), which
5426 * has a different API than the Solaris/IRIX one. */
5427 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5430 const struct spwd * const spwent = getspnam(pwent->pw_name);
5431 /* Save and restore errno so that
5432 * underprivileged attempts seem
5433 * to have never made the unsuccessful
5434 * attempt to retrieve the shadow password. */
5436 if (spwent && spwent->sp_pwdp)
5437 sv_setpv(sv, spwent->sp_pwdp);
5441 if (!SvPOK(sv)) /* Use the standard password, then. */
5442 sv_setpv(sv, pwent->pw_passwd);
5445 /* passwd is tainted because user himself can diddle with it.
5446 * admittedly not much and in a very limited way, but nevertheless. */
5449 sv_setuid(PUSHmortal, pwent->pw_uid);
5450 sv_setgid(PUSHmortal, pwent->pw_gid);
5452 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5453 * because of the poor interface of the Perl getpw*(),
5454 * not because there's some standard/convention saying so.
5455 * A better interface would have been to return a hash,
5456 * but we are accursed by our history, alas. --jhi. */
5458 mPUSHi(pwent->pw_change);
5461 mPUSHi(pwent->pw_quota);
5464 mPUSHs(newSVpv(pwent->pw_age, 0));
5466 /* I think that you can never get this compiled, but just in case. */
5467 PUSHs(sv_mortalcopy(&PL_sv_no));
5472 /* pw_class and pw_comment are mutually exclusive--.
5473 * see the above note for pw_change, pw_quota, and pw_age. */
5475 mPUSHs(newSVpv(pwent->pw_class, 0));
5478 mPUSHs(newSVpv(pwent->pw_comment, 0));
5480 /* I think that you can never get this compiled, but just in case. */
5481 PUSHs(sv_mortalcopy(&PL_sv_no));
5486 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5488 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5490 /* pw_gecos is tainted because user himself can diddle with it. */
5493 mPUSHs(newSVpv(pwent->pw_dir, 0));
5495 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5496 /* pw_shell is tainted because user himself can diddle with it. */
5500 mPUSHi(pwent->pw_expire);
5505 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5510 /* also used for: pp_ggrgid() pp_ggrnam() */
5516 const I32 which = PL_op->op_type;
5517 const struct group *grent;
5519 if (which == OP_GGRNAM) {
5520 const char* const name = POPpbytex;
5521 grent = (const struct group *)getgrnam(name);
5523 else if (which == OP_GGRGID) {
5525 const Gid_t gid = POPu;
5526 #elif Gid_t_sign == -1
5527 const Gid_t gid = POPi;
5529 # error "Unexpected Gid_t_sign"
5531 grent = (const struct group *)getgrgid(gid);
5535 grent = (struct group *)getgrent();
5537 DIE(aTHX_ PL_no_func, "getgrent");
5541 if (GIMME_V != G_ARRAY) {
5542 SV * const sv = sv_newmortal();
5546 if (which == OP_GGRNAM)
5547 sv_setgid(sv, grent->gr_gid);
5549 sv_setpv(sv, grent->gr_name);
5555 mPUSHs(newSVpv(grent->gr_name, 0));
5558 mPUSHs(newSVpv(grent->gr_passwd, 0));
5560 PUSHs(sv_mortalcopy(&PL_sv_no));
5563 sv_setgid(PUSHmortal, grent->gr_gid);
5565 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5566 /* In UNICOS/mk (_CRAYMPP) the multithreading
5567 * versions (getgrnam_r, getgrgid_r)
5568 * seem to return an illegal pointer
5569 * as the group members list, gr_mem.
5570 * getgrent() doesn't even have a _r version
5571 * but the gr_mem is poisonous anyway.
5572 * So yes, you cannot get the list of group
5573 * members if building multithreaded in UNICOS/mk. */
5574 PUSHs(space_join_names_mortal(grent->gr_mem));
5580 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5590 if (!(tmps = PerlProc_getlogin()))
5592 sv_setpv_mg(TARG, tmps);
5596 DIE(aTHX_ PL_no_func, "getlogin");
5600 /* Miscellaneous. */
5605 dSP; dMARK; dORIGMARK; dTARGET;
5606 I32 items = SP - MARK;
5607 unsigned long a[20];
5612 while (++MARK <= SP) {
5613 if (SvTAINTED(*MARK)) {
5619 TAINT_PROPER("syscall");
5622 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5623 * or where sizeof(long) != sizeof(char*). But such machines will
5624 * not likely have syscall implemented either, so who cares?
5626 while (++MARK <= SP) {
5627 if (SvNIOK(*MARK) || !i)
5628 a[i++] = SvIV(*MARK);
5629 else if (*MARK == &PL_sv_undef)
5632 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5638 DIE(aTHX_ "Too many args to syscall");
5640 DIE(aTHX_ "Too few args to syscall");
5642 retval = syscall(a[0]);
5645 retval = syscall(a[0],a[1]);
5648 retval = syscall(a[0],a[1],a[2]);
5651 retval = syscall(a[0],a[1],a[2],a[3]);
5654 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5657 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5660 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5663 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5670 DIE(aTHX_ PL_no_func, "syscall");
5674 #ifdef FCNTL_EMULATE_FLOCK
5676 /* XXX Emulate flock() with fcntl().
5677 What's really needed is a good file locking module.
5681 fcntl_emulate_flock(int fd, int operation)
5686 switch (operation & ~LOCK_NB) {
5688 flock.l_type = F_RDLCK;
5691 flock.l_type = F_WRLCK;
5694 flock.l_type = F_UNLCK;
5700 flock.l_whence = SEEK_SET;
5701 flock.l_start = flock.l_len = (Off_t)0;
5703 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5704 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5705 errno = EWOULDBLOCK;
5709 #endif /* FCNTL_EMULATE_FLOCK */
5711 #ifdef LOCKF_EMULATE_FLOCK
5713 /* XXX Emulate flock() with lockf(). This is just to increase
5714 portability of scripts. The calls are not completely
5715 interchangeable. What's really needed is a good file
5719 /* The lockf() constants might have been defined in <unistd.h>.
5720 Unfortunately, <unistd.h> causes troubles on some mixed
5721 (BSD/POSIX) systems, such as SunOS 4.1.3.
5723 Further, the lockf() constants aren't POSIX, so they might not be
5724 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5725 just stick in the SVID values and be done with it. Sigh.
5729 # define F_ULOCK 0 /* Unlock a previously locked region */
5732 # define F_LOCK 1 /* Lock a region for exclusive use */
5735 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5738 # define F_TEST 3 /* Test a region for other processes locks */
5742 lockf_emulate_flock(int fd, int operation)
5748 /* flock locks entire file so for lockf we need to do the same */
5749 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5750 if (pos > 0) /* is seekable and needs to be repositioned */
5751 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5752 pos = -1; /* seek failed, so don't seek back afterwards */
5755 switch (operation) {
5757 /* LOCK_SH - get a shared lock */
5759 /* LOCK_EX - get an exclusive lock */
5761 i = lockf (fd, F_LOCK, 0);
5764 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5765 case LOCK_SH|LOCK_NB:
5766 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5767 case LOCK_EX|LOCK_NB:
5768 i = lockf (fd, F_TLOCK, 0);
5770 if ((errno == EAGAIN) || (errno == EACCES))
5771 errno = EWOULDBLOCK;
5774 /* LOCK_UN - unlock (non-blocking is a no-op) */
5776 case LOCK_UN|LOCK_NB:
5777 i = lockf (fd, F_ULOCK, 0);
5780 /* Default - can't decipher operation */
5787 if (pos > 0) /* need to restore position of the handle */
5788 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5793 #endif /* LOCKF_EMULATE_FLOCK */
5796 * ex: set ts=8 sts=4 sw=4 et: