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);
196 # include "amigaos4/amigaio.h"
199 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
201 /* F_OK unused: if stat() cannot find it... */
203 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
204 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
205 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
208 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
209 # ifdef I_SYS_SECURITY
210 # include <sys/security.h>
214 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
217 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
221 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
223 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
227 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
228 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
229 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
232 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
234 const Uid_t ruid = getuid();
235 const Uid_t euid = geteuid();
236 const Gid_t rgid = getgid();
237 const Gid_t egid = getegid();
240 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
241 Perl_croak(aTHX_ "switching effective uid is not implemented");
244 if (setreuid(euid, ruid))
247 if (setresuid(euid, ruid, (Uid_t)-1))
250 /* diag_listed_as: entering effective %s failed */
251 Perl_croak(aTHX_ "entering effective uid failed");
254 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
255 Perl_croak(aTHX_ "switching effective gid is not implemented");
258 if (setregid(egid, rgid))
261 if (setresgid(egid, rgid, (Gid_t)-1))
264 /* diag_listed_as: entering effective %s failed */
265 Perl_croak(aTHX_ "entering effective gid failed");
268 res = access(path, mode);
271 if (setreuid(ruid, euid))
274 if (setresuid(ruid, euid, (Uid_t)-1))
277 /* diag_listed_as: leaving effective %s failed */
278 Perl_croak(aTHX_ "leaving effective uid failed");
281 if (setregid(rgid, egid))
284 if (setresgid(rgid, egid, (Gid_t)-1))
287 /* diag_listed_as: leaving effective %s failed */
288 Perl_croak(aTHX_ "leaving effective gid failed");
292 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
299 const char * const tmps = POPpconstx;
300 const I32 gimme = GIMME_V;
301 const char *mode = "r";
304 if (PL_op->op_private & OPpOPEN_IN_RAW)
306 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
308 fp = PerlProc_popen(tmps, mode);
310 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
312 PerlIO_apply_layers(aTHX_ fp,mode,type);
314 if (gimme == G_VOID) {
316 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
319 else if (gimme == G_SCALAR) {
320 ENTER_with_name("backtick");
322 PL_rs = &PL_sv_undef;
323 sv_setpvs(TARG, ""); /* note that this preserves previous buffer */
324 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
326 LEAVE_with_name("backtick");
332 SV * const sv = newSV(79);
333 if (sv_gets(sv, fp, 0) == NULL) {
338 if (SvLEN(sv) - SvCUR(sv) > 20) {
339 SvPV_shrink_to_cur(sv);
344 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
345 TAINT; /* "I believe that this is not gratuitous!" */
348 STATUS_NATIVE_CHILD_SET(-1);
349 if (gimme == G_SCALAR)
360 GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs;
364 /* make a copy of the pattern if it is gmagical, to ensure that magic
365 * is called once and only once */
366 if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs));
368 tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL));
370 if (PL_op->op_flags & OPf_SPECIAL) {
371 /* call Perl-level glob function instead. Stack args are:
373 * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
382 /* Note that we only ever get here if File::Glob fails to load
383 * without at the same time croaking, for some reason, or if
384 * perl was built with PERL_EXTERNAL_GLOB */
386 ENTER_with_name("glob");
391 * The external globbing program may use things we can't control,
392 * so for security reasons we must assume the worst.
395 taint_proper(PL_no_security, "glob");
399 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
402 SAVESPTR(PL_rs); /* This is not permanent, either. */
403 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
406 *SvPVX(PL_rs) = '\n';
410 result = do_readline();
411 LEAVE_with_name("glob");
417 PL_last_in_gv = cGVOP_gv;
418 return do_readline();
428 do_join(TARG, &PL_sv_no, MARK, SP);
432 else if (SP == MARK) {
439 if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
442 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
443 /* well-formed exception supplied */
446 SV * const errsv = ERRSV;
449 if (SvGMAGICAL(errsv)) {
450 exsv = sv_newmortal();
451 sv_setsv_nomg(exsv, errsv);
455 else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) {
456 exsv = sv_newmortal();
457 sv_setsv_nomg(exsv, errsv);
458 sv_catpvs(exsv, "\t...caught");
461 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
464 if (SvROK(exsv) && !PL_warnhook)
465 Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
477 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
479 if (SP - MARK != 1) {
481 do_join(TARG, &PL_sv_no, MARK, SP);
489 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
490 /* well-formed exception supplied */
493 SV * const errsv = ERRSV;
497 if (sv_isobject(exsv)) {
498 HV * const stash = SvSTASH(SvRV(exsv));
499 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
501 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
502 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
509 call_sv(MUTABLE_SV(GvCV(gv)),
510 G_SCALAR|G_EVAL|G_KEEPERR);
511 exsv = sv_mortalcopy(*PL_stack_sp--);
515 else if (SvPOK(errsv) && SvCUR(errsv)) {
516 exsv = sv_mortalcopy(errsv);
517 sv_catpvs(exsv, "\t...propagated");
520 exsv = newSVpvs_flags("Died", SVs_TEMP);
524 NOT_REACHED; /* NOTREACHED */
525 return NULL; /* avoid missing return from non-void function warning */
531 Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv,
532 const MAGIC *const mg, const U32 flags, U32 argc, ...)
538 PERL_ARGS_ASSERT_TIED_METHOD;
540 /* Ensure that our flag bits do not overlap. */
541 STATIC_ASSERT_STMT((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
542 STATIC_ASSERT_STMT((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
543 STATIC_ASSERT_STMT((TIED_METHOD_SAY & G_WANT) == 0);
545 PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
546 PUSHSTACKi(PERLSI_MAGIC);
547 /* extend for object + args. If argc might wrap/truncate when cast
548 * to SSize_t, set to -1 which will trigger a panic in EXTEND() */
550 sizeof(argc) >= sizeof(SSize_t) && argc > SSize_t_MAX - 1
551 ? -1 : (SSize_t)argc + 1;
552 EXTEND(SP, extend_size);
554 PUSHs(SvTIED_obj(sv, mg));
555 if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
556 Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
560 const U32 mortalize_not_needed
561 = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
563 va_start(args, argc);
565 SV *const arg = va_arg(args, SV *);
566 if(mortalize_not_needed)
575 ENTER_with_name("call_tied_method");
576 if (flags & TIED_METHOD_SAY) {
577 /* local $\ = "\n" */
578 SAVEGENERICSV(PL_ors_sv);
579 PL_ors_sv = newSVpvs("\n");
581 ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED);
586 if (ret_args) { /* copy results back to original stack */
587 EXTEND(sp, ret_args);
588 Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
592 LEAVE_with_name("call_tied_method");
596 #define tied_method0(a,b,c,d) \
597 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
598 #define tied_method1(a,b,c,d,e) \
599 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
600 #define tied_method2(a,b,c,d,e,f) \
601 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
614 GV * const gv = MUTABLE_GV(*++MARK);
616 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
617 DIE(aTHX_ PL_no_usym, "filehandle");
619 if ((io = GvIOp(gv))) {
621 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
624 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
625 "Opening dirhandle %"HEKf" also as a file",
626 HEKfARG(GvENAME_HEK(gv)));
628 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
630 /* Method's args are same as ours ... */
631 /* ... except handle is replaced by the object */
632 return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg,
633 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
645 tmps = SvPV_const(sv, len);
646 ok = do_open6(gv, tmps, len, NULL, MARK+1, (SP-MARK));
649 PUSHi( (I32)PL_forkprocess );
650 else if (PL_forkprocess == 0) /* we are a new child */
661 MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
667 IO * const io = GvIO(gv);
669 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
671 return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg);
675 PUSHs(boolSV(do_close(gv, TRUE)));
687 GV * const wgv = MUTABLE_GV(POPs);
688 GV * const rgv = MUTABLE_GV(POPs);
690 assert (isGV_with_GP(rgv));
691 assert (isGV_with_GP(wgv));
694 do_close(rgv, FALSE);
698 do_close(wgv, FALSE);
700 if (PerlProc_pipe(fd) < 0)
703 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
704 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
705 IoOFP(rstio) = IoIFP(rstio);
706 IoIFP(wstio) = IoOFP(wstio);
707 IoTYPE(rstio) = IoTYPE_RDONLY;
708 IoTYPE(wstio) = IoTYPE_WRONLY;
710 if (!IoIFP(rstio) || !IoOFP(wstio)) {
712 PerlIO_close(IoIFP(rstio));
714 PerlLIO_close(fd[0]);
716 PerlIO_close(IoOFP(wstio));
718 PerlLIO_close(fd[1]);
721 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
722 /* ensure close-on-exec */
723 if ((fd[0] > PL_maxsysfd && fcntl(fd[0], F_SETFD, FD_CLOEXEC) < 0) ||
724 (fd[1] > PL_maxsysfd && fcntl(fd[1], F_SETFD, FD_CLOEXEC) < 0))
732 DIE(aTHX_ PL_no_func, "pipe");
746 gv = MUTABLE_GV(POPs);
750 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
752 return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg);
755 if (io && IoDIRP(io)) {
756 #if defined(HAS_DIRFD) || defined(HAS_DIR_DD_FD)
757 PUSHi(my_dirfd(IoDIRP(io)));
759 #elif defined(ENOTSUP)
760 errno = ENOTSUP; /* Operation not supported */
762 #elif defined(EOPNOTSUPP)
763 errno = EOPNOTSUPP; /* Operation not supported on socket */
766 errno = EINVAL; /* Invalid argument */
771 if (!io || !(fp = IoIFP(io))) {
772 /* Can't do this because people seem to do things like
773 defined(fileno($foo)) to check whether $foo is a valid fh.
780 PUSHi(PerlIO_fileno(fp));
791 if (MAXARG < 1 || (!TOPs && !POPs)) {
792 anum = PerlLIO_umask(022);
793 /* setting it to 022 between the two calls to umask avoids
794 * to have a window where the umask is set to 0 -- meaning
795 * that another thread could create world-writeable files. */
797 (void)PerlLIO_umask(anum);
800 anum = PerlLIO_umask(POPi);
801 TAINT_PROPER("umask");
804 /* Only DIE if trying to restrict permissions on "user" (self).
805 * Otherwise it's harmless and more useful to just return undef
806 * since 'group' and 'other' concepts probably don't exist here. */
807 if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
808 DIE(aTHX_ "umask not implemented");
809 XPUSHs(&PL_sv_undef);
828 gv = MUTABLE_GV(POPs);
832 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
834 /* This takes advantage of the implementation of the varargs
835 function, which I don't think that the optimiser will be able to
836 figure out. Although, as it's a static function, in theory it
838 return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg,
839 G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
840 discp ? 1 : 0, discp);
844 if (!io || !(fp = IoIFP(io))) {
846 SETERRNO(EBADF,RMS_IFI);
853 const char *d = NULL;
856 d = SvPV_const(discp, len);
857 mode = mode_from_discipline(d, len);
858 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
859 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
860 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
881 const I32 markoff = MARK - PL_stack_base;
882 const char *methname;
883 int how = PERL_MAGIC_tied;
887 switch(SvTYPE(varsv)) {
891 methname = "TIEHASH";
892 if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
893 HvLAZYDEL_off(varsv);
894 hv_free_ent((HV *)varsv, entry);
896 HvEITER_set(MUTABLE_HV(varsv), 0);
900 methname = "TIEARRAY";
901 if (!AvREAL(varsv)) {
903 Perl_croak(aTHX_ "Cannot tie unreifiable array");
904 av_clear((AV *)varsv);
911 if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
912 methname = "TIEHANDLE";
913 how = PERL_MAGIC_tiedscalar;
914 /* For tied filehandles, we apply tiedscalar magic to the IO
915 slot of the GP rather than the GV itself. AMS 20010812 */
917 GvIOp(varsv) = newIO();
918 varsv = MUTABLE_SV(GvIOp(varsv));
921 if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
922 vivify_defelem(varsv);
923 varsv = LvTARG(varsv);
927 methname = "TIESCALAR";
928 how = PERL_MAGIC_tiedscalar;
932 if (sv_isobject(*MARK)) { /* Calls GET magic. */
933 ENTER_with_name("call_TIE");
934 PUSHSTACKi(PERLSI_MAGIC);
936 EXTEND(SP,(I32)items);
940 call_method(methname, G_SCALAR);
943 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
944 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
945 * wrong error message, and worse case, supreme action at a distance.
946 * (Sorry obfuscation writers. You're not going to be given this one.)
948 stash = gv_stashsv(*MARK, 0);
949 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
950 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
951 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
953 ENTER_with_name("call_TIE");
954 PUSHSTACKi(PERLSI_MAGIC);
956 EXTEND(SP,(I32)items);
960 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
966 if (sv_isobject(sv)) {
967 sv_unmagic(varsv, how);
968 /* Croak if a self-tie on an aggregate is attempted. */
969 if (varsv == SvRV(sv) &&
970 (SvTYPE(varsv) == SVt_PVAV ||
971 SvTYPE(varsv) == SVt_PVHV))
973 "Self-ties of arrays and hashes are not supported");
974 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
976 LEAVE_with_name("call_TIE");
977 SP = PL_stack_base + markoff;
983 /* also used for: pp_dbmclose() */
990 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
991 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
993 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
996 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
997 !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
999 if ((mg = SvTIED_mg(sv, how))) {
1000 SV * const obj = SvRV(SvTIED_obj(sv, mg));
1002 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
1004 if (gv && isGV(gv) && (cv = GvCV(gv))) {
1006 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
1007 mXPUSHi(SvREFCNT(obj) - 1);
1009 ENTER_with_name("call_UNTIE");
1010 call_sv(MUTABLE_SV(cv), G_VOID);
1011 LEAVE_with_name("call_UNTIE");
1014 else if (mg && SvREFCNT(obj) > 1) {
1015 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
1016 "untie attempted while %"UVuf" inner references still exist",
1017 (UV)SvREFCNT(obj) - 1 ) ;
1021 sv_unmagic(sv, how) ;
1030 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1031 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1033 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1036 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1037 !(sv = defelem_target(sv, NULL))) goto ret_undef;
1039 if ((mg = SvTIED_mg(sv, how))) {
1040 SETs(SvTIED_obj(sv, mg));
1041 return NORMAL; /* PUTBACK not needed, pp_tied never moves SP */
1055 HV * const hv = MUTABLE_HV(POPs);
1056 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1057 stash = gv_stashsv(sv, 0);
1058 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1060 require_pv("AnyDBM_File.pm");
1062 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1063 DIE(aTHX_ "No dbm on this machine");
1073 mPUSHu(O_RDWR|O_CREAT);
1077 if (!SvOK(right)) right = &PL_sv_no;
1081 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1084 if (!sv_isobject(TOPs)) {
1092 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1094 if (sv_isobject(TOPs))
1099 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1100 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1117 struct timeval timebuf;
1118 struct timeval *tbuf = &timebuf;
1121 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1126 # if BYTEORDER & 0xf0000
1127 # define ORDERBYTE (0x88888888 - BYTEORDER)
1129 # define ORDERBYTE (0x4444 - BYTEORDER)
1135 for (i = 1; i <= 3; i++) {
1136 SV * const sv = SP[i];
1140 if (SvREADONLY(sv)) {
1141 if (!(SvPOK(sv) && SvCUR(sv) == 0))
1142 Perl_croak_no_modify();
1144 else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
1147 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1148 "Non-string passed as bitmask");
1149 SvPV_force_nomg_nolen(sv); /* force string conversion */
1156 /* little endians can use vecs directly */
1157 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1164 masksize = NFDBITS / NBBY;
1166 masksize = sizeof(long); /* documented int, everyone seems to use long */
1168 Zero(&fd_sets[0], 4, char*);
1171 # if SELECT_MIN_BITS == 1
1172 growsize = sizeof(fd_set);
1174 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1175 # undef SELECT_MIN_BITS
1176 # define SELECT_MIN_BITS __FD_SETSIZE
1178 /* If SELECT_MIN_BITS is greater than one we most probably will want
1179 * to align the sizes with SELECT_MIN_BITS/8 because for example
1180 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1181 * UNIX, Solaris, Darwin) the smallest quantum select() operates
1182 * on (sets/tests/clears bits) is 32 bits. */
1183 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1189 value = SvNV_nomg(sv);
1192 timebuf.tv_sec = (long)value;
1193 value -= (NV)timebuf.tv_sec;
1194 timebuf.tv_usec = (long)(value * 1000000.0);
1199 for (i = 1; i <= 3; i++) {
1201 if (!SvOK(sv) || SvCUR(sv) == 0) {
1208 Sv_Grow(sv, growsize);
1212 while (++j <= growsize) {
1216 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1218 Newx(fd_sets[i], growsize, char);
1219 for (offset = 0; offset < growsize; offset += masksize) {
1220 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1221 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1224 fd_sets[i] = SvPVX(sv);
1228 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1229 /* Can't make just the (void*) conditional because that would be
1230 * cpp #if within cpp macro, and not all compilers like that. */
1231 nfound = PerlSock_select(
1233 (Select_fd_set_t) fd_sets[1],
1234 (Select_fd_set_t) fd_sets[2],
1235 (Select_fd_set_t) fd_sets[3],
1236 (void*) tbuf); /* Workaround for compiler bug. */
1238 nfound = PerlSock_select(
1240 (Select_fd_set_t) fd_sets[1],
1241 (Select_fd_set_t) fd_sets[2],
1242 (Select_fd_set_t) fd_sets[3],
1245 for (i = 1; i <= 3; i++) {
1248 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1250 for (offset = 0; offset < growsize; offset += masksize) {
1251 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1252 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1254 Safefree(fd_sets[i]);
1261 if (GIMME_V == G_ARRAY && tbuf) {
1262 value = (NV)(timebuf.tv_sec) +
1263 (NV)(timebuf.tv_usec) / 1000000.0;
1268 DIE(aTHX_ "select not implemented");
1276 =for apidoc setdefout
1278 Sets C<PL_defoutgv>, the default file handle for output, to the passed in
1279 typeglob. As C<PL_defoutgv> "owns" a reference on its typeglob, the reference
1280 count of the passed in typeglob is increased by one, and the reference count
1281 of the typeglob that C<PL_defoutgv> points to is decreased by one.
1287 Perl_setdefout(pTHX_ GV *gv)
1289 PERL_ARGS_ASSERT_SETDEFOUT;
1290 SvREFCNT_inc_simple_void_NN(gv);
1291 SvREFCNT_dec(PL_defoutgv);
1299 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1300 GV * egv = GvEGVx(PL_defoutgv);
1305 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1306 gvp = hv && HvENAME(hv)
1307 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1309 if (gvp && *gvp == egv) {
1310 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1314 mXPUSHs(newRV(MUTABLE_SV(egv)));
1318 if (!GvIO(newdefout))
1319 gv_IOadd(newdefout);
1320 setdefout(newdefout);
1330 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1331 IO *const io = GvIO(gv);
1337 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1339 const U32 gimme = GIMME_V;
1340 Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1341 if (gimme == G_SCALAR) {
1343 SvSetMagicSV_nosteal(TARG, TOPs);
1348 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1349 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1351 SETERRNO(EBADF,RMS_IFI);
1355 sv_setpvs(TARG, " ");
1356 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1357 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1358 /* Find out how many bytes the char needs */
1359 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1362 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1363 SvCUR_set(TARG,1+len);
1367 else SvUTF8_off(TARG);
1373 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1376 const I32 gimme = GIMME_V;
1378 PERL_ARGS_ASSERT_DOFORM;
1381 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1386 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1387 PUSHFORMAT(cx, retop);
1388 if (CvDEPTH(cv) >= 2) {
1389 PERL_STACK_OVERFLOW_CHECK();
1390 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1393 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1395 setdefout(gv); /* locally select filehandle so $% et al work */
1413 gv = MUTABLE_GV(POPs);
1430 tmpsv = sv_newmortal();
1431 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1432 DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
1434 IoFLAGS(io) &= ~IOf_DIDTOP;
1435 RETURNOP(doform(cv,gv,PL_op->op_next));
1441 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1442 IO * const io = GvIOp(gv);
1449 bool is_return = cBOOL(PL_op->op_type == OP_RETURN);
1451 if (is_return || !io || !(ofp = IoOFP(io)))
1454 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1455 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1457 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1458 PL_formtarget != PL_toptarget)
1462 if (!IoTOP_GV(io)) {
1465 if (!IoTOP_NAME(io)) {
1467 if (!IoFMT_NAME(io))
1468 IoFMT_NAME(io) = savepv(GvNAME(gv));
1469 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1470 HEKfARG(GvNAME_HEK(gv))));
1471 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1472 if ((topgv && GvFORM(topgv)) ||
1473 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1474 IoTOP_NAME(io) = savesvpv(topname);
1476 IoTOP_NAME(io) = savepvs("top");
1478 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1479 if (!topgv || !GvFORM(topgv)) {
1480 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1483 IoTOP_GV(io) = topgv;
1485 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1486 I32 lines = IoLINES_LEFT(io);
1487 const char *s = SvPVX_const(PL_formtarget);
1488 if (lines <= 0) /* Yow, header didn't even fit!!! */
1490 while (lines-- > 0) {
1491 s = strchr(s, '\n');
1497 const STRLEN save = SvCUR(PL_formtarget);
1498 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1499 do_print(PL_formtarget, ofp);
1500 SvCUR_set(PL_formtarget, save);
1501 sv_chop(PL_formtarget, s);
1502 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1505 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1506 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1507 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1509 PL_formtarget = PL_toptarget;
1510 IoFLAGS(io) |= IOf_DIDTOP;
1512 assert(fgv); /* IoTOP_GV(io) should have been set above */
1515 SV * const sv = sv_newmortal();
1516 gv_efullname4(sv, fgv, NULL, FALSE);
1517 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1519 return doform(cv, gv, PL_op);
1523 POPBLOCK(cx,PL_curpm);
1524 retop = cx->blk_sub.retop;
1526 SP = newsp; /* ignore retval of formline */
1530 /* XXX the semantics of doing 'return' in a format aren't documented.
1531 * Currently we ignore any args to 'return' and just return
1532 * a single undef in both scalar and list contexts
1534 PUSHs(&PL_sv_undef);
1535 else if (!io || !(fp = IoOFP(io))) {
1536 if (io && IoIFP(io))
1537 report_wrongway_fh(gv, '<');
1543 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1544 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1546 if (!do_print(PL_formtarget, fp))
1549 FmLINES(PL_formtarget) = 0;
1550 SvCUR_set(PL_formtarget, 0);
1551 *SvEND(PL_formtarget) = '\0';
1552 if (IoFLAGS(io) & IOf_FLUSH)
1553 (void)PerlIO_flush(fp);
1557 PL_formtarget = PL_bodytarget;
1558 PERL_UNUSED_VAR(gimme);
1564 dSP; dMARK; dORIGMARK;
1568 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1569 IO *const io = GvIO(gv);
1571 /* Treat empty list as "" */
1572 if (MARK == SP) XPUSHs(&PL_sv_no);
1575 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1577 if (MARK == ORIGMARK) {
1580 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1583 return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1585 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1592 SETERRNO(EBADF,RMS_IFI);
1595 else if (!(fp = IoOFP(io))) {
1597 report_wrongway_fh(gv, '<');
1598 else if (ckWARN(WARN_CLOSED))
1600 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1604 SV *sv = sv_newmortal();
1605 do_sprintf(sv, SP - MARK, MARK + 1);
1606 if (!do_print(sv, fp))
1609 if (IoFLAGS(io) & IOf_FLUSH)
1610 if (PerlIO_flush(fp) == EOF)
1619 PUSHs(&PL_sv_undef);
1626 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1627 const int mode = POPi;
1628 SV * const sv = POPs;
1629 GV * const gv = MUTABLE_GV(POPs);
1632 /* Need TIEHANDLE method ? */
1633 const char * const tmps = SvPV_const(sv, len);
1634 if (do_open_raw(gv, tmps, len, mode, perm)) {
1635 IoLINES(GvIOp(gv)) = 0;
1639 PUSHs(&PL_sv_undef);
1645 /* also used for: pp_read() and pp_recv() (where supported) */
1649 dSP; dMARK; dORIGMARK; dTARGET;
1663 bool charstart = FALSE;
1664 STRLEN charskip = 0;
1666 GV * const gv = MUTABLE_GV(*++MARK);
1669 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1670 && gv && (io = GvIO(gv)) )
1672 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1674 return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1675 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1684 sv_setpvs(bufsv, "");
1685 length = SvIVx(*++MARK);
1687 DIE(aTHX_ "Negative length");
1690 offset = SvIVx(*++MARK);
1694 if (!io || !IoIFP(io)) {
1696 SETERRNO(EBADF,RMS_IFI);
1700 /* Note that fd can here validly be -1, don't check it yet. */
1701 fd = PerlIO_fileno(IoIFP(io));
1703 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1704 if (PL_op->op_type == OP_SYSREAD || PL_op->op_type == OP_RECV) {
1705 Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
1706 "%s() is deprecated on :utf8 handles",
1709 buffer = SvPVutf8_force(bufsv, blen);
1710 /* UTF-8 may not have been set if they are all low bytes */
1715 buffer = SvPV_force(bufsv, blen);
1716 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1718 if (DO_UTF8(bufsv)) {
1719 blen = sv_len_utf8_nomg(bufsv);
1728 if (PL_op->op_type == OP_RECV) {
1729 Sock_size_t bufsize;
1730 char namebuf[MAXPATHLEN];
1732 SETERRNO(EBADF,SS_IVCHAN);
1735 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1736 bufsize = sizeof (struct sockaddr_in);
1738 bufsize = sizeof namebuf;
1740 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1744 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1745 /* 'offset' means 'flags' here */
1746 count = PerlSock_recvfrom(fd, buffer, length, offset,
1747 (struct sockaddr *)namebuf, &bufsize);
1750 /* MSG_TRUNC can give oversized count; quietly lose it */
1753 SvCUR_set(bufsv, count);
1754 *SvEND(bufsv) = '\0';
1755 (void)SvPOK_only(bufsv);
1759 /* This should not be marked tainted if the fp is marked clean */
1760 if (!(IoFLAGS(io) & IOf_UNTAINT))
1761 SvTAINTED_on(bufsv);
1763 #if defined(__CYGWIN__)
1764 /* recvfrom() on cygwin doesn't set bufsize at all for
1765 connected sockets, leaving us with trash in the returned
1766 name, so use the same test as the Win32 code to check if it
1767 wasn't set, and set it [perl #118843] */
1768 if (bufsize == sizeof namebuf)
1771 sv_setpvn(TARG, namebuf, bufsize);
1777 if (-offset > (SSize_t)blen)
1778 DIE(aTHX_ "Offset outside string");
1781 if (DO_UTF8(bufsv)) {
1782 /* convert offset-as-chars to offset-as-bytes */
1783 if (offset >= (SSize_t)blen)
1784 offset += SvCUR(bufsv) - blen;
1786 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1790 /* Reestablish the fd in case it shifted from underneath us. */
1791 fd = PerlIO_fileno(IoIFP(io));
1793 orig_size = SvCUR(bufsv);
1794 /* Allocating length + offset + 1 isn't perfect in the case of reading
1795 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1797 (should be 2 * length + offset + 1, or possibly something longer if
1798 IN_ENCODING Is true) */
1799 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1800 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1801 Zero(buffer+orig_size, offset-orig_size, char);
1803 buffer = buffer + offset;
1805 read_target = bufsv;
1807 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1808 concatenate it to the current buffer. */
1810 /* Truncate the existing buffer to the start of where we will be
1812 SvCUR_set(bufsv, offset);
1814 read_target = sv_newmortal();
1815 SvUPGRADE(read_target, SVt_PV);
1816 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1819 if (PL_op->op_type == OP_SYSREAD) {
1820 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1821 if (IoTYPE(io) == IoTYPE_SOCKET) {
1823 SETERRNO(EBADF,SS_IVCHAN);
1827 count = PerlSock_recv(fd, buffer, length, 0);
1833 SETERRNO(EBADF,RMS_IFI);
1837 count = PerlLIO_read(fd, buffer, length);
1842 count = PerlIO_read(IoIFP(io), buffer, length);
1843 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1844 if (count == 0 && PerlIO_error(IoIFP(io)))
1848 if (IoTYPE(io) == IoTYPE_WRONLY)
1849 report_wrongway_fh(gv, '>');
1852 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1853 *SvEND(read_target) = '\0';
1854 (void)SvPOK_only(read_target);
1855 if (fp_utf8 && !IN_BYTES) {
1856 /* Look at utf8 we got back and count the characters */
1857 const char *bend = buffer + count;
1858 while (buffer < bend) {
1860 skip = UTF8SKIP(buffer);
1863 if (buffer - charskip + skip > bend) {
1864 /* partial character - try for rest of it */
1865 length = skip - (bend-buffer);
1866 offset = bend - SvPVX_const(bufsv);
1878 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1879 provided amount read (count) was what was requested (length)
1881 if (got < wanted && count == length) {
1882 length = wanted - got;
1883 offset = bend - SvPVX_const(bufsv);
1886 /* return value is character count */
1890 else if (buffer_utf8) {
1891 /* Let svcatsv upgrade the bytes we read in to utf8.
1892 The buffer is a mortal so will be freed soon. */
1893 sv_catsv_nomg(bufsv, read_target);
1896 /* This should not be marked tainted if the fp is marked clean */
1897 if (!(IoFLAGS(io) & IOf_UNTAINT))
1898 SvTAINTED_on(bufsv);
1909 /* also used for: pp_send() where defined */
1913 dSP; dMARK; dORIGMARK; dTARGET;
1918 STRLEN orig_blen_bytes;
1919 const int op_type = PL_op->op_type;
1922 GV *const gv = MUTABLE_GV(*++MARK);
1923 IO *const io = GvIO(gv);
1926 if (op_type == OP_SYSWRITE && io) {
1927 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1929 if (MARK == SP - 1) {
1931 mXPUSHi(sv_len(sv));
1935 return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1936 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1946 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1948 if (io && IoIFP(io))
1949 report_wrongway_fh(gv, '<');
1952 SETERRNO(EBADF,RMS_IFI);
1955 fd = PerlIO_fileno(IoIFP(io));
1957 SETERRNO(EBADF,SS_IVCHAN);
1962 /* Do this first to trigger any overloading. */
1963 buffer = SvPV_const(bufsv, blen);
1964 orig_blen_bytes = blen;
1965 doing_utf8 = DO_UTF8(bufsv);
1967 if (PerlIO_isutf8(IoIFP(io))) {
1968 Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
1969 "%s() is deprecated on :utf8 handles",
1971 if (!SvUTF8(bufsv)) {
1972 /* We don't modify the original scalar. */
1973 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1974 buffer = (char *) tmpbuf;
1978 else if (doing_utf8) {
1979 STRLEN tmplen = blen;
1980 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1983 buffer = (char *) tmpbuf;
1987 assert((char *)result == buffer);
1988 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1993 if (op_type == OP_SEND) {
1994 const int flags = SvIVx(*++MARK);
1997 char * const sockbuf = SvPVx(*++MARK, mlen);
1998 retval = PerlSock_sendto(fd, buffer, blen,
1999 flags, (struct sockaddr *)sockbuf, mlen);
2002 retval = PerlSock_send(fd, buffer, blen, flags);
2008 Size_t length = 0; /* This length is in characters. */
2014 /* The SV is bytes, and we've had to upgrade it. */
2015 blen_chars = orig_blen_bytes;
2017 /* The SV really is UTF-8. */
2018 /* Don't call sv_len_utf8 on a magical or overloaded
2019 scalar, as we might get back a different result. */
2020 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
2027 length = blen_chars;
2029 #if Size_t_size > IVSIZE
2030 length = (Size_t)SvNVx(*++MARK);
2032 length = (Size_t)SvIVx(*++MARK);
2034 if ((SSize_t)length < 0) {
2036 DIE(aTHX_ "Negative length");
2041 offset = SvIVx(*++MARK);
2043 if (-offset > (IV)blen_chars) {
2045 DIE(aTHX_ "Offset outside string");
2047 offset += blen_chars;
2048 } else if (offset > (IV)blen_chars) {
2050 DIE(aTHX_ "Offset outside string");
2054 if (length > blen_chars - offset)
2055 length = blen_chars - offset;
2057 /* Here we convert length from characters to bytes. */
2058 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
2059 /* Either we had to convert the SV, or the SV is magical, or
2060 the SV has overloading, in which case we can't or mustn't
2061 or mustn't call it again. */
2063 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
2064 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
2066 /* It's a real UTF-8 SV, and it's not going to change under
2067 us. Take advantage of any cache. */
2069 I32 len_I32 = length;
2071 /* Convert the start and end character positions to bytes.
2072 Remember that the second argument to sv_pos_u2b is relative
2074 sv_pos_u2b(bufsv, &start, &len_I32);
2081 buffer = buffer+offset;
2083 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2084 if (IoTYPE(io) == IoTYPE_SOCKET) {
2085 retval = PerlSock_send(fd, buffer, length, 0);
2090 /* See the note at doio.c:do_print about filesize limits. --jhi */
2091 retval = PerlLIO_write(fd, buffer, length);
2099 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2102 #if Size_t_size > IVSIZE
2122 * in Perl 5.12 and later, the additional parameter is a bitmask:
2125 * 2 = eof() <- ARGV magic
2127 * I'll rely on the compiler's trace flow analysis to decide whether to
2128 * actually assign this out here, or punt it into the only block where it is
2129 * used. Doing it out here is DRY on the condition logic.
2134 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2140 if (PL_op->op_flags & OPf_SPECIAL) {
2141 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2145 gv = PL_last_in_gv; /* eof */
2153 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2154 return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2157 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2158 if (io && !IoIFP(io)) {
2159 if ((IoFLAGS(io) & IOf_START) && av_tindex(GvAVn(gv)) < 0) {
2162 IoFLAGS(io) &= ~IOf_START;
2163 do_open6(gv, "-", 1, NULL, NULL, 0);
2171 *svp = newSVpvs("-");
2173 else if (!nextargv(gv, FALSE))
2178 PUSHs(boolSV(do_eof(gv)));
2188 if (MAXARG != 0 && (TOPs || POPs))
2189 PL_last_in_gv = MUTABLE_GV(POPs);
2196 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2198 return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2203 SETERRNO(EBADF,RMS_IFI);
2208 #if LSEEKSIZE > IVSIZE
2209 PUSHn( do_tell(gv) );
2211 PUSHi( do_tell(gv) );
2217 /* also used for: pp_seek() */
2222 const int whence = POPi;
2223 #if LSEEKSIZE > IVSIZE
2224 const Off_t offset = (Off_t)SvNVx(POPs);
2226 const Off_t offset = (Off_t)SvIVx(POPs);
2229 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2230 IO *const io = GvIO(gv);
2233 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2235 #if LSEEKSIZE > IVSIZE
2236 SV *const offset_sv = newSVnv((NV) offset);
2238 SV *const offset_sv = newSViv(offset);
2241 return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2246 if (PL_op->op_type == OP_SEEK)
2247 PUSHs(boolSV(do_seek(gv, offset, whence)));
2249 const Off_t sought = do_sysseek(gv, offset, whence);
2251 PUSHs(&PL_sv_undef);
2253 SV* const sv = sought ?
2254 #if LSEEKSIZE > IVSIZE
2259 : newSVpvn(zero_but_true, ZBTLEN);
2269 /* There seems to be no consensus on the length type of truncate()
2270 * and ftruncate(), both off_t and size_t have supporters. In
2271 * general one would think that when using large files, off_t is
2272 * at least as wide as size_t, so using an off_t should be okay. */
2273 /* XXX Configure probe for the length type of *truncate() needed XXX */
2276 #if Off_t_size > IVSIZE
2281 /* Checking for length < 0 is problematic as the type might or
2282 * might not be signed: if it is not, clever compilers will moan. */
2283 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2286 SV * const sv = POPs;
2291 if (PL_op->op_flags & OPf_SPECIAL
2292 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2293 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2300 TAINT_PROPER("truncate");
2301 if (!(fp = IoIFP(io))) {
2305 int fd = PerlIO_fileno(fp);
2307 SETERRNO(EBADF,RMS_IFI);
2311 SETERRNO(EINVAL, LIB_INVARG);
2316 if (ftruncate(fd, len) < 0)
2318 if (my_chsize(fd, len) < 0)
2326 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2327 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2328 goto do_ftruncate_io;
2331 const char * const name = SvPV_nomg_const_nolen(sv);
2332 TAINT_PROPER("truncate");
2334 if (truncate(name, len) < 0)
2341 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
2342 mode |= O_LARGEFILE; /* Transparently largefiley. */
2345 /* On open(), the Win32 CRT tries to seek around text
2346 * files using 32-bit offsets, which causes the open()
2347 * to fail on large files, so open in binary mode.
2351 tmpfd = PerlLIO_open(name, mode);
2356 if (my_chsize(tmpfd, len) < 0)
2358 PerlLIO_close(tmpfd);
2367 SETERRNO(EBADF,RMS_IFI);
2373 /* also used for: pp_fcntl() */
2378 SV * const argsv = POPs;
2379 const unsigned int func = POPu;
2381 GV * const gv = MUTABLE_GV(POPs);
2382 IO * const io = GvIOn(gv);
2388 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2392 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2395 s = SvPV_force(argsv, len);
2396 need = IOCPARM_LEN(func);
2398 s = Sv_Grow(argsv, need + 1);
2399 SvCUR_set(argsv, need);
2402 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2405 retval = SvIV(argsv);
2406 s = INT2PTR(char*,retval); /* ouch */
2409 optype = PL_op->op_type;
2410 TAINT_PROPER(PL_op_desc[optype]);
2412 if (optype == OP_IOCTL)
2414 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2416 DIE(aTHX_ "ioctl is not implemented");
2420 DIE(aTHX_ "fcntl is not implemented");
2422 #if defined(OS2) && defined(__EMX__)
2423 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2425 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2429 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2431 if (s[SvCUR(argsv)] != 17)
2432 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2434 s[SvCUR(argsv)] = 0; /* put our null back */
2435 SvSETMAGIC(argsv); /* Assume it has changed */
2444 PUSHp(zero_but_true, ZBTLEN);
2455 const int argtype = POPi;
2456 GV * const gv = MUTABLE_GV(POPs);
2457 IO *const io = GvIO(gv);
2458 PerlIO *const fp = io ? IoIFP(io) : NULL;
2460 /* XXX Looks to me like io is always NULL at this point */
2462 (void)PerlIO_flush(fp);
2463 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2468 SETERRNO(EBADF,RMS_IFI);
2473 DIE(aTHX_ PL_no_func, "flock");
2484 const int protocol = POPi;
2485 const int type = POPi;
2486 const int domain = POPi;
2487 GV * const gv = MUTABLE_GV(POPs);
2488 IO * const io = GvIOn(gv);
2492 do_close(gv, FALSE);
2494 TAINT_PROPER("socket");
2495 fd = PerlSock_socket(domain, type, protocol);
2497 SETERRNO(EBADF,RMS_IFI);
2500 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2501 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2502 IoTYPE(io) = IoTYPE_SOCKET;
2503 if (!IoIFP(io) || !IoOFP(io)) {
2504 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2505 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2506 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2509 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2510 /* ensure close-on-exec */
2511 if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0)
2521 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2524 const int protocol = POPi;
2525 const int type = POPi;
2526 const int domain = POPi;
2528 GV * const gv2 = MUTABLE_GV(POPs);
2529 IO * const io2 = GvIOn(gv2);
2530 GV * const gv1 = MUTABLE_GV(POPs);
2531 IO * const io1 = GvIOn(gv1);
2534 do_close(gv1, FALSE);
2536 do_close(gv2, FALSE);
2538 TAINT_PROPER("socketpair");
2539 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2541 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2542 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2543 IoTYPE(io1) = IoTYPE_SOCKET;
2544 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2545 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2546 IoTYPE(io2) = IoTYPE_SOCKET;
2547 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2548 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2549 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2550 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2551 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2552 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2553 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2556 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2557 /* ensure close-on-exec */
2558 if ((fd[0] > PL_maxsysfd && fcntl(fd[0], F_SETFD, FD_CLOEXEC) < 0) ||
2559 (fd[1] > PL_maxsysfd && fcntl(fd[1], F_SETFD, FD_CLOEXEC) < 0))
2565 DIE(aTHX_ PL_no_sock_func, "socketpair");
2571 /* also used for: pp_connect() */
2576 SV * const addrsv = POPs;
2577 /* OK, so on what platform does bind modify addr? */
2579 GV * const gv = MUTABLE_GV(POPs);
2580 IO * const io = GvIOn(gv);
2587 fd = PerlIO_fileno(IoIFP(io));
2591 addr = SvPV_const(addrsv, len);
2592 op_type = PL_op->op_type;
2593 TAINT_PROPER(PL_op_desc[op_type]);
2594 if ((op_type == OP_BIND
2595 ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
2596 : PerlSock_connect(fd, (struct sockaddr *)addr, len))
2604 SETERRNO(EBADF,SS_IVCHAN);
2611 const int backlog = POPi;
2612 GV * const gv = MUTABLE_GV(POPs);
2613 IO * const io = GvIOn(gv);
2618 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2625 SETERRNO(EBADF,SS_IVCHAN);
2633 char namebuf[MAXPATHLEN];
2634 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2635 Sock_size_t len = sizeof (struct sockaddr_in);
2637 Sock_size_t len = sizeof namebuf;
2639 GV * const ggv = MUTABLE_GV(POPs);
2640 GV * const ngv = MUTABLE_GV(POPs);
2643 IO * const gstio = GvIO(ggv);
2644 if (!gstio || !IoIFP(gstio))
2648 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2651 /* Some platforms indicate zero length when an AF_UNIX client is
2652 * not bound. Simulate a non-zero-length sockaddr structure in
2654 namebuf[0] = 0; /* sun_len */
2655 namebuf[1] = AF_UNIX; /* sun_family */
2663 do_close(ngv, FALSE);
2664 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2665 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2666 IoTYPE(nstio) = IoTYPE_SOCKET;
2667 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2668 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2669 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2670 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2673 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2674 /* ensure close-on-exec */
2675 if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0)
2679 #ifdef __SCO_VERSION__
2680 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2683 PUSHp(namebuf, len);
2687 report_evil_fh(ggv);
2688 SETERRNO(EBADF,SS_IVCHAN);
2698 const int how = POPi;
2699 GV * const gv = MUTABLE_GV(POPs);
2700 IO * const io = GvIOn(gv);
2705 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2710 SETERRNO(EBADF,SS_IVCHAN);
2715 /* also used for: pp_gsockopt() */
2720 const int optype = PL_op->op_type;
2721 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2722 const unsigned int optname = (unsigned int) POPi;
2723 const unsigned int lvl = (unsigned int) POPi;
2724 GV * const gv = MUTABLE_GV(POPs);
2725 IO * const io = GvIOn(gv);
2732 fd = PerlIO_fileno(IoIFP(io));
2738 (void)SvPOK_only(sv);
2742 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2745 /* XXX Configure test: does getsockopt set the length properly? */
2754 #if defined(__SYMBIAN32__)
2755 # define SETSOCKOPT_OPTION_VALUE_T void *
2757 # define SETSOCKOPT_OPTION_VALUE_T const char *
2759 /* XXX TODO: We need to have a proper type (a Configure probe,
2760 * etc.) for what the C headers think of the third argument of
2761 * setsockopt(), the option_value read-only buffer: is it
2762 * a "char *", or a "void *", const or not. Some compilers
2763 * don't take kindly to e.g. assuming that "char *" implicitly
2764 * promotes to a "void *", or to explicitly promoting/demoting
2765 * consts to non/vice versa. The "const void *" is the SUS
2766 * definition, but that does not fly everywhere for the above
2768 SETSOCKOPT_OPTION_VALUE_T buf;
2772 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2776 aint = (int)SvIV(sv);
2777 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2780 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2790 SETERRNO(EBADF,SS_IVCHAN);
2797 /* also used for: pp_getsockname() */
2802 const int optype = PL_op->op_type;
2803 GV * const gv = MUTABLE_GV(POPs);
2804 IO * const io = GvIOn(gv);
2812 sv = sv_2mortal(newSV(257));
2813 (void)SvPOK_only(sv);
2817 fd = PerlIO_fileno(IoIFP(io));
2821 case OP_GETSOCKNAME:
2822 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2825 case OP_GETPEERNAME:
2826 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2828 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2830 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";
2831 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2832 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2833 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2834 sizeof(u_short) + sizeof(struct in_addr))) {
2841 #ifdef BOGUS_GETNAME_RETURN
2842 /* Interactive Unix, getpeername() and getsockname()
2843 does not return valid namelen */
2844 if (len == BOGUS_GETNAME_RETURN)
2845 len = sizeof(struct sockaddr);
2854 SETERRNO(EBADF,SS_IVCHAN);
2863 /* also used for: pp_lstat() */
2874 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2875 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2876 if (PL_op->op_type == OP_LSTAT) {
2877 if (gv != PL_defgv) {
2878 do_fstat_warning_check:
2879 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2880 "lstat() on filehandle%s%"SVf,
2883 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2885 } else if (PL_laststype != OP_LSTAT)
2886 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2887 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2890 if (gv != PL_defgv) {
2894 PL_laststype = OP_STAT;
2895 PL_statgv = gv ? gv : (GV *)io;
2896 sv_setpvs(PL_statname, "");
2902 int fd = PerlIO_fileno(IoIFP(io));
2904 PL_laststatval = -1;
2905 SETERRNO(EBADF,RMS_IFI);
2907 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
2910 } else if (IoDIRP(io)) {
2912 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2915 PL_laststatval = -1;
2918 else PL_laststatval = -1;
2919 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2922 if (PL_laststatval < 0) {
2928 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2929 io = MUTABLE_IO(SvRV(sv));
2930 if (PL_op->op_type == OP_LSTAT)
2931 goto do_fstat_warning_check;
2932 goto do_fstat_have_io;
2935 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2936 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2938 PL_laststype = PL_op->op_type;
2939 file = SvPV_nolen_const(PL_statname);
2940 if (PL_op->op_type == OP_LSTAT)
2941 PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
2943 PL_laststatval = PerlLIO_stat(file, &PL_statcache);
2944 if (PL_laststatval < 0) {
2945 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
2946 /* PL_warn_nl is constant */
2947 GCC_DIAG_IGNORE(-Wformat-nonliteral);
2948 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2956 if (gimme != G_ARRAY) {
2957 if (gimme != G_VOID)
2958 XPUSHs(boolSV(max));
2964 mPUSHi(PL_statcache.st_dev);
2965 #if ST_INO_SIZE > IVSIZE
2966 mPUSHn(PL_statcache.st_ino);
2968 # if ST_INO_SIGN <= 0
2969 mPUSHi(PL_statcache.st_ino);
2971 mPUSHu(PL_statcache.st_ino);
2974 mPUSHu(PL_statcache.st_mode);
2975 mPUSHu(PL_statcache.st_nlink);
2977 sv_setuid(PUSHmortal, PL_statcache.st_uid);
2978 sv_setgid(PUSHmortal, PL_statcache.st_gid);
2980 #ifdef USE_STAT_RDEV
2981 mPUSHi(PL_statcache.st_rdev);
2983 PUSHs(newSVpvs_flags("", SVs_TEMP));
2985 #if Off_t_size > IVSIZE
2986 mPUSHn(PL_statcache.st_size);
2988 mPUSHi(PL_statcache.st_size);
2991 mPUSHn(PL_statcache.st_atime);
2992 mPUSHn(PL_statcache.st_mtime);
2993 mPUSHn(PL_statcache.st_ctime);
2995 mPUSHi(PL_statcache.st_atime);
2996 mPUSHi(PL_statcache.st_mtime);
2997 mPUSHi(PL_statcache.st_ctime);
2999 #ifdef USE_STAT_BLOCKS
3000 mPUSHu(PL_statcache.st_blksize);
3001 mPUSHu(PL_statcache.st_blocks);
3003 PUSHs(newSVpvs_flags("", SVs_TEMP));
3004 PUSHs(newSVpvs_flags("", SVs_TEMP));
3010 /* All filetest ops avoid manipulating the perl stack pointer in their main
3011 bodies (since commit d2c4d2d1e22d3125), and return using either
3012 S_ft_return_false() or S_ft_return_true(). These two helper functions are
3013 the only two which manipulate the perl stack. To ensure that no stack
3014 manipulation macros are used, the filetest ops avoid defining a local copy
3015 of the stack pointer with dSP. */
3017 /* If the next filetest is stacked up with this one
3018 (PL_op->op_private & OPpFT_STACKING), we leave
3019 the original argument on the stack for success,
3020 and skip the stacked operators on failure.
3021 The next few macros/functions take care of this.
3025 S_ft_return_false(pTHX_ SV *ret) {
3029 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
3033 if (PL_op->op_private & OPpFT_STACKING) {
3034 while (OP_IS_FILETEST(next->op_type)
3035 && next->op_private & OPpFT_STACKED)
3036 next = next->op_next;
3041 PERL_STATIC_INLINE OP *
3042 S_ft_return_true(pTHX_ SV *ret) {
3044 if (PL_op->op_flags & OPf_REF)
3045 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
3046 else if (!(PL_op->op_private & OPpFT_STACKING))
3052 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
3053 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
3054 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
3056 #define tryAMAGICftest_MG(chr) STMT_START { \
3057 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
3058 && PL_op->op_flags & OPf_KIDS) { \
3059 OP *next = S_try_amagic_ftest(aTHX_ chr); \
3060 if (next) return next; \
3065 S_try_amagic_ftest(pTHX_ char chr) {
3066 SV *const arg = *PL_stack_sp;
3069 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
3073 const char tmpchr = chr;
3074 SV * const tmpsv = amagic_call(arg,
3075 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
3076 ftest_amg, AMGf_unary);
3081 return SvTRUE(tmpsv)
3082 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
3088 /* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec()
3094 /* Not const, because things tweak this below. Not bool, because there's
3095 no guarantee that OPpFT_ACCESS is <= CHAR_MAX */
3096 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3097 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3098 /* Giving some sort of initial value silences compilers. */
3100 int access_mode = R_OK;
3102 int access_mode = 0;
3105 /* access_mode is never used, but leaving use_access in makes the
3106 conditional compiling below much clearer. */
3109 Mode_t stat_mode = S_IRUSR;
3111 bool effective = FALSE;
3114 switch (PL_op->op_type) {
3115 case OP_FTRREAD: opchar = 'R'; break;
3116 case OP_FTRWRITE: opchar = 'W'; break;
3117 case OP_FTREXEC: opchar = 'X'; break;
3118 case OP_FTEREAD: opchar = 'r'; break;
3119 case OP_FTEWRITE: opchar = 'w'; break;
3120 case OP_FTEEXEC: opchar = 'x'; break;
3122 tryAMAGICftest_MG(opchar);
3124 switch (PL_op->op_type) {
3126 #if !(defined(HAS_ACCESS) && defined(R_OK))
3132 #if defined(HAS_ACCESS) && defined(W_OK)
3137 stat_mode = S_IWUSR;
3141 #if defined(HAS_ACCESS) && defined(X_OK)
3146 stat_mode = S_IXUSR;
3150 #ifdef PERL_EFF_ACCESS
3153 stat_mode = S_IWUSR;
3157 #ifndef PERL_EFF_ACCESS
3164 #ifdef PERL_EFF_ACCESS
3169 stat_mode = S_IXUSR;
3175 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3176 const char *name = SvPV_nolen(*PL_stack_sp);
3178 # ifdef PERL_EFF_ACCESS
3179 result = PERL_EFF_ACCESS(name, access_mode);
3181 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3187 result = access(name, access_mode);
3189 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3200 result = my_stat_flags(0);
3203 if (cando(stat_mode, effective, &PL_statcache))
3209 /* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */
3214 const int op_type = PL_op->op_type;
3218 case OP_FTIS: opchar = 'e'; break;
3219 case OP_FTSIZE: opchar = 's'; break;
3220 case OP_FTMTIME: opchar = 'M'; break;
3221 case OP_FTCTIME: opchar = 'C'; break;
3222 case OP_FTATIME: opchar = 'A'; break;
3224 tryAMAGICftest_MG(opchar);
3226 result = my_stat_flags(0);
3229 if (op_type == OP_FTIS)
3232 /* You can't dTARGET inside OP_FTIS, because you'll get
3233 "panic: pad_sv po" - the op is not flagged to have a target. */
3237 #if Off_t_size > IVSIZE
3238 sv_setnv(TARG, (NV)PL_statcache.st_size);
3240 sv_setiv(TARG, (IV)PL_statcache.st_size);
3245 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3249 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3253 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3257 return SvTRUE_nomg(TARG)
3258 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3263 /* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned()
3264 * pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock()
3265 * pp_ftsuid() pp_ftsvtx() pp_ftzero() */
3272 switch (PL_op->op_type) {
3273 case OP_FTROWNED: opchar = 'O'; break;
3274 case OP_FTEOWNED: opchar = 'o'; break;
3275 case OP_FTZERO: opchar = 'z'; break;
3276 case OP_FTSOCK: opchar = 'S'; break;
3277 case OP_FTCHR: opchar = 'c'; break;
3278 case OP_FTBLK: opchar = 'b'; break;
3279 case OP_FTFILE: opchar = 'f'; break;
3280 case OP_FTDIR: opchar = 'd'; break;
3281 case OP_FTPIPE: opchar = 'p'; break;
3282 case OP_FTSUID: opchar = 'u'; break;
3283 case OP_FTSGID: opchar = 'g'; break;
3284 case OP_FTSVTX: opchar = 'k'; break;
3286 tryAMAGICftest_MG(opchar);
3288 /* I believe that all these three are likely to be defined on most every
3289 system these days. */
3291 if(PL_op->op_type == OP_FTSUID) {
3296 if(PL_op->op_type == OP_FTSGID) {
3301 if(PL_op->op_type == OP_FTSVTX) {
3306 result = my_stat_flags(0);
3309 switch (PL_op->op_type) {
3311 if (PL_statcache.st_uid == PerlProc_getuid())
3315 if (PL_statcache.st_uid == PerlProc_geteuid())
3319 if (PL_statcache.st_size == 0)
3323 if (S_ISSOCK(PL_statcache.st_mode))
3327 if (S_ISCHR(PL_statcache.st_mode))
3331 if (S_ISBLK(PL_statcache.st_mode))
3335 if (S_ISREG(PL_statcache.st_mode))
3339 if (S_ISDIR(PL_statcache.st_mode))
3343 if (S_ISFIFO(PL_statcache.st_mode))
3348 if (PL_statcache.st_mode & S_ISUID)
3354 if (PL_statcache.st_mode & S_ISGID)
3360 if (PL_statcache.st_mode & S_ISVTX)
3372 tryAMAGICftest_MG('l');
3373 result = my_lstat_flags(0);
3377 if (S_ISLNK(PL_statcache.st_mode))
3390 tryAMAGICftest_MG('t');
3392 if (PL_op->op_flags & OPf_REF)
3395 SV *tmpsv = *PL_stack_sp;
3396 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3397 name = SvPV_nomg(tmpsv, namelen);
3398 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3402 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3403 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3404 else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX)
3409 SETERRNO(EBADF,RMS_IFI);
3412 if (PerlLIO_isatty(fd))
3418 /* also used for: pp_ftbinary() */
3432 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3434 if (PL_op->op_flags & OPf_REF)
3436 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3441 gv = MAYBE_DEREF_GV_nomg(sv);
3445 if (gv == PL_defgv) {
3447 io = SvTYPE(PL_statgv) == SVt_PVIO
3451 goto really_filename;
3456 sv_setpvs(PL_statname, "");
3457 io = GvIO(PL_statgv);
3459 PL_laststatval = -1;
3460 PL_laststype = OP_STAT;
3461 if (io && IoIFP(io)) {
3463 if (! PerlIO_has_base(IoIFP(io)))
3464 DIE(aTHX_ "-T and -B not implemented on filehandles");
3465 fd = PerlIO_fileno(IoIFP(io));
3467 SETERRNO(EBADF,RMS_IFI);
3470 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3471 if (PL_laststatval < 0)
3473 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3474 if (PL_op->op_type == OP_FTTEXT)
3479 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3480 i = PerlIO_getc(IoIFP(io));
3482 (void)PerlIO_ungetc(IoIFP(io),i);
3484 /* null file is anything */
3487 len = PerlIO_get_bufsiz(IoIFP(io));
3488 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3489 /* sfio can have large buffers - limit to 512 */
3494 SETERRNO(EBADF,RMS_IFI);
3496 SETERRNO(EBADF,RMS_IFI);
3505 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3507 file = SvPVX_const(PL_statname);
3509 if (!(fp = PerlIO_open(file, "r"))) {
3511 PL_laststatval = -1;
3512 PL_laststype = OP_STAT;
3514 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
3515 /* PL_warn_nl is constant */
3516 GCC_DIAG_IGNORE(-Wformat-nonliteral);
3517 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3522 PL_laststype = OP_STAT;
3523 fd = PerlIO_fileno(fp);
3525 (void)PerlIO_close(fp);
3526 SETERRNO(EBADF,RMS_IFI);
3529 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3530 if (PL_laststatval < 0) {
3531 (void)PerlIO_close(fp);
3532 SETERRNO(EBADF,RMS_IFI);
3535 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3536 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3537 (void)PerlIO_close(fp);
3539 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3540 FT_RETURNNO; /* special case NFS directories */
3541 FT_RETURNYES; /* null file is anything */
3546 /* now scan s to look for textiness */
3548 #if defined(DOSISH) || defined(USEMYBINMODE)
3549 /* ignore trailing ^Z on short files */
3550 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3555 if (! is_invariant_string((U8 *) s, len)) {
3558 /* Here contains a variant under UTF-8 . See if the entire string is
3559 * UTF-8. But the buffer may end in a partial character, so consider
3560 * it UTF-8 if the first non-UTF8 char is an ending partial */
3561 if (is_utf8_string_loc((U8 *) s, len, &ep)
3562 || ep + UTF8SKIP(ep) > (U8 *) (s + len))
3564 if (PL_op->op_type == OP_FTTEXT) {
3573 /* Here, is not UTF-8 or is entirely ASCII. Look through the buffer for
3574 * things that wouldn't be in ASCII text or rich ASCII text. Count these
3576 for (i = 0; i < len; i++, s++) {
3577 if (!*s) { /* null never allowed in text */
3581 #ifdef USE_LOCALE_CTYPE
3582 if (IN_LC_RUNTIME(LC_CTYPE)) {
3583 if ( isPRINT_LC(*s) || isSPACE_LC(*s)) {
3590 /* VT occurs so rarely in text, that we consider it odd */
3591 || (isSPACE_A(*s) && *s != VT_NATIVE)
3593 /* But there is a fair amount of backspaces and escapes in
3596 || *s == ESC_NATIVE)
3603 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3614 const char *tmps = NULL;
3618 SV * const sv = POPs;
3619 if (PL_op->op_flags & OPf_SPECIAL) {
3620 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3622 if (ckWARN(WARN_UNOPENED)) {
3623 Perl_warner(aTHX_ packWARN(WARN_UNOPENED),
3624 "chdir() on unopened filehandle %" SVf, sv);
3626 SETERRNO(EBADF,RMS_IFI);
3628 TAINT_PROPER("chdir");
3632 else if (!(gv = MAYBE_DEREF_GV(sv)))
3633 tmps = SvPV_nomg_const_nolen(sv);
3636 HV * const table = GvHVn(PL_envgv);
3639 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3640 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3642 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3646 tmps = SvPV_nolen_const(*svp);
3650 SETERRNO(EINVAL, LIB_INVARG);
3651 TAINT_PROPER("chdir");
3656 TAINT_PROPER("chdir");
3659 IO* const io = GvIO(gv);
3662 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3663 } else if (IoIFP(io)) {
3664 int fd = PerlIO_fileno(IoIFP(io));
3668 PUSHi(fchdir(fd) >= 0);
3678 DIE(aTHX_ PL_no_func, "fchdir");
3682 PUSHi( PerlDir_chdir(tmps) >= 0 );
3684 /* Clear the DEFAULT element of ENV so we'll get the new value
3686 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3693 SETERRNO(EBADF,RMS_IFI);
3700 /* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */
3704 dSP; dMARK; dTARGET;
3705 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3716 char * const tmps = POPpx;
3717 TAINT_PROPER("chroot");
3718 PUSHi( chroot(tmps) >= 0 );
3721 DIE(aTHX_ PL_no_func, "chroot");
3732 const char * const tmps2 = POPpconstx;
3733 const char * const tmps = SvPV_nolen_const(TOPs);
3734 TAINT_PROPER("rename");
3736 anum = PerlLIO_rename(tmps, tmps2);
3738 if (!(anum = PerlLIO_stat(tmps, &statbuf))) {
3739 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3742 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
3743 (void)UNLINK(tmps2);
3744 if (!(anum = link(tmps, tmps2)))
3745 anum = UNLINK(tmps);
3754 /* also used for: pp_symlink() */
3756 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3760 const int op_type = PL_op->op_type;
3764 if (op_type == OP_LINK)
3765 DIE(aTHX_ PL_no_func, "link");
3767 # ifndef HAS_SYMLINK
3768 if (op_type == OP_SYMLINK)
3769 DIE(aTHX_ PL_no_func, "symlink");
3773 const char * const tmps2 = POPpconstx;
3774 const char * const tmps = SvPV_nolen_const(TOPs);
3775 TAINT_PROPER(PL_op_desc[op_type]);
3777 # if defined(HAS_LINK)
3778 # if defined(HAS_SYMLINK)
3779 /* Both present - need to choose which. */
3780 (op_type == OP_LINK) ?
3781 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3783 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3784 PerlLIO_link(tmps, tmps2);
3787 # if defined(HAS_SYMLINK)
3788 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3789 symlink(tmps, tmps2);
3794 SETi( result >= 0 );
3799 /* also used for: pp_symlink() */
3804 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3814 char buf[MAXPATHLEN];
3819 /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
3820 * it is impossible to know whether the result was truncated. */
3821 len = readlink(tmps, buf, sizeof(buf) - 1);
3830 RETSETUNDEF; /* just pretend it's a normal file */
3834 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3836 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3838 char * const save_filename = filename;
3843 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3845 PERL_ARGS_ASSERT_DOONELINER;
3847 Newx(cmdline, size, char);
3848 my_strlcpy(cmdline, cmd, size);
3849 my_strlcat(cmdline, " ", size);
3850 for (s = cmdline + strlen(cmdline); *filename; ) {
3854 if (s - cmdline < size)
3855 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3856 myfp = PerlProc_popen(cmdline, "r");
3860 SV * const tmpsv = sv_newmortal();
3861 /* Need to save/restore 'PL_rs' ?? */
3862 s = sv_gets(tmpsv, myfp, 0);
3863 (void)PerlProc_pclose(myfp);
3867 #ifdef HAS_SYS_ERRLIST
3872 /* you don't see this */
3873 const char * const errmsg = Strerror(e) ;
3876 if (instr(s, errmsg)) {
3883 #define EACCES EPERM
3885 if (instr(s, "cannot make"))
3886 SETERRNO(EEXIST,RMS_FEX);
3887 else if (instr(s, "existing file"))
3888 SETERRNO(EEXIST,RMS_FEX);
3889 else if (instr(s, "ile exists"))
3890 SETERRNO(EEXIST,RMS_FEX);
3891 else if (instr(s, "non-exist"))
3892 SETERRNO(ENOENT,RMS_FNF);
3893 else if (instr(s, "does not exist"))
3894 SETERRNO(ENOENT,RMS_FNF);
3895 else if (instr(s, "not empty"))
3896 SETERRNO(EBUSY,SS_DEVOFFLINE);
3897 else if (instr(s, "cannot access"))
3898 SETERRNO(EACCES,RMS_PRV);
3900 SETERRNO(EPERM,RMS_PRV);
3903 else { /* some mkdirs return no failure indication */
3905 anum = (PerlLIO_stat(save_filename, &statbuf) >= 0);
3906 if (PL_op->op_type == OP_RMDIR)
3911 SETERRNO(EACCES,RMS_PRV); /* a guess */
3920 /* This macro removes trailing slashes from a directory name.
3921 * Different operating and file systems take differently to
3922 * trailing slashes. According to POSIX 1003.1 1996 Edition
3923 * any number of trailing slashes should be allowed.
3924 * Thusly we snip them away so that even non-conforming
3925 * systems are happy.
3926 * We should probably do this "filtering" for all
3927 * the functions that expect (potentially) directory names:
3928 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3929 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3931 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3932 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3935 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3936 (tmps) = savepvn((tmps), (len)); \
3946 const unsigned int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPu : 0777;
3948 TRIMSLASHES(tmps,len,copy);
3950 TAINT_PROPER("mkdir");
3952 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3956 SETi( dooneliner("mkdir", tmps) );
3957 oldumask = PerlLIO_umask(0);
3958 PerlLIO_umask(oldumask);
3959 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3974 TRIMSLASHES(tmps,len,copy);
3975 TAINT_PROPER("rmdir");
3977 SETi( PerlDir_rmdir(tmps) >= 0 );
3979 SETi( dooneliner("rmdir", tmps) );
3986 /* Directory calls. */
3990 #if defined(Direntry_t) && defined(HAS_READDIR)
3992 const char * const dirname = POPpconstx;
3993 GV * const gv = MUTABLE_GV(POPs);
3994 IO * const io = GvIOn(gv);
3996 if ((IoIFP(io) || IoOFP(io)))
3997 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3998 "Opening filehandle %"HEKf" also as a directory",
3999 HEKfARG(GvENAME_HEK(gv)) );
4001 PerlDir_close(IoDIRP(io));
4002 if (!(IoDIRP(io) = PerlDir_open(dirname)))
4008 SETERRNO(EBADF,RMS_DIR);
4011 DIE(aTHX_ PL_no_dir_func, "opendir");
4017 #if !defined(Direntry_t) || !defined(HAS_READDIR)
4018 DIE(aTHX_ PL_no_dir_func, "readdir");
4020 #if !defined(I_DIRENT) && !defined(VMS)
4021 Direntry_t *readdir (DIR *);
4026 const I32 gimme = GIMME_V;
4027 GV * const gv = MUTABLE_GV(POPs);
4028 const Direntry_t *dp;
4029 IO * const io = GvIOn(gv);
4032 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4033 "readdir() attempted on invalid dirhandle %"HEKf,
4034 HEKfARG(GvENAME_HEK(gv)));
4039 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
4043 sv = newSVpvn(dp->d_name, dp->d_namlen);
4045 sv = newSVpv(dp->d_name, 0);
4047 if (!(IoFLAGS(io) & IOf_UNTAINT))
4050 } while (gimme == G_ARRAY);
4052 if (!dp && gimme != G_ARRAY)
4059 SETERRNO(EBADF,RMS_ISI);
4060 if (gimme == G_ARRAY)
4069 #if defined(HAS_TELLDIR) || defined(telldir)
4071 /* XXX does _anyone_ need this? --AD 2/20/1998 */
4072 /* XXX netbsd still seemed to.
4073 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
4074 --JHI 1999-Feb-02 */
4075 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
4076 long telldir (DIR *);
4078 GV * const gv = MUTABLE_GV(POPs);
4079 IO * const io = GvIOn(gv);
4082 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4083 "telldir() attempted on invalid dirhandle %"HEKf,
4084 HEKfARG(GvENAME_HEK(gv)));
4088 PUSHi( PerlDir_tell(IoDIRP(io)) );
4092 SETERRNO(EBADF,RMS_ISI);
4095 DIE(aTHX_ PL_no_dir_func, "telldir");
4101 #if defined(HAS_SEEKDIR) || defined(seekdir)
4103 const long along = POPl;
4104 GV * const gv = MUTABLE_GV(POPs);
4105 IO * const io = GvIOn(gv);
4108 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4109 "seekdir() attempted on invalid dirhandle %"HEKf,
4110 HEKfARG(GvENAME_HEK(gv)));
4113 (void)PerlDir_seek(IoDIRP(io), along);
4118 SETERRNO(EBADF,RMS_ISI);
4121 DIE(aTHX_ PL_no_dir_func, "seekdir");
4127 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4129 GV * const gv = MUTABLE_GV(POPs);
4130 IO * const io = GvIOn(gv);
4133 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4134 "rewinddir() attempted on invalid dirhandle %"HEKf,
4135 HEKfARG(GvENAME_HEK(gv)));
4138 (void)PerlDir_rewind(IoDIRP(io));
4142 SETERRNO(EBADF,RMS_ISI);
4145 DIE(aTHX_ PL_no_dir_func, "rewinddir");
4151 #if defined(Direntry_t) && defined(HAS_READDIR)
4153 GV * const gv = MUTABLE_GV(POPs);
4154 IO * const io = GvIOn(gv);
4157 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4158 "closedir() attempted on invalid dirhandle %"HEKf,
4159 HEKfARG(GvENAME_HEK(gv)));
4162 #ifdef VOID_CLOSEDIR
4163 PerlDir_close(IoDIRP(io));
4165 if (PerlDir_close(IoDIRP(io)) < 0) {
4166 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4175 SETERRNO(EBADF,RMS_IFI);
4178 DIE(aTHX_ PL_no_dir_func, "closedir");
4182 /* Process control. */
4189 #ifdef HAS_SIGPROCMASK
4190 sigset_t oldmask, newmask;
4194 PERL_FLUSHALL_FOR_CHILD;
4195 #ifdef HAS_SIGPROCMASK
4196 sigfillset(&newmask);
4197 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4199 childpid = PerlProc_fork();
4200 if (childpid == 0) {
4204 for (sig = 1; sig < SIG_SIZE; sig++)
4205 PL_psig_pend[sig] = 0;
4207 #ifdef HAS_SIGPROCMASK
4210 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4217 #ifdef PERL_USES_PL_PIDSTATUS
4218 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4224 # if (defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)) || defined(__amigaos4__)
4229 PERL_FLUSHALL_FOR_CHILD;
4230 childpid = PerlProc_fork();
4236 DIE(aTHX_ PL_no_func, "fork");
4243 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4248 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4249 childpid = wait4pid(-1, &argflags, 0);
4251 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4256 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4257 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4258 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4260 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4265 DIE(aTHX_ PL_no_func, "wait");
4271 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4273 const int optype = POPi;
4274 const Pid_t pid = TOPi;
4278 result = amigaos_waitpid(aTHX_ optype, pid, &argflags);
4279 STATUS_NATIVE_CHILD_SET((result >= 0) ? argflags : -1);
4280 result = result == 0 ? pid : -1;
4284 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4285 result = wait4pid(pid, &argflags, optype);
4287 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4292 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4293 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4294 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4296 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4298 # endif /* __amigaos4__ */
4302 DIE(aTHX_ PL_no_func, "waitpid");
4308 dSP; dMARK; dORIGMARK; dTARGET;
4309 #if defined(__LIBCATAMOUNT__)
4310 PL_statusvalue = -1;
4315 # ifdef __amigaos4__
4323 while (++MARK <= SP) {
4324 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4329 TAINT_PROPER("system");
4331 PERL_FLUSHALL_FOR_CHILD;
4332 #if (defined(HAS_FORK) || defined(__amigaos4__)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4335 struct UserData userdata;
4342 bool child_success = FALSE;
4343 #ifdef HAS_SIGPROCMASK
4344 sigset_t newset, oldset;
4347 if (PerlProc_pipe(pp) >= 0)
4350 amigaos_fork_set_userdata(aTHX_
4356 pthread_create(&proc,NULL,amigaos_system_child,(void *)&userdata);
4357 child_success = proc > 0;
4359 #ifdef HAS_SIGPROCMASK
4360 sigemptyset(&newset);
4361 sigaddset(&newset, SIGCHLD);
4362 sigprocmask(SIG_BLOCK, &newset, &oldset);
4364 while ((childpid = PerlProc_fork()) == -1) {
4365 if (errno != EAGAIN) {
4370 PerlLIO_close(pp[0]);
4371 PerlLIO_close(pp[1]);
4373 #ifdef HAS_SIGPROCMASK
4374 sigprocmask(SIG_SETMASK, &oldset, NULL);
4380 child_success = childpid > 0;
4382 if (child_success) {
4383 Sigsave_t ihand,qhand; /* place to save signals during system() */
4386 #ifndef __amigaos4__
4388 PerlLIO_close(pp[1]);
4391 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4392 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4395 result = pthread_join(proc, (void **)&status);
4398 result = wait4pid(childpid, &status, 0);
4399 } while (result == -1 && errno == EINTR);
4402 #ifdef HAS_SIGPROCMASK
4403 sigprocmask(SIG_SETMASK, &oldset, NULL);
4405 (void)rsignal_restore(SIGINT, &ihand);
4406 (void)rsignal_restore(SIGQUIT, &qhand);
4408 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4409 do_execfree(); /* free any memory child malloced on fork */
4416 while (n < sizeof(int)) {
4417 n1 = PerlLIO_read(pp[0],
4418 (void*)(((char*)&errkid)+n),
4424 PerlLIO_close(pp[0]);
4425 if (n) { /* Error */
4426 if (n != sizeof(int))
4427 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4428 errno = errkid; /* Propagate errno from kid */
4430 /* The pipe always has something in it
4431 * so n alone is not enough. */
4435 STATUS_NATIVE_CHILD_SET(-1);
4439 XPUSHi(STATUS_CURRENT);
4442 #ifndef __amigaos4__
4443 #ifdef HAS_SIGPROCMASK
4444 sigprocmask(SIG_SETMASK, &oldset, NULL);
4447 PerlLIO_close(pp[0]);
4448 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
4449 if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
4453 if (PL_op->op_flags & OPf_STACKED) {
4454 SV * const really = *++MARK;
4455 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4457 else if (SP - MARK != 1)
4458 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4460 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4462 #endif /* __amigaos4__ */
4465 #else /* ! FORK or VMS or OS/2 */
4468 if (PL_op->op_flags & OPf_STACKED) {
4469 SV * const really = *++MARK;
4470 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4471 value = (I32)do_aspawn(really, MARK, SP);
4473 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4476 else if (SP - MARK != 1) {
4477 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4478 value = (I32)do_aspawn(NULL, MARK, SP);
4480 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4484 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4486 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4488 STATUS_NATIVE_CHILD_SET(value);
4491 XPUSHi(result ? value : STATUS_CURRENT);
4492 #endif /* !FORK or VMS or OS/2 */
4499 dSP; dMARK; dORIGMARK; dTARGET;
4504 while (++MARK <= SP) {
4505 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4510 TAINT_PROPER("exec");
4513 PERL_FLUSHALL_FOR_CHILD;
4514 if (PL_op->op_flags & OPf_STACKED) {
4515 SV * const really = *++MARK;
4516 value = (I32)do_aexec(really, MARK, SP);
4518 else if (SP - MARK != 1)
4520 value = (I32)vms_do_aexec(NULL, MARK, SP);
4522 value = (I32)do_aexec(NULL, MARK, SP);
4526 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4528 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4540 XPUSHi( getppid() );
4543 DIE(aTHX_ PL_no_func, "getppid");
4553 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4556 pgrp = (I32)BSD_GETPGRP(pid);
4558 if (pid != 0 && pid != PerlProc_getpid())
4559 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4565 DIE(aTHX_ PL_no_func, "getpgrp");
4575 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4576 if (MAXARG > 0) pid = TOPs ? TOPi : 0;
4583 TAINT_PROPER("setpgrp");
4585 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4587 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4588 || (pid != 0 && pid != PerlProc_getpid()))
4590 DIE(aTHX_ "setpgrp can't take arguments");
4592 SETi( setpgrp() >= 0 );
4593 #endif /* USE_BSDPGRP */
4596 DIE(aTHX_ PL_no_func, "setpgrp");
4600 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4601 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4603 # define PRIORITY_WHICH_T(which) which
4608 #ifdef HAS_GETPRIORITY
4610 const int who = POPi;
4611 const int which = TOPi;
4612 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4615 DIE(aTHX_ PL_no_func, "getpriority");
4621 #ifdef HAS_SETPRIORITY
4623 const int niceval = POPi;
4624 const int who = POPi;
4625 const int which = TOPi;
4626 TAINT_PROPER("setpriority");
4627 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4630 DIE(aTHX_ PL_no_func, "setpriority");
4634 #undef PRIORITY_WHICH_T
4642 XPUSHn( time(NULL) );
4644 XPUSHi( time(NULL) );
4653 struct tms timesbuf;
4656 (void)PerlProc_times(×buf);
4658 mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
4659 if (GIMME_V == G_ARRAY) {
4660 mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
4661 mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
4662 mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
4670 if (GIMME_V == G_ARRAY) {
4677 DIE(aTHX_ "times not implemented");
4679 #endif /* HAS_TIMES */
4682 /* The 32 bit int year limits the times we can represent to these
4683 boundaries with a few days wiggle room to account for time zone
4686 /* Sat Jan 3 00:00:00 -2147481748 */
4687 #define TIME_LOWER_BOUND -67768100567755200.0
4688 /* Sun Dec 29 12:00:00 2147483647 */
4689 #define TIME_UPPER_BOUND 67767976233316800.0
4692 /* also used for: pp_localtime() */
4700 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4701 static const char * const dayname[] =
4702 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4703 static const char * const monname[] =
4704 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4705 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4707 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4710 when = (Time64_T)now;
4713 NV input = Perl_floor(POPn);
4714 const bool pl_isnan = Perl_isnan(input);
4715 when = (Time64_T)input;
4716 if (UNLIKELY(pl_isnan || when != input)) {
4717 /* diag_listed_as: gmtime(%f) too large */
4718 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4719 "%s(%.0" NVff ") too large", opname, input);
4727 if ( TIME_LOWER_BOUND > when ) {
4728 /* diag_listed_as: gmtime(%f) too small */
4729 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4730 "%s(%.0" NVff ") too small", opname, when);
4733 else if( when > TIME_UPPER_BOUND ) {
4734 /* diag_listed_as: gmtime(%f) too small */
4735 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4736 "%s(%.0" NVff ") too large", opname, when);
4740 if (PL_op->op_type == OP_LOCALTIME)
4741 err = Perl_localtime64_r(&when, &tmbuf);
4743 err = Perl_gmtime64_r(&when, &tmbuf);
4747 /* diag_listed_as: gmtime(%f) failed */
4748 /* XXX %lld broken for quads */
4750 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4751 "%s(%.0" NVff ") failed", opname, when);
4754 if (GIMME_V != G_ARRAY) { /* scalar context */
4761 Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %"IVdf,
4762 dayname[tmbuf.tm_wday],
4763 monname[tmbuf.tm_mon],
4768 (IV)tmbuf.tm_year + 1900);
4771 else { /* list context */
4777 mPUSHi(tmbuf.tm_sec);
4778 mPUSHi(tmbuf.tm_min);
4779 mPUSHi(tmbuf.tm_hour);
4780 mPUSHi(tmbuf.tm_mday);
4781 mPUSHi(tmbuf.tm_mon);
4782 mPUSHn(tmbuf.tm_year);
4783 mPUSHi(tmbuf.tm_wday);
4784 mPUSHi(tmbuf.tm_yday);
4785 mPUSHi(tmbuf.tm_isdst);
4794 /* alarm() takes an unsigned int number of seconds, and return the
4795 * unsigned int number of seconds remaining in the previous alarm
4796 * (alarms don't stack). Therefore negative return values are not
4800 /* Note that while the C library function alarm() as such has
4801 * no errors defined (or in other words, properly behaving client
4802 * code shouldn't expect any), alarm() being obsoleted by
4803 * setitimer() and often being implemented in terms of
4804 * setitimer(), can fail. */
4805 /* diag_listed_as: %s() with negative argument */
4806 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4807 "alarm() with negative argument");
4808 SETERRNO(EINVAL, LIB_INVARG);
4812 unsigned int retval = alarm(anum);
4813 if ((int)retval < 0) /* Strictly speaking "cannot happen". */
4819 DIE(aTHX_ PL_no_func, "alarm");
4830 (void)time(&lasttime);
4831 if (MAXARG < 1 || (!TOPs && !POPs))
4836 /* diag_listed_as: %s() with negative argument */
4837 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4838 "sleep() with negative argument");
4839 SETERRNO(EINVAL, LIB_INVARG);
4843 PerlProc_sleep((unsigned int)duration);
4847 XPUSHi(when - lasttime);
4851 /* Shared memory. */
4852 /* Merged with some message passing. */
4854 /* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */
4858 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4859 dSP; dMARK; dTARGET;
4860 const int op_type = PL_op->op_type;
4865 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4868 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4871 value = (I32)(do_semop(MARK, SP) >= 0);
4874 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4882 return Perl_pp_semget(aTHX);
4888 /* also used for: pp_msgget() pp_shmget() */
4892 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4893 dSP; dMARK; dTARGET;
4894 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4901 DIE(aTHX_ "System V IPC is not implemented on this machine");
4905 /* also used for: pp_msgctl() pp_shmctl() */
4909 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4910 dSP; dMARK; dTARGET;
4911 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4919 PUSHp(zero_but_true, ZBTLEN);
4923 return Perl_pp_semget(aTHX);
4927 /* I can't const this further without getting warnings about the types of
4928 various arrays passed in from structures. */
4930 S_space_join_names_mortal(pTHX_ char *const *array)
4934 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4937 target = newSVpvs_flags("", SVs_TEMP);
4939 sv_catpv(target, *array);
4942 sv_catpvs(target, " ");
4945 target = sv_mortalcopy(&PL_sv_no);
4950 /* Get system info. */
4952 /* also used for: pp_ghbyaddr() pp_ghbyname() */
4956 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4958 I32 which = PL_op->op_type;
4961 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4962 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4963 struct hostent *gethostbyname(Netdb_name_t);
4964 struct hostent *gethostent(void);
4966 struct hostent *hent = NULL;
4970 if (which == OP_GHBYNAME) {
4971 #ifdef HAS_GETHOSTBYNAME
4972 const char* const name = POPpbytex;
4973 hent = PerlSock_gethostbyname(name);
4975 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4978 else if (which == OP_GHBYADDR) {
4979 #ifdef HAS_GETHOSTBYADDR
4980 const int addrtype = POPi;
4981 SV * const addrsv = POPs;
4983 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4985 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4987 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4991 #ifdef HAS_GETHOSTENT
4992 hent = PerlSock_gethostent();
4994 DIE(aTHX_ PL_no_sock_func, "gethostent");
4997 #ifdef HOST_NOT_FOUND
4999 #ifdef USE_REENTRANT_API
5000 # ifdef USE_GETHOSTENT_ERRNO
5001 h_errno = PL_reentrant_buffer->_gethostent_errno;
5004 STATUS_UNIX_SET(h_errno);
5008 if (GIMME_V != G_ARRAY) {
5009 PUSHs(sv = sv_newmortal());
5011 if (which == OP_GHBYNAME) {
5013 sv_setpvn(sv, hent->h_addr, hent->h_length);
5016 sv_setpv(sv, (char*)hent->h_name);
5022 mPUSHs(newSVpv((char*)hent->h_name, 0));
5023 PUSHs(space_join_names_mortal(hent->h_aliases));
5024 mPUSHi(hent->h_addrtype);
5025 len = hent->h_length;
5028 for (elem = hent->h_addr_list; elem && *elem; elem++) {
5029 mXPUSHp(*elem, len);
5033 mPUSHp(hent->h_addr, len);
5035 PUSHs(sv_mortalcopy(&PL_sv_no));
5040 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5044 /* also used for: pp_gnbyaddr() pp_gnbyname() */
5048 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
5050 I32 which = PL_op->op_type;
5052 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
5053 struct netent *getnetbyaddr(Netdb_net_t, int);
5054 struct netent *getnetbyname(Netdb_name_t);
5055 struct netent *getnetent(void);
5057 struct netent *nent;
5059 if (which == OP_GNBYNAME){
5060 #ifdef HAS_GETNETBYNAME
5061 const char * const name = POPpbytex;
5062 nent = PerlSock_getnetbyname(name);
5064 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
5067 else if (which == OP_GNBYADDR) {
5068 #ifdef HAS_GETNETBYADDR
5069 const int addrtype = POPi;
5070 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
5071 nent = PerlSock_getnetbyaddr(addr, addrtype);
5073 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
5077 #ifdef HAS_GETNETENT
5078 nent = PerlSock_getnetent();
5080 DIE(aTHX_ PL_no_sock_func, "getnetent");
5083 #ifdef HOST_NOT_FOUND
5085 #ifdef USE_REENTRANT_API
5086 # ifdef USE_GETNETENT_ERRNO
5087 h_errno = PL_reentrant_buffer->_getnetent_errno;
5090 STATUS_UNIX_SET(h_errno);
5095 if (GIMME_V != G_ARRAY) {
5096 PUSHs(sv = sv_newmortal());
5098 if (which == OP_GNBYNAME)
5099 sv_setiv(sv, (IV)nent->n_net);
5101 sv_setpv(sv, nent->n_name);
5107 mPUSHs(newSVpv(nent->n_name, 0));
5108 PUSHs(space_join_names_mortal(nent->n_aliases));
5109 mPUSHi(nent->n_addrtype);
5110 mPUSHi(nent->n_net);
5115 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5120 /* also used for: pp_gpbyname() pp_gpbynumber() */
5124 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
5126 I32 which = PL_op->op_type;
5128 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
5129 struct protoent *getprotobyname(Netdb_name_t);
5130 struct protoent *getprotobynumber(int);
5131 struct protoent *getprotoent(void);
5133 struct protoent *pent;
5135 if (which == OP_GPBYNAME) {
5136 #ifdef HAS_GETPROTOBYNAME
5137 const char* const name = POPpbytex;
5138 pent = PerlSock_getprotobyname(name);
5140 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
5143 else if (which == OP_GPBYNUMBER) {
5144 #ifdef HAS_GETPROTOBYNUMBER
5145 const int number = POPi;
5146 pent = PerlSock_getprotobynumber(number);
5148 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
5152 #ifdef HAS_GETPROTOENT
5153 pent = PerlSock_getprotoent();
5155 DIE(aTHX_ PL_no_sock_func, "getprotoent");
5159 if (GIMME_V != G_ARRAY) {
5160 PUSHs(sv = sv_newmortal());
5162 if (which == OP_GPBYNAME)
5163 sv_setiv(sv, (IV)pent->p_proto);
5165 sv_setpv(sv, pent->p_name);
5171 mPUSHs(newSVpv(pent->p_name, 0));
5172 PUSHs(space_join_names_mortal(pent->p_aliases));
5173 mPUSHi(pent->p_proto);
5178 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5183 /* also used for: pp_gsbyname() pp_gsbyport() */
5187 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
5189 I32 which = PL_op->op_type;
5191 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
5192 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
5193 struct servent *getservbyport(int, Netdb_name_t);
5194 struct servent *getservent(void);
5196 struct servent *sent;
5198 if (which == OP_GSBYNAME) {
5199 #ifdef HAS_GETSERVBYNAME
5200 const char * const proto = POPpbytex;
5201 const char * const name = POPpbytex;
5202 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5204 DIE(aTHX_ PL_no_sock_func, "getservbyname");
5207 else if (which == OP_GSBYPORT) {
5208 #ifdef HAS_GETSERVBYPORT
5209 const char * const proto = POPpbytex;
5210 unsigned short port = (unsigned short)POPu;
5211 port = PerlSock_htons(port);
5212 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5214 DIE(aTHX_ PL_no_sock_func, "getservbyport");
5218 #ifdef HAS_GETSERVENT
5219 sent = PerlSock_getservent();
5221 DIE(aTHX_ PL_no_sock_func, "getservent");
5225 if (GIMME_V != G_ARRAY) {
5226 PUSHs(sv = sv_newmortal());
5228 if (which == OP_GSBYNAME) {
5229 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5232 sv_setpv(sv, sent->s_name);
5238 mPUSHs(newSVpv(sent->s_name, 0));
5239 PUSHs(space_join_names_mortal(sent->s_aliases));
5240 mPUSHi(PerlSock_ntohs(sent->s_port));
5241 mPUSHs(newSVpv(sent->s_proto, 0));
5246 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5251 /* also used for: pp_snetent() pp_sprotoent() pp_sservent() */
5256 const int stayopen = TOPi;
5257 switch(PL_op->op_type) {
5259 #ifdef HAS_SETHOSTENT
5260 PerlSock_sethostent(stayopen);
5262 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5265 #ifdef HAS_SETNETENT
5267 PerlSock_setnetent(stayopen);
5269 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5273 #ifdef HAS_SETPROTOENT
5274 PerlSock_setprotoent(stayopen);
5276 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5280 #ifdef HAS_SETSERVENT
5281 PerlSock_setservent(stayopen);
5283 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5291 /* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent()
5292 * pp_eservent() pp_sgrent() pp_spwent() */
5297 switch(PL_op->op_type) {
5299 #ifdef HAS_ENDHOSTENT
5300 PerlSock_endhostent();
5302 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5306 #ifdef HAS_ENDNETENT
5307 PerlSock_endnetent();
5309 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5313 #ifdef HAS_ENDPROTOENT
5314 PerlSock_endprotoent();
5316 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5320 #ifdef HAS_ENDSERVENT
5321 PerlSock_endservent();
5323 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5327 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5330 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5334 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5337 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5341 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5344 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5348 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5351 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5360 /* also used for: pp_gpwnam() pp_gpwuid() */
5366 I32 which = PL_op->op_type;
5368 struct passwd *pwent = NULL;
5370 * We currently support only the SysV getsp* shadow password interface.
5371 * The interface is declared in <shadow.h> and often one needs to link
5372 * with -lsecurity or some such.
5373 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5376 * AIX getpwnam() is clever enough to return the encrypted password
5377 * only if the caller (euid?) is root.
5379 * There are at least three other shadow password APIs. Many platforms
5380 * seem to contain more than one interface for accessing the shadow
5381 * password databases, possibly for compatibility reasons.
5382 * The getsp*() is by far he simplest one, the other two interfaces
5383 * are much more complicated, but also very similar to each other.
5388 * struct pr_passwd *getprpw*();
5389 * The password is in
5390 * char getprpw*(...).ufld.fd_encrypt[]
5391 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5396 * struct es_passwd *getespw*();
5397 * The password is in
5398 * char *(getespw*(...).ufld.fd_encrypt)
5399 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5402 * struct userpw *getuserpw();
5403 * The password is in
5404 * char *(getuserpw(...)).spw_upw_passwd
5405 * (but the de facto standard getpwnam() should work okay)
5407 * Mention I_PROT here so that Configure probes for it.
5409 * In HP-UX for getprpw*() the manual page claims that one should include
5410 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5411 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5412 * and pp_sys.c already includes <shadow.h> if there is such.
5414 * Note that <sys/security.h> is already probed for, but currently
5415 * it is only included in special cases.
5417 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5418 * be preferred interface, even though also the getprpw*() interface
5419 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5420 * One also needs to call set_auth_parameters() in main() before
5421 * doing anything else, whether one is using getespw*() or getprpw*().
5423 * Note that accessing the shadow databases can be magnitudes
5424 * slower than accessing the standard databases.
5429 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5430 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5431 * the pw_comment is left uninitialized. */
5432 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5438 const char* const name = POPpbytex;
5439 pwent = getpwnam(name);
5445 pwent = getpwuid(uid);
5449 # ifdef HAS_GETPWENT
5451 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5452 if (pwent) pwent = getpwnam(pwent->pw_name);
5455 DIE(aTHX_ PL_no_func, "getpwent");
5461 if (GIMME_V != G_ARRAY) {
5462 PUSHs(sv = sv_newmortal());
5464 if (which == OP_GPWNAM)
5465 sv_setuid(sv, pwent->pw_uid);
5467 sv_setpv(sv, pwent->pw_name);
5473 mPUSHs(newSVpv(pwent->pw_name, 0));
5477 /* If we have getspnam(), we try to dig up the shadow
5478 * password. If we are underprivileged, the shadow
5479 * interface will set the errno to EACCES or similar,
5480 * and return a null pointer. If this happens, we will
5481 * use the dummy password (usually "*" or "x") from the
5482 * standard password database.
5484 * In theory we could skip the shadow call completely
5485 * if euid != 0 but in practice we cannot know which
5486 * security measures are guarding the shadow databases
5487 * on a random platform.
5489 * Resist the urge to use additional shadow interfaces.
5490 * Divert the urge to writing an extension instead.
5493 /* Some AIX setups falsely(?) detect some getspnam(), which
5494 * has a different API than the Solaris/IRIX one. */
5495 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5498 const struct spwd * const spwent = getspnam(pwent->pw_name);
5499 /* Save and restore errno so that
5500 * underprivileged attempts seem
5501 * to have never made the unsuccessful
5502 * attempt to retrieve the shadow password. */
5504 if (spwent && spwent->sp_pwdp)
5505 sv_setpv(sv, spwent->sp_pwdp);
5509 if (!SvPOK(sv)) /* Use the standard password, then. */
5510 sv_setpv(sv, pwent->pw_passwd);
5513 /* passwd is tainted because user himself can diddle with it.
5514 * admittedly not much and in a very limited way, but nevertheless. */
5517 sv_setuid(PUSHmortal, pwent->pw_uid);
5518 sv_setgid(PUSHmortal, pwent->pw_gid);
5520 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5521 * because of the poor interface of the Perl getpw*(),
5522 * not because there's some standard/convention saying so.
5523 * A better interface would have been to return a hash,
5524 * but we are accursed by our history, alas. --jhi. */
5526 mPUSHi(pwent->pw_change);
5529 mPUSHi(pwent->pw_quota);
5532 mPUSHs(newSVpv(pwent->pw_age, 0));
5534 /* I think that you can never get this compiled, but just in case. */
5535 PUSHs(sv_mortalcopy(&PL_sv_no));
5540 /* pw_class and pw_comment are mutually exclusive--.
5541 * see the above note for pw_change, pw_quota, and pw_age. */
5543 mPUSHs(newSVpv(pwent->pw_class, 0));
5546 mPUSHs(newSVpv(pwent->pw_comment, 0));
5548 /* I think that you can never get this compiled, but just in case. */
5549 PUSHs(sv_mortalcopy(&PL_sv_no));
5554 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5556 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5558 /* pw_gecos is tainted because user himself can diddle with it. */
5561 mPUSHs(newSVpv(pwent->pw_dir, 0));
5563 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5564 /* pw_shell is tainted because user himself can diddle with it. */
5568 mPUSHi(pwent->pw_expire);
5573 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5578 /* also used for: pp_ggrgid() pp_ggrnam() */
5584 const I32 which = PL_op->op_type;
5585 const struct group *grent;
5587 if (which == OP_GGRNAM) {
5588 const char* const name = POPpbytex;
5589 grent = (const struct group *)getgrnam(name);
5591 else if (which == OP_GGRGID) {
5593 const Gid_t gid = POPu;
5594 #elif Gid_t_sign == -1
5595 const Gid_t gid = POPi;
5597 # error "Unexpected Gid_t_sign"
5599 grent = (const struct group *)getgrgid(gid);
5603 grent = (struct group *)getgrent();
5605 DIE(aTHX_ PL_no_func, "getgrent");
5609 if (GIMME_V != G_ARRAY) {
5610 SV * const sv = sv_newmortal();
5614 if (which == OP_GGRNAM)
5615 sv_setgid(sv, grent->gr_gid);
5617 sv_setpv(sv, grent->gr_name);
5623 mPUSHs(newSVpv(grent->gr_name, 0));
5626 mPUSHs(newSVpv(grent->gr_passwd, 0));
5628 PUSHs(sv_mortalcopy(&PL_sv_no));
5631 sv_setgid(PUSHmortal, grent->gr_gid);
5633 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5634 /* In UNICOS/mk (_CRAYMPP) the multithreading
5635 * versions (getgrnam_r, getgrgid_r)
5636 * seem to return an illegal pointer
5637 * as the group members list, gr_mem.
5638 * getgrent() doesn't even have a _r version
5639 * but the gr_mem is poisonous anyway.
5640 * So yes, you cannot get the list of group
5641 * members if building multithreaded in UNICOS/mk. */
5642 PUSHs(space_join_names_mortal(grent->gr_mem));
5648 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5658 if (!(tmps = PerlProc_getlogin()))
5660 sv_setpv_mg(TARG, tmps);
5664 DIE(aTHX_ PL_no_func, "getlogin");
5668 /* Miscellaneous. */
5673 dSP; dMARK; dORIGMARK; dTARGET;
5674 I32 items = SP - MARK;
5675 unsigned long a[20];
5680 while (++MARK <= SP) {
5681 if (SvTAINTED(*MARK)) {
5687 TAINT_PROPER("syscall");
5690 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5691 * or where sizeof(long) != sizeof(char*). But such machines will
5692 * not likely have syscall implemented either, so who cares?
5694 while (++MARK <= SP) {
5695 if (SvNIOK(*MARK) || !i)
5696 a[i++] = SvIV(*MARK);
5697 else if (*MARK == &PL_sv_undef)
5700 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5706 DIE(aTHX_ "Too many args to syscall");
5708 DIE(aTHX_ "Too few args to syscall");
5710 retval = syscall(a[0]);
5713 retval = syscall(a[0],a[1]);
5716 retval = syscall(a[0],a[1],a[2]);
5719 retval = syscall(a[0],a[1],a[2],a[3]);
5722 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5725 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5728 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5731 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5738 DIE(aTHX_ PL_no_func, "syscall");
5742 #ifdef FCNTL_EMULATE_FLOCK
5744 /* XXX Emulate flock() with fcntl().
5745 What's really needed is a good file locking module.
5749 fcntl_emulate_flock(int fd, int operation)
5754 switch (operation & ~LOCK_NB) {
5756 flock.l_type = F_RDLCK;
5759 flock.l_type = F_WRLCK;
5762 flock.l_type = F_UNLCK;
5768 flock.l_whence = SEEK_SET;
5769 flock.l_start = flock.l_len = (Off_t)0;
5771 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5772 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5773 errno = EWOULDBLOCK;
5777 #endif /* FCNTL_EMULATE_FLOCK */
5779 #ifdef LOCKF_EMULATE_FLOCK
5781 /* XXX Emulate flock() with lockf(). This is just to increase
5782 portability of scripts. The calls are not completely
5783 interchangeable. What's really needed is a good file
5787 /* The lockf() constants might have been defined in <unistd.h>.
5788 Unfortunately, <unistd.h> causes troubles on some mixed
5789 (BSD/POSIX) systems, such as SunOS 4.1.3.
5791 Further, the lockf() constants aren't POSIX, so they might not be
5792 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5793 just stick in the SVID values and be done with it. Sigh.
5797 # define F_ULOCK 0 /* Unlock a previously locked region */
5800 # define F_LOCK 1 /* Lock a region for exclusive use */
5803 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5806 # define F_TEST 3 /* Test a region for other processes locks */
5810 lockf_emulate_flock(int fd, int operation)
5816 /* flock locks entire file so for lockf we need to do the same */
5817 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5818 if (pos > 0) /* is seekable and needs to be repositioned */
5819 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5820 pos = -1; /* seek failed, so don't seek back afterwards */
5823 switch (operation) {
5825 /* LOCK_SH - get a shared lock */
5827 /* LOCK_EX - get an exclusive lock */
5829 i = lockf (fd, F_LOCK, 0);
5832 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5833 case LOCK_SH|LOCK_NB:
5834 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5835 case LOCK_EX|LOCK_NB:
5836 i = lockf (fd, F_TLOCK, 0);
5838 if ((errno == EAGAIN) || (errno == EACCES))
5839 errno = EWOULDBLOCK;
5842 /* LOCK_UN - unlock (non-blocking is a no-op) */
5844 case LOCK_UN|LOCK_NB:
5845 i = lockf (fd, F_ULOCK, 0);
5848 /* Default - can't decipher operation */
5855 if (pos > 0) /* need to restore position of the handle */
5856 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5861 #endif /* LOCKF_EMULATE_FLOCK */
5864 * ex: set ts=8 sts=4 sw=4 et: