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 and incremented, set to -1, which will trigger a panic in
550 * The weird way this is written is because g++ is dumb enough to
551 * warn "comparison is always false" on something like:
553 * sizeof(a) >= sizeof(b) && a >= B_t_MAX -1
555 * (where the LH condition is false)
558 (argc > (sizeof(argc) >= sizeof(SSize_t) ? SSize_t_MAX - 1 : argc))
559 ? -1 : (SSize_t)argc + 1;
560 EXTEND(SP, extend_size);
562 PUSHs(SvTIED_obj(sv, mg));
563 if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
564 Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
568 const U32 mortalize_not_needed
569 = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
571 va_start(args, argc);
573 SV *const arg = va_arg(args, SV *);
574 if(mortalize_not_needed)
583 ENTER_with_name("call_tied_method");
584 if (flags & TIED_METHOD_SAY) {
585 /* local $\ = "\n" */
586 SAVEGENERICSV(PL_ors_sv);
587 PL_ors_sv = newSVpvs("\n");
589 ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED);
594 if (ret_args) { /* copy results back to original stack */
595 EXTEND(sp, ret_args);
596 Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
600 LEAVE_with_name("call_tied_method");
604 #define tied_method0(a,b,c,d) \
605 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
606 #define tied_method1(a,b,c,d,e) \
607 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
608 #define tied_method2(a,b,c,d,e,f) \
609 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
622 GV * const gv = MUTABLE_GV(*++MARK);
624 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
625 DIE(aTHX_ PL_no_usym, "filehandle");
627 if ((io = GvIOp(gv))) {
629 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
632 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
633 "Opening dirhandle %"HEKf" also as a file",
634 HEKfARG(GvENAME_HEK(gv)));
636 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
638 /* Method's args are same as ours ... */
639 /* ... except handle is replaced by the object */
640 return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg,
641 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
653 tmps = SvPV_const(sv, len);
654 ok = do_open6(gv, tmps, len, NULL, MARK+1, (SP-MARK));
657 PUSHi( (I32)PL_forkprocess );
658 else if (PL_forkprocess == 0) /* we are a new child */
669 MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
675 IO * const io = GvIO(gv);
677 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
679 return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg);
683 PUSHs(boolSV(do_close(gv, TRUE)));
695 GV * const wgv = MUTABLE_GV(POPs);
696 GV * const rgv = MUTABLE_GV(POPs);
700 do_close(rgv, FALSE);
704 do_close(wgv, FALSE);
706 if (PerlProc_pipe(fd) < 0)
709 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
710 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
711 IoOFP(rstio) = IoIFP(rstio);
712 IoIFP(wstio) = IoOFP(wstio);
713 IoTYPE(rstio) = IoTYPE_RDONLY;
714 IoTYPE(wstio) = IoTYPE_WRONLY;
716 if (!IoIFP(rstio) || !IoOFP(wstio)) {
718 PerlIO_close(IoIFP(rstio));
720 PerlLIO_close(fd[0]);
722 PerlIO_close(IoOFP(wstio));
724 PerlLIO_close(fd[1]);
727 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
728 /* ensure close-on-exec */
729 if ((fd[0] > PL_maxsysfd && fcntl(fd[0], F_SETFD, FD_CLOEXEC) < 0) ||
730 (fd[1] > PL_maxsysfd && fcntl(fd[1], F_SETFD, FD_CLOEXEC) < 0))
738 DIE(aTHX_ PL_no_func, "pipe");
752 gv = MUTABLE_GV(POPs);
756 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
758 return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg);
761 if (io && IoDIRP(io)) {
762 #if defined(HAS_DIRFD) || defined(HAS_DIR_DD_FD)
763 PUSHi(my_dirfd(IoDIRP(io)));
765 #elif defined(ENOTSUP)
766 errno = ENOTSUP; /* Operation not supported */
768 #elif defined(EOPNOTSUPP)
769 errno = EOPNOTSUPP; /* Operation not supported on socket */
772 errno = EINVAL; /* Invalid argument */
777 if (!io || !(fp = IoIFP(io))) {
778 /* Can't do this because people seem to do things like
779 defined(fileno($foo)) to check whether $foo is a valid fh.
786 PUSHi(PerlIO_fileno(fp));
797 if (MAXARG < 1 || (!TOPs && !POPs)) {
798 anum = PerlLIO_umask(022);
799 /* setting it to 022 between the two calls to umask avoids
800 * to have a window where the umask is set to 0 -- meaning
801 * that another thread could create world-writeable files. */
803 (void)PerlLIO_umask(anum);
806 anum = PerlLIO_umask(POPi);
807 TAINT_PROPER("umask");
810 /* Only DIE if trying to restrict permissions on "user" (self).
811 * Otherwise it's harmless and more useful to just return undef
812 * since 'group' and 'other' concepts probably don't exist here. */
813 if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
814 DIE(aTHX_ "umask not implemented");
815 XPUSHs(&PL_sv_undef);
834 gv = MUTABLE_GV(POPs);
838 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
840 /* This takes advantage of the implementation of the varargs
841 function, which I don't think that the optimiser will be able to
842 figure out. Although, as it's a static function, in theory it
844 return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg,
845 G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
846 discp ? 1 : 0, discp);
850 if (!io || !(fp = IoIFP(io))) {
852 SETERRNO(EBADF,RMS_IFI);
859 const char *d = NULL;
862 d = SvPV_const(discp, len);
863 mode = mode_from_discipline(d, len);
864 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
865 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
866 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
887 const I32 markoff = MARK - PL_stack_base;
888 const char *methname;
889 int how = PERL_MAGIC_tied;
893 switch(SvTYPE(varsv)) {
897 methname = "TIEHASH";
898 if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
899 HvLAZYDEL_off(varsv);
900 hv_free_ent((HV *)varsv, entry);
902 HvEITER_set(MUTABLE_HV(varsv), 0);
906 methname = "TIEARRAY";
907 if (!AvREAL(varsv)) {
909 Perl_croak(aTHX_ "Cannot tie unreifiable array");
910 av_clear((AV *)varsv);
917 if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
918 methname = "TIEHANDLE";
919 how = PERL_MAGIC_tiedscalar;
920 /* For tied filehandles, we apply tiedscalar magic to the IO
921 slot of the GP rather than the GV itself. AMS 20010812 */
923 GvIOp(varsv) = newIO();
924 varsv = MUTABLE_SV(GvIOp(varsv));
927 if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
928 vivify_defelem(varsv);
929 varsv = LvTARG(varsv);
933 methname = "TIESCALAR";
934 how = PERL_MAGIC_tiedscalar;
938 if (sv_isobject(*MARK)) { /* Calls GET magic. */
939 ENTER_with_name("call_TIE");
940 PUSHSTACKi(PERLSI_MAGIC);
942 EXTEND(SP,(I32)items);
946 call_method(methname, G_SCALAR);
949 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
950 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
951 * wrong error message, and worse case, supreme action at a distance.
952 * (Sorry obfuscation writers. You're not going to be given this one.)
954 stash = gv_stashsv(*MARK, 0);
955 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
956 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
957 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
959 ENTER_with_name("call_TIE");
960 PUSHSTACKi(PERLSI_MAGIC);
962 EXTEND(SP,(I32)items);
966 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
972 if (sv_isobject(sv)) {
973 sv_unmagic(varsv, how);
974 /* Croak if a self-tie on an aggregate is attempted. */
975 if (varsv == SvRV(sv) &&
976 (SvTYPE(varsv) == SVt_PVAV ||
977 SvTYPE(varsv) == SVt_PVHV))
979 "Self-ties of arrays and hashes are not supported");
980 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
982 LEAVE_with_name("call_TIE");
983 SP = PL_stack_base + markoff;
989 /* also used for: pp_dbmclose() */
996 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
997 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
999 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1002 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1003 !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
1005 if ((mg = SvTIED_mg(sv, how))) {
1006 SV * const obj = SvRV(SvTIED_obj(sv, mg));
1008 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
1010 if (gv && isGV(gv) && (cv = GvCV(gv))) {
1012 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
1013 mXPUSHi(SvREFCNT(obj) - 1);
1015 ENTER_with_name("call_UNTIE");
1016 call_sv(MUTABLE_SV(cv), G_VOID);
1017 LEAVE_with_name("call_UNTIE");
1020 else if (mg && SvREFCNT(obj) > 1) {
1021 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
1022 "untie attempted while %"UVuf" inner references still exist",
1023 (UV)SvREFCNT(obj) - 1 ) ;
1027 sv_unmagic(sv, how) ;
1036 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1037 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1039 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1042 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1043 !(sv = defelem_target(sv, NULL))) goto ret_undef;
1045 if ((mg = SvTIED_mg(sv, how))) {
1046 SETs(SvTIED_obj(sv, mg));
1047 return NORMAL; /* PUTBACK not needed, pp_tied never moves SP */
1061 HV * const hv = MUTABLE_HV(POPs);
1062 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1063 stash = gv_stashsv(sv, 0);
1064 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1066 require_pv("AnyDBM_File.pm");
1068 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1069 DIE(aTHX_ "No dbm on this machine");
1079 mPUSHu(O_RDWR|O_CREAT);
1083 if (!SvOK(right)) right = &PL_sv_no;
1087 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1090 if (!sv_isobject(TOPs)) {
1098 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1100 if (sv_isobject(TOPs))
1105 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1106 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1123 struct timeval timebuf;
1124 struct timeval *tbuf = &timebuf;
1127 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1132 # if BYTEORDER & 0xf0000
1133 # define ORDERBYTE (0x88888888 - BYTEORDER)
1135 # define ORDERBYTE (0x4444 - BYTEORDER)
1141 for (i = 1; i <= 3; i++) {
1142 SV * const sv = SP[i];
1146 if (SvREADONLY(sv)) {
1147 if (!(SvPOK(sv) && SvCUR(sv) == 0))
1148 Perl_croak_no_modify();
1150 else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
1153 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1154 "Non-string passed as bitmask");
1155 SvPV_force_nomg_nolen(sv); /* force string conversion */
1162 /* little endians can use vecs directly */
1163 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1170 masksize = NFDBITS / NBBY;
1172 masksize = sizeof(long); /* documented int, everyone seems to use long */
1174 Zero(&fd_sets[0], 4, char*);
1177 # if SELECT_MIN_BITS == 1
1178 growsize = sizeof(fd_set);
1180 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1181 # undef SELECT_MIN_BITS
1182 # define SELECT_MIN_BITS __FD_SETSIZE
1184 /* If SELECT_MIN_BITS is greater than one we most probably will want
1185 * to align the sizes with SELECT_MIN_BITS/8 because for example
1186 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1187 * UNIX, Solaris, Darwin) the smallest quantum select() operates
1188 * on (sets/tests/clears bits) is 32 bits. */
1189 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1195 value = SvNV_nomg(sv);
1198 timebuf.tv_sec = (long)value;
1199 value -= (NV)timebuf.tv_sec;
1200 timebuf.tv_usec = (long)(value * 1000000.0);
1205 for (i = 1; i <= 3; i++) {
1207 if (!SvOK(sv) || SvCUR(sv) == 0) {
1214 Sv_Grow(sv, growsize);
1218 while (++j <= growsize) {
1222 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1224 Newx(fd_sets[i], growsize, char);
1225 for (offset = 0; offset < growsize; offset += masksize) {
1226 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1227 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1230 fd_sets[i] = SvPVX(sv);
1234 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1235 /* Can't make just the (void*) conditional because that would be
1236 * cpp #if within cpp macro, and not all compilers like that. */
1237 nfound = PerlSock_select(
1239 (Select_fd_set_t) fd_sets[1],
1240 (Select_fd_set_t) fd_sets[2],
1241 (Select_fd_set_t) fd_sets[3],
1242 (void*) tbuf); /* Workaround for compiler bug. */
1244 nfound = PerlSock_select(
1246 (Select_fd_set_t) fd_sets[1],
1247 (Select_fd_set_t) fd_sets[2],
1248 (Select_fd_set_t) fd_sets[3],
1251 for (i = 1; i <= 3; i++) {
1254 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1256 for (offset = 0; offset < growsize; offset += masksize) {
1257 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1258 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1260 Safefree(fd_sets[i]);
1267 if (GIMME_V == G_ARRAY && tbuf) {
1268 value = (NV)(timebuf.tv_sec) +
1269 (NV)(timebuf.tv_usec) / 1000000.0;
1274 DIE(aTHX_ "select not implemented");
1282 =for apidoc setdefout
1284 Sets C<PL_defoutgv>, the default file handle for output, to the passed in
1285 typeglob. As C<PL_defoutgv> "owns" a reference on its typeglob, the reference
1286 count of the passed in typeglob is increased by one, and the reference count
1287 of the typeglob that C<PL_defoutgv> points to is decreased by one.
1293 Perl_setdefout(pTHX_ GV *gv)
1295 PERL_ARGS_ASSERT_SETDEFOUT;
1296 SvREFCNT_inc_simple_void_NN(gv);
1297 SvREFCNT_dec(PL_defoutgv);
1305 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1306 GV * egv = GvEGVx(PL_defoutgv);
1311 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1312 gvp = hv && HvENAME(hv)
1313 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1315 if (gvp && *gvp == egv) {
1316 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1320 mXPUSHs(newRV(MUTABLE_SV(egv)));
1324 if (!GvIO(newdefout))
1325 gv_IOadd(newdefout);
1326 setdefout(newdefout);
1336 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1337 IO *const io = GvIO(gv);
1343 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1345 const U32 gimme = GIMME_V;
1346 Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1347 if (gimme == G_SCALAR) {
1349 SvSetMagicSV_nosteal(TARG, TOPs);
1354 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1355 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1357 SETERRNO(EBADF,RMS_IFI);
1361 sv_setpvs(TARG, " ");
1362 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1363 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1364 /* Find out how many bytes the char needs */
1365 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1368 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1369 SvCUR_set(TARG,1+len);
1373 else SvUTF8_off(TARG);
1379 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1382 const I32 gimme = GIMME_V;
1384 PERL_ARGS_ASSERT_DOFORM;
1387 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1392 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1393 PUSHFORMAT(cx, retop);
1394 if (CvDEPTH(cv) >= 2) {
1395 PERL_STACK_OVERFLOW_CHECK();
1396 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1399 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1401 setdefout(gv); /* locally select filehandle so $% et al work */
1419 gv = MUTABLE_GV(POPs);
1436 tmpsv = sv_newmortal();
1437 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1438 DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
1440 IoFLAGS(io) &= ~IOf_DIDTOP;
1441 RETURNOP(doform(cv,gv,PL_op->op_next));
1447 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1448 IO * const io = GvIOp(gv);
1455 bool is_return = cBOOL(PL_op->op_type == OP_RETURN);
1457 if (is_return || !io || !(ofp = IoOFP(io)))
1460 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1461 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1463 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1464 PL_formtarget != PL_toptarget)
1468 if (!IoTOP_GV(io)) {
1471 if (!IoTOP_NAME(io)) {
1473 if (!IoFMT_NAME(io))
1474 IoFMT_NAME(io) = savepv(GvNAME(gv));
1475 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1476 HEKfARG(GvNAME_HEK(gv))));
1477 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1478 if ((topgv && GvFORM(topgv)) ||
1479 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1480 IoTOP_NAME(io) = savesvpv(topname);
1482 IoTOP_NAME(io) = savepvs("top");
1484 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1485 if (!topgv || !GvFORM(topgv)) {
1486 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1489 IoTOP_GV(io) = topgv;
1491 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1492 I32 lines = IoLINES_LEFT(io);
1493 const char *s = SvPVX_const(PL_formtarget);
1494 if (lines <= 0) /* Yow, header didn't even fit!!! */
1496 while (lines-- > 0) {
1497 s = strchr(s, '\n');
1503 const STRLEN save = SvCUR(PL_formtarget);
1504 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1505 do_print(PL_formtarget, ofp);
1506 SvCUR_set(PL_formtarget, save);
1507 sv_chop(PL_formtarget, s);
1508 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1511 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1512 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1513 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1515 PL_formtarget = PL_toptarget;
1516 IoFLAGS(io) |= IOf_DIDTOP;
1518 assert(fgv); /* IoTOP_GV(io) should have been set above */
1521 SV * const sv = sv_newmortal();
1522 gv_efullname4(sv, fgv, NULL, FALSE);
1523 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1525 return doform(cv, gv, PL_op);
1529 POPBLOCK(cx,PL_curpm);
1530 retop = cx->blk_sub.retop;
1532 SP = newsp; /* ignore retval of formline */
1536 /* XXX the semantics of doing 'return' in a format aren't documented.
1537 * Currently we ignore any args to 'return' and just return
1538 * a single undef in both scalar and list contexts
1540 PUSHs(&PL_sv_undef);
1541 else if (!io || !(fp = IoOFP(io))) {
1542 if (io && IoIFP(io))
1543 report_wrongway_fh(gv, '<');
1549 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1550 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1552 if (!do_print(PL_formtarget, fp))
1555 FmLINES(PL_formtarget) = 0;
1556 SvCUR_set(PL_formtarget, 0);
1557 *SvEND(PL_formtarget) = '\0';
1558 if (IoFLAGS(io) & IOf_FLUSH)
1559 (void)PerlIO_flush(fp);
1563 PL_formtarget = PL_bodytarget;
1564 PERL_UNUSED_VAR(gimme);
1570 dSP; dMARK; dORIGMARK;
1574 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1575 IO *const io = GvIO(gv);
1577 /* Treat empty list as "" */
1578 if (MARK == SP) XPUSHs(&PL_sv_no);
1581 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1583 if (MARK == ORIGMARK) {
1586 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1589 return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1591 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1598 SETERRNO(EBADF,RMS_IFI);
1601 else if (!(fp = IoOFP(io))) {
1603 report_wrongway_fh(gv, '<');
1604 else if (ckWARN(WARN_CLOSED))
1606 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1610 SV *sv = sv_newmortal();
1611 do_sprintf(sv, SP - MARK, MARK + 1);
1612 if (!do_print(sv, fp))
1615 if (IoFLAGS(io) & IOf_FLUSH)
1616 if (PerlIO_flush(fp) == EOF)
1625 PUSHs(&PL_sv_undef);
1632 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1633 const int mode = POPi;
1634 SV * const sv = POPs;
1635 GV * const gv = MUTABLE_GV(POPs);
1638 /* Need TIEHANDLE method ? */
1639 const char * const tmps = SvPV_const(sv, len);
1640 if (do_open_raw(gv, tmps, len, mode, perm)) {
1641 IoLINES(GvIOp(gv)) = 0;
1645 PUSHs(&PL_sv_undef);
1651 /* also used for: pp_read() and pp_recv() (where supported) */
1655 dSP; dMARK; dORIGMARK; dTARGET;
1669 bool charstart = FALSE;
1670 STRLEN charskip = 0;
1672 GV * const gv = MUTABLE_GV(*++MARK);
1675 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1676 && gv && (io = GvIO(gv)) )
1678 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1680 return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1681 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1690 sv_setpvs(bufsv, "");
1691 length = SvIVx(*++MARK);
1693 DIE(aTHX_ "Negative length");
1696 offset = SvIVx(*++MARK);
1700 if (!io || !IoIFP(io)) {
1702 SETERRNO(EBADF,RMS_IFI);
1706 /* Note that fd can here validly be -1, don't check it yet. */
1707 fd = PerlIO_fileno(IoIFP(io));
1709 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1710 if (PL_op->op_type == OP_SYSREAD || PL_op->op_type == OP_RECV) {
1711 Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
1712 "%s() is deprecated on :utf8 handles",
1715 buffer = SvPVutf8_force(bufsv, blen);
1716 /* UTF-8 may not have been set if they are all low bytes */
1721 buffer = SvPV_force(bufsv, blen);
1722 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1724 if (DO_UTF8(bufsv)) {
1725 blen = sv_len_utf8_nomg(bufsv);
1734 if (PL_op->op_type == OP_RECV) {
1735 Sock_size_t bufsize;
1736 char namebuf[MAXPATHLEN];
1738 SETERRNO(EBADF,SS_IVCHAN);
1741 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1742 bufsize = sizeof (struct sockaddr_in);
1744 bufsize = sizeof namebuf;
1746 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1750 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1751 /* 'offset' means 'flags' here */
1752 count = PerlSock_recvfrom(fd, buffer, length, offset,
1753 (struct sockaddr *)namebuf, &bufsize);
1756 /* MSG_TRUNC can give oversized count; quietly lose it */
1759 SvCUR_set(bufsv, count);
1760 *SvEND(bufsv) = '\0';
1761 (void)SvPOK_only(bufsv);
1765 /* This should not be marked tainted if the fp is marked clean */
1766 if (!(IoFLAGS(io) & IOf_UNTAINT))
1767 SvTAINTED_on(bufsv);
1769 #if defined(__CYGWIN__)
1770 /* recvfrom() on cygwin doesn't set bufsize at all for
1771 connected sockets, leaving us with trash in the returned
1772 name, so use the same test as the Win32 code to check if it
1773 wasn't set, and set it [perl #118843] */
1774 if (bufsize == sizeof namebuf)
1777 sv_setpvn(TARG, namebuf, bufsize);
1783 if (-offset > (SSize_t)blen)
1784 DIE(aTHX_ "Offset outside string");
1787 if (DO_UTF8(bufsv)) {
1788 /* convert offset-as-chars to offset-as-bytes */
1789 if (offset >= (SSize_t)blen)
1790 offset += SvCUR(bufsv) - blen;
1792 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1796 /* Reestablish the fd in case it shifted from underneath us. */
1797 fd = PerlIO_fileno(IoIFP(io));
1799 orig_size = SvCUR(bufsv);
1800 /* Allocating length + offset + 1 isn't perfect in the case of reading
1801 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1803 (should be 2 * length + offset + 1, or possibly something longer if
1804 IN_ENCODING Is true) */
1805 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1806 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1807 Zero(buffer+orig_size, offset-orig_size, char);
1809 buffer = buffer + offset;
1811 read_target = bufsv;
1813 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1814 concatenate it to the current buffer. */
1816 /* Truncate the existing buffer to the start of where we will be
1818 SvCUR_set(bufsv, offset);
1820 read_target = sv_newmortal();
1821 SvUPGRADE(read_target, SVt_PV);
1822 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1825 if (PL_op->op_type == OP_SYSREAD) {
1826 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1827 if (IoTYPE(io) == IoTYPE_SOCKET) {
1829 SETERRNO(EBADF,SS_IVCHAN);
1833 count = PerlSock_recv(fd, buffer, length, 0);
1839 SETERRNO(EBADF,RMS_IFI);
1843 count = PerlLIO_read(fd, buffer, length);
1848 count = PerlIO_read(IoIFP(io), buffer, length);
1849 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1850 if (count == 0 && PerlIO_error(IoIFP(io)))
1854 if (IoTYPE(io) == IoTYPE_WRONLY)
1855 report_wrongway_fh(gv, '>');
1858 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1859 *SvEND(read_target) = '\0';
1860 (void)SvPOK_only(read_target);
1861 if (fp_utf8 && !IN_BYTES) {
1862 /* Look at utf8 we got back and count the characters */
1863 const char *bend = buffer + count;
1864 while (buffer < bend) {
1866 skip = UTF8SKIP(buffer);
1869 if (buffer - charskip + skip > bend) {
1870 /* partial character - try for rest of it */
1871 length = skip - (bend-buffer);
1872 offset = bend - SvPVX_const(bufsv);
1884 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1885 provided amount read (count) was what was requested (length)
1887 if (got < wanted && count == length) {
1888 length = wanted - got;
1889 offset = bend - SvPVX_const(bufsv);
1892 /* return value is character count */
1896 else if (buffer_utf8) {
1897 /* Let svcatsv upgrade the bytes we read in to utf8.
1898 The buffer is a mortal so will be freed soon. */
1899 sv_catsv_nomg(bufsv, read_target);
1902 /* This should not be marked tainted if the fp is marked clean */
1903 if (!(IoFLAGS(io) & IOf_UNTAINT))
1904 SvTAINTED_on(bufsv);
1915 /* also used for: pp_send() where defined */
1919 dSP; dMARK; dORIGMARK; dTARGET;
1924 STRLEN orig_blen_bytes;
1925 const int op_type = PL_op->op_type;
1928 GV *const gv = MUTABLE_GV(*++MARK);
1929 IO *const io = GvIO(gv);
1932 if (op_type == OP_SYSWRITE && io) {
1933 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1935 if (MARK == SP - 1) {
1937 mXPUSHi(sv_len(sv));
1941 return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1942 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1952 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1954 if (io && IoIFP(io))
1955 report_wrongway_fh(gv, '<');
1958 SETERRNO(EBADF,RMS_IFI);
1961 fd = PerlIO_fileno(IoIFP(io));
1963 SETERRNO(EBADF,SS_IVCHAN);
1968 /* Do this first to trigger any overloading. */
1969 buffer = SvPV_const(bufsv, blen);
1970 orig_blen_bytes = blen;
1971 doing_utf8 = DO_UTF8(bufsv);
1973 if (PerlIO_isutf8(IoIFP(io))) {
1974 Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
1975 "%s() is deprecated on :utf8 handles",
1977 if (!SvUTF8(bufsv)) {
1978 /* We don't modify the original scalar. */
1979 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1980 buffer = (char *) tmpbuf;
1984 else if (doing_utf8) {
1985 STRLEN tmplen = blen;
1986 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1989 buffer = (char *) tmpbuf;
1993 assert((char *)result == buffer);
1994 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1999 if (op_type == OP_SEND) {
2000 const int flags = SvIVx(*++MARK);
2003 char * const sockbuf = SvPVx(*++MARK, mlen);
2004 retval = PerlSock_sendto(fd, buffer, blen,
2005 flags, (struct sockaddr *)sockbuf, mlen);
2008 retval = PerlSock_send(fd, buffer, blen, flags);
2014 Size_t length = 0; /* This length is in characters. */
2020 /* The SV is bytes, and we've had to upgrade it. */
2021 blen_chars = orig_blen_bytes;
2023 /* The SV really is UTF-8. */
2024 /* Don't call sv_len_utf8 on a magical or overloaded
2025 scalar, as we might get back a different result. */
2026 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
2033 length = blen_chars;
2035 #if Size_t_size > IVSIZE
2036 length = (Size_t)SvNVx(*++MARK);
2038 length = (Size_t)SvIVx(*++MARK);
2040 if ((SSize_t)length < 0) {
2042 DIE(aTHX_ "Negative length");
2047 offset = SvIVx(*++MARK);
2049 if (-offset > (IV)blen_chars) {
2051 DIE(aTHX_ "Offset outside string");
2053 offset += blen_chars;
2054 } else if (offset > (IV)blen_chars) {
2056 DIE(aTHX_ "Offset outside string");
2060 if (length > blen_chars - offset)
2061 length = blen_chars - offset;
2063 /* Here we convert length from characters to bytes. */
2064 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
2065 /* Either we had to convert the SV, or the SV is magical, or
2066 the SV has overloading, in which case we can't or mustn't
2067 or mustn't call it again. */
2069 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
2070 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
2072 /* It's a real UTF-8 SV, and it's not going to change under
2073 us. Take advantage of any cache. */
2075 I32 len_I32 = length;
2077 /* Convert the start and end character positions to bytes.
2078 Remember that the second argument to sv_pos_u2b is relative
2080 sv_pos_u2b(bufsv, &start, &len_I32);
2087 buffer = buffer+offset;
2089 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2090 if (IoTYPE(io) == IoTYPE_SOCKET) {
2091 retval = PerlSock_send(fd, buffer, length, 0);
2096 /* See the note at doio.c:do_print about filesize limits. --jhi */
2097 retval = PerlLIO_write(fd, buffer, length);
2105 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2108 #if Size_t_size > IVSIZE
2128 * in Perl 5.12 and later, the additional parameter is a bitmask:
2131 * 2 = eof() <- ARGV magic
2133 * I'll rely on the compiler's trace flow analysis to decide whether to
2134 * actually assign this out here, or punt it into the only block where it is
2135 * used. Doing it out here is DRY on the condition logic.
2140 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2146 if (PL_op->op_flags & OPf_SPECIAL) {
2147 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2151 gv = PL_last_in_gv; /* eof */
2159 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2160 return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2163 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2164 if (io && !IoIFP(io)) {
2165 if ((IoFLAGS(io) & IOf_START) && av_tindex(GvAVn(gv)) < 0) {
2168 IoFLAGS(io) &= ~IOf_START;
2169 do_open6(gv, "-", 1, NULL, NULL, 0);
2177 *svp = newSVpvs("-");
2179 else if (!nextargv(gv, FALSE))
2184 PUSHs(boolSV(do_eof(gv)));
2194 if (MAXARG != 0 && (TOPs || POPs))
2195 PL_last_in_gv = MUTABLE_GV(POPs);
2202 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2204 return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2209 SETERRNO(EBADF,RMS_IFI);
2214 #if LSEEKSIZE > IVSIZE
2215 PUSHn( do_tell(gv) );
2217 PUSHi( do_tell(gv) );
2223 /* also used for: pp_seek() */
2228 const int whence = POPi;
2229 #if LSEEKSIZE > IVSIZE
2230 const Off_t offset = (Off_t)SvNVx(POPs);
2232 const Off_t offset = (Off_t)SvIVx(POPs);
2235 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2236 IO *const io = GvIO(gv);
2239 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2241 #if LSEEKSIZE > IVSIZE
2242 SV *const offset_sv = newSVnv((NV) offset);
2244 SV *const offset_sv = newSViv(offset);
2247 return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2252 if (PL_op->op_type == OP_SEEK)
2253 PUSHs(boolSV(do_seek(gv, offset, whence)));
2255 const Off_t sought = do_sysseek(gv, offset, whence);
2257 PUSHs(&PL_sv_undef);
2259 SV* const sv = sought ?
2260 #if LSEEKSIZE > IVSIZE
2265 : newSVpvn(zero_but_true, ZBTLEN);
2275 /* There seems to be no consensus on the length type of truncate()
2276 * and ftruncate(), both off_t and size_t have supporters. In
2277 * general one would think that when using large files, off_t is
2278 * at least as wide as size_t, so using an off_t should be okay. */
2279 /* XXX Configure probe for the length type of *truncate() needed XXX */
2282 #if Off_t_size > IVSIZE
2287 /* Checking for length < 0 is problematic as the type might or
2288 * might not be signed: if it is not, clever compilers will moan. */
2289 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2292 SV * const sv = POPs;
2297 if (PL_op->op_flags & OPf_SPECIAL
2298 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2299 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2306 TAINT_PROPER("truncate");
2307 if (!(fp = IoIFP(io))) {
2311 int fd = PerlIO_fileno(fp);
2313 SETERRNO(EBADF,RMS_IFI);
2317 SETERRNO(EINVAL, LIB_INVARG);
2322 if (ftruncate(fd, len) < 0)
2324 if (my_chsize(fd, len) < 0)
2332 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2333 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2334 goto do_ftruncate_io;
2337 const char * const name = SvPV_nomg_const_nolen(sv);
2338 TAINT_PROPER("truncate");
2340 if (truncate(name, len) < 0)
2347 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
2348 mode |= O_LARGEFILE; /* Transparently largefiley. */
2351 /* On open(), the Win32 CRT tries to seek around text
2352 * files using 32-bit offsets, which causes the open()
2353 * to fail on large files, so open in binary mode.
2357 tmpfd = PerlLIO_open(name, mode);
2362 if (my_chsize(tmpfd, len) < 0)
2364 PerlLIO_close(tmpfd);
2373 SETERRNO(EBADF,RMS_IFI);
2379 /* also used for: pp_fcntl() */
2384 SV * const argsv = POPs;
2385 const unsigned int func = POPu;
2387 GV * const gv = MUTABLE_GV(POPs);
2388 IO * const io = GvIOn(gv);
2394 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2398 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2401 s = SvPV_force(argsv, len);
2402 need = IOCPARM_LEN(func);
2404 s = Sv_Grow(argsv, need + 1);
2405 SvCUR_set(argsv, need);
2408 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2411 retval = SvIV(argsv);
2412 s = INT2PTR(char*,retval); /* ouch */
2415 optype = PL_op->op_type;
2416 TAINT_PROPER(PL_op_desc[optype]);
2418 if (optype == OP_IOCTL)
2420 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2422 DIE(aTHX_ "ioctl is not implemented");
2426 DIE(aTHX_ "fcntl is not implemented");
2428 #if defined(OS2) && defined(__EMX__)
2429 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2431 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2435 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2437 if (s[SvCUR(argsv)] != 17)
2438 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2440 s[SvCUR(argsv)] = 0; /* put our null back */
2441 SvSETMAGIC(argsv); /* Assume it has changed */
2450 PUSHp(zero_but_true, ZBTLEN);
2461 const int argtype = POPi;
2462 GV * const gv = MUTABLE_GV(POPs);
2463 IO *const io = GvIO(gv);
2464 PerlIO *const fp = io ? IoIFP(io) : NULL;
2466 /* XXX Looks to me like io is always NULL at this point */
2468 (void)PerlIO_flush(fp);
2469 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2474 SETERRNO(EBADF,RMS_IFI);
2479 DIE(aTHX_ PL_no_func, "flock");
2490 const int protocol = POPi;
2491 const int type = POPi;
2492 const int domain = POPi;
2493 GV * const gv = MUTABLE_GV(POPs);
2494 IO * const io = GvIOn(gv);
2498 do_close(gv, FALSE);
2500 TAINT_PROPER("socket");
2501 fd = PerlSock_socket(domain, type, protocol);
2503 SETERRNO(EBADF,RMS_IFI);
2506 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2507 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2508 IoTYPE(io) = IoTYPE_SOCKET;
2509 if (!IoIFP(io) || !IoOFP(io)) {
2510 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2511 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2512 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2515 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2516 /* ensure close-on-exec */
2517 if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0)
2527 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2530 const int protocol = POPi;
2531 const int type = POPi;
2532 const int domain = POPi;
2534 GV * const gv2 = MUTABLE_GV(POPs);
2535 IO * const io2 = GvIOn(gv2);
2536 GV * const gv1 = MUTABLE_GV(POPs);
2537 IO * const io1 = GvIOn(gv1);
2540 do_close(gv1, FALSE);
2542 do_close(gv2, FALSE);
2544 TAINT_PROPER("socketpair");
2545 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2547 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2548 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2549 IoTYPE(io1) = IoTYPE_SOCKET;
2550 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2551 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2552 IoTYPE(io2) = IoTYPE_SOCKET;
2553 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2554 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2555 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2556 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2557 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2558 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2559 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2562 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2563 /* ensure close-on-exec */
2564 if ((fd[0] > PL_maxsysfd && fcntl(fd[0], F_SETFD, FD_CLOEXEC) < 0) ||
2565 (fd[1] > PL_maxsysfd && fcntl(fd[1], F_SETFD, FD_CLOEXEC) < 0))
2571 DIE(aTHX_ PL_no_sock_func, "socketpair");
2577 /* also used for: pp_connect() */
2582 SV * const addrsv = POPs;
2583 /* OK, so on what platform does bind modify addr? */
2585 GV * const gv = MUTABLE_GV(POPs);
2586 IO * const io = GvIOn(gv);
2593 fd = PerlIO_fileno(IoIFP(io));
2597 addr = SvPV_const(addrsv, len);
2598 op_type = PL_op->op_type;
2599 TAINT_PROPER(PL_op_desc[op_type]);
2600 if ((op_type == OP_BIND
2601 ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
2602 : PerlSock_connect(fd, (struct sockaddr *)addr, len))
2610 SETERRNO(EBADF,SS_IVCHAN);
2617 const int backlog = POPi;
2618 GV * const gv = MUTABLE_GV(POPs);
2619 IO * const io = GvIOn(gv);
2624 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2631 SETERRNO(EBADF,SS_IVCHAN);
2639 char namebuf[MAXPATHLEN];
2640 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2641 Sock_size_t len = sizeof (struct sockaddr_in);
2643 Sock_size_t len = sizeof namebuf;
2645 GV * const ggv = MUTABLE_GV(POPs);
2646 GV * const ngv = MUTABLE_GV(POPs);
2649 IO * const gstio = GvIO(ggv);
2650 if (!gstio || !IoIFP(gstio))
2654 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2657 /* Some platforms indicate zero length when an AF_UNIX client is
2658 * not bound. Simulate a non-zero-length sockaddr structure in
2660 namebuf[0] = 0; /* sun_len */
2661 namebuf[1] = AF_UNIX; /* sun_family */
2669 do_close(ngv, FALSE);
2670 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2671 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2672 IoTYPE(nstio) = IoTYPE_SOCKET;
2673 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2674 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2675 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2676 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2679 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2680 /* ensure close-on-exec */
2681 if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0)
2685 #ifdef __SCO_VERSION__
2686 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2689 PUSHp(namebuf, len);
2693 report_evil_fh(ggv);
2694 SETERRNO(EBADF,SS_IVCHAN);
2704 const int how = POPi;
2705 GV * const gv = MUTABLE_GV(POPs);
2706 IO * const io = GvIOn(gv);
2711 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2716 SETERRNO(EBADF,SS_IVCHAN);
2721 /* also used for: pp_gsockopt() */
2726 const int optype = PL_op->op_type;
2727 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2728 const unsigned int optname = (unsigned int) POPi;
2729 const unsigned int lvl = (unsigned int) POPi;
2730 GV * const gv = MUTABLE_GV(POPs);
2731 IO * const io = GvIOn(gv);
2738 fd = PerlIO_fileno(IoIFP(io));
2744 (void)SvPOK_only(sv);
2748 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2751 /* XXX Configure test: does getsockopt set the length properly? */
2760 #if defined(__SYMBIAN32__)
2761 # define SETSOCKOPT_OPTION_VALUE_T void *
2763 # define SETSOCKOPT_OPTION_VALUE_T const char *
2765 /* XXX TODO: We need to have a proper type (a Configure probe,
2766 * etc.) for what the C headers think of the third argument of
2767 * setsockopt(), the option_value read-only buffer: is it
2768 * a "char *", or a "void *", const or not. Some compilers
2769 * don't take kindly to e.g. assuming that "char *" implicitly
2770 * promotes to a "void *", or to explicitly promoting/demoting
2771 * consts to non/vice versa. The "const void *" is the SUS
2772 * definition, but that does not fly everywhere for the above
2774 SETSOCKOPT_OPTION_VALUE_T buf;
2778 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2782 aint = (int)SvIV(sv);
2783 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2786 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2796 SETERRNO(EBADF,SS_IVCHAN);
2803 /* also used for: pp_getsockname() */
2808 const int optype = PL_op->op_type;
2809 GV * const gv = MUTABLE_GV(POPs);
2810 IO * const io = GvIOn(gv);
2818 sv = sv_2mortal(newSV(257));
2819 (void)SvPOK_only(sv);
2823 fd = PerlIO_fileno(IoIFP(io));
2827 case OP_GETSOCKNAME:
2828 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2831 case OP_GETPEERNAME:
2832 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2834 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2836 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";
2837 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2838 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2839 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2840 sizeof(u_short) + sizeof(struct in_addr))) {
2847 #ifdef BOGUS_GETNAME_RETURN
2848 /* Interactive Unix, getpeername() and getsockname()
2849 does not return valid namelen */
2850 if (len == BOGUS_GETNAME_RETURN)
2851 len = sizeof(struct sockaddr);
2860 SETERRNO(EBADF,SS_IVCHAN);
2869 /* also used for: pp_lstat() */
2880 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2881 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2882 if (PL_op->op_type == OP_LSTAT) {
2883 if (gv != PL_defgv) {
2884 do_fstat_warning_check:
2885 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2886 "lstat() on filehandle%s%"SVf,
2889 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2891 } else if (PL_laststype != OP_LSTAT)
2892 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2893 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2896 if (gv != PL_defgv) {
2900 PL_laststype = OP_STAT;
2901 PL_statgv = gv ? gv : (GV *)io;
2902 sv_setpvs(PL_statname, "");
2908 int fd = PerlIO_fileno(IoIFP(io));
2910 PL_laststatval = -1;
2911 SETERRNO(EBADF,RMS_IFI);
2913 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
2916 } else if (IoDIRP(io)) {
2918 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2921 PL_laststatval = -1;
2924 else PL_laststatval = -1;
2925 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2928 if (PL_laststatval < 0) {
2934 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2935 io = MUTABLE_IO(SvRV(sv));
2936 if (PL_op->op_type == OP_LSTAT)
2937 goto do_fstat_warning_check;
2938 goto do_fstat_have_io;
2941 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2942 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2944 PL_laststype = PL_op->op_type;
2945 file = SvPV_nolen_const(PL_statname);
2946 if (PL_op->op_type == OP_LSTAT)
2947 PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
2949 PL_laststatval = PerlLIO_stat(file, &PL_statcache);
2950 if (PL_laststatval < 0) {
2951 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
2952 /* PL_warn_nl is constant */
2953 GCC_DIAG_IGNORE(-Wformat-nonliteral);
2954 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2962 if (gimme != G_ARRAY) {
2963 if (gimme != G_VOID)
2964 XPUSHs(boolSV(max));
2970 mPUSHi(PL_statcache.st_dev);
2971 #if ST_INO_SIZE > IVSIZE
2972 mPUSHn(PL_statcache.st_ino);
2974 # if ST_INO_SIGN <= 0
2975 mPUSHi(PL_statcache.st_ino);
2977 mPUSHu(PL_statcache.st_ino);
2980 mPUSHu(PL_statcache.st_mode);
2981 mPUSHu(PL_statcache.st_nlink);
2983 sv_setuid(PUSHmortal, PL_statcache.st_uid);
2984 sv_setgid(PUSHmortal, PL_statcache.st_gid);
2986 #ifdef USE_STAT_RDEV
2987 mPUSHi(PL_statcache.st_rdev);
2989 PUSHs(newSVpvs_flags("", SVs_TEMP));
2991 #if Off_t_size > IVSIZE
2992 mPUSHn(PL_statcache.st_size);
2994 mPUSHi(PL_statcache.st_size);
2997 mPUSHn(PL_statcache.st_atime);
2998 mPUSHn(PL_statcache.st_mtime);
2999 mPUSHn(PL_statcache.st_ctime);
3001 mPUSHi(PL_statcache.st_atime);
3002 mPUSHi(PL_statcache.st_mtime);
3003 mPUSHi(PL_statcache.st_ctime);
3005 #ifdef USE_STAT_BLOCKS
3006 mPUSHu(PL_statcache.st_blksize);
3007 mPUSHu(PL_statcache.st_blocks);
3009 PUSHs(newSVpvs_flags("", SVs_TEMP));
3010 PUSHs(newSVpvs_flags("", SVs_TEMP));
3016 /* All filetest ops avoid manipulating the perl stack pointer in their main
3017 bodies (since commit d2c4d2d1e22d3125), and return using either
3018 S_ft_return_false() or S_ft_return_true(). These two helper functions are
3019 the only two which manipulate the perl stack. To ensure that no stack
3020 manipulation macros are used, the filetest ops avoid defining a local copy
3021 of the stack pointer with dSP. */
3023 /* If the next filetest is stacked up with this one
3024 (PL_op->op_private & OPpFT_STACKING), we leave
3025 the original argument on the stack for success,
3026 and skip the stacked operators on failure.
3027 The next few macros/functions take care of this.
3031 S_ft_return_false(pTHX_ SV *ret) {
3035 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
3039 if (PL_op->op_private & OPpFT_STACKING) {
3040 while (OP_IS_FILETEST(next->op_type)
3041 && next->op_private & OPpFT_STACKED)
3042 next = next->op_next;
3047 PERL_STATIC_INLINE OP *
3048 S_ft_return_true(pTHX_ SV *ret) {
3050 if (PL_op->op_flags & OPf_REF)
3051 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
3052 else if (!(PL_op->op_private & OPpFT_STACKING))
3058 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
3059 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
3060 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
3062 #define tryAMAGICftest_MG(chr) STMT_START { \
3063 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
3064 && PL_op->op_flags & OPf_KIDS) { \
3065 OP *next = S_try_amagic_ftest(aTHX_ chr); \
3066 if (next) return next; \
3071 S_try_amagic_ftest(pTHX_ char chr) {
3072 SV *const arg = *PL_stack_sp;
3075 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
3079 const char tmpchr = chr;
3080 SV * const tmpsv = amagic_call(arg,
3081 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
3082 ftest_amg, AMGf_unary);
3087 return SvTRUE(tmpsv)
3088 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
3094 /* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec()
3100 /* Not const, because things tweak this below. Not bool, because there's
3101 no guarantee that OPpFT_ACCESS is <= CHAR_MAX */
3102 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3103 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3104 /* Giving some sort of initial value silences compilers. */
3106 int access_mode = R_OK;
3108 int access_mode = 0;
3111 /* access_mode is never used, but leaving use_access in makes the
3112 conditional compiling below much clearer. */
3115 Mode_t stat_mode = S_IRUSR;
3117 bool effective = FALSE;
3120 switch (PL_op->op_type) {
3121 case OP_FTRREAD: opchar = 'R'; break;
3122 case OP_FTRWRITE: opchar = 'W'; break;
3123 case OP_FTREXEC: opchar = 'X'; break;
3124 case OP_FTEREAD: opchar = 'r'; break;
3125 case OP_FTEWRITE: opchar = 'w'; break;
3126 case OP_FTEEXEC: opchar = 'x'; break;
3128 tryAMAGICftest_MG(opchar);
3130 switch (PL_op->op_type) {
3132 #if !(defined(HAS_ACCESS) && defined(R_OK))
3138 #if defined(HAS_ACCESS) && defined(W_OK)
3143 stat_mode = S_IWUSR;
3147 #if defined(HAS_ACCESS) && defined(X_OK)
3152 stat_mode = S_IXUSR;
3156 #ifdef PERL_EFF_ACCESS
3159 stat_mode = S_IWUSR;
3163 #ifndef PERL_EFF_ACCESS
3170 #ifdef PERL_EFF_ACCESS
3175 stat_mode = S_IXUSR;
3181 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3182 const char *name = SvPV_nolen(*PL_stack_sp);
3184 # ifdef PERL_EFF_ACCESS
3185 result = PERL_EFF_ACCESS(name, access_mode);
3187 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3193 result = access(name, access_mode);
3195 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3206 result = my_stat_flags(0);
3209 if (cando(stat_mode, effective, &PL_statcache))
3215 /* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */
3220 const int op_type = PL_op->op_type;
3224 case OP_FTIS: opchar = 'e'; break;
3225 case OP_FTSIZE: opchar = 's'; break;
3226 case OP_FTMTIME: opchar = 'M'; break;
3227 case OP_FTCTIME: opchar = 'C'; break;
3228 case OP_FTATIME: opchar = 'A'; break;
3230 tryAMAGICftest_MG(opchar);
3232 result = my_stat_flags(0);
3235 if (op_type == OP_FTIS)
3238 /* You can't dTARGET inside OP_FTIS, because you'll get
3239 "panic: pad_sv po" - the op is not flagged to have a target. */
3243 #if Off_t_size > IVSIZE
3244 sv_setnv(TARG, (NV)PL_statcache.st_size);
3246 sv_setiv(TARG, (IV)PL_statcache.st_size);
3251 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3255 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3259 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3263 return SvTRUE_nomg(TARG)
3264 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3269 /* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned()
3270 * pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock()
3271 * pp_ftsuid() pp_ftsvtx() pp_ftzero() */
3278 switch (PL_op->op_type) {
3279 case OP_FTROWNED: opchar = 'O'; break;
3280 case OP_FTEOWNED: opchar = 'o'; break;
3281 case OP_FTZERO: opchar = 'z'; break;
3282 case OP_FTSOCK: opchar = 'S'; break;
3283 case OP_FTCHR: opchar = 'c'; break;
3284 case OP_FTBLK: opchar = 'b'; break;
3285 case OP_FTFILE: opchar = 'f'; break;
3286 case OP_FTDIR: opchar = 'd'; break;
3287 case OP_FTPIPE: opchar = 'p'; break;
3288 case OP_FTSUID: opchar = 'u'; break;
3289 case OP_FTSGID: opchar = 'g'; break;
3290 case OP_FTSVTX: opchar = 'k'; break;
3292 tryAMAGICftest_MG(opchar);
3294 /* I believe that all these three are likely to be defined on most every
3295 system these days. */
3297 if(PL_op->op_type == OP_FTSUID) {
3302 if(PL_op->op_type == OP_FTSGID) {
3307 if(PL_op->op_type == OP_FTSVTX) {
3312 result = my_stat_flags(0);
3315 switch (PL_op->op_type) {
3317 if (PL_statcache.st_uid == PerlProc_getuid())
3321 if (PL_statcache.st_uid == PerlProc_geteuid())
3325 if (PL_statcache.st_size == 0)
3329 if (S_ISSOCK(PL_statcache.st_mode))
3333 if (S_ISCHR(PL_statcache.st_mode))
3337 if (S_ISBLK(PL_statcache.st_mode))
3341 if (S_ISREG(PL_statcache.st_mode))
3345 if (S_ISDIR(PL_statcache.st_mode))
3349 if (S_ISFIFO(PL_statcache.st_mode))
3354 if (PL_statcache.st_mode & S_ISUID)
3360 if (PL_statcache.st_mode & S_ISGID)
3366 if (PL_statcache.st_mode & S_ISVTX)
3378 tryAMAGICftest_MG('l');
3379 result = my_lstat_flags(0);
3383 if (S_ISLNK(PL_statcache.st_mode))
3396 tryAMAGICftest_MG('t');
3398 if (PL_op->op_flags & OPf_REF)
3401 SV *tmpsv = *PL_stack_sp;
3402 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3403 name = SvPV_nomg(tmpsv, namelen);
3404 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3408 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3409 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3410 else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX)
3415 SETERRNO(EBADF,RMS_IFI);
3418 if (PerlLIO_isatty(fd))
3424 /* also used for: pp_ftbinary() */
3438 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3440 if (PL_op->op_flags & OPf_REF)
3442 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3447 gv = MAYBE_DEREF_GV_nomg(sv);
3451 if (gv == PL_defgv) {
3453 io = SvTYPE(PL_statgv) == SVt_PVIO
3457 goto really_filename;
3462 sv_setpvs(PL_statname, "");
3463 io = GvIO(PL_statgv);
3465 PL_laststatval = -1;
3466 PL_laststype = OP_STAT;
3467 if (io && IoIFP(io)) {
3469 if (! PerlIO_has_base(IoIFP(io)))
3470 DIE(aTHX_ "-T and -B not implemented on filehandles");
3471 fd = PerlIO_fileno(IoIFP(io));
3473 SETERRNO(EBADF,RMS_IFI);
3476 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3477 if (PL_laststatval < 0)
3479 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3480 if (PL_op->op_type == OP_FTTEXT)
3485 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3486 i = PerlIO_getc(IoIFP(io));
3488 (void)PerlIO_ungetc(IoIFP(io),i);
3490 /* null file is anything */
3493 len = PerlIO_get_bufsiz(IoIFP(io));
3494 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3495 /* sfio can have large buffers - limit to 512 */
3500 SETERRNO(EBADF,RMS_IFI);
3502 SETERRNO(EBADF,RMS_IFI);
3511 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3513 file = SvPVX_const(PL_statname);
3515 if (!(fp = PerlIO_open(file, "r"))) {
3517 PL_laststatval = -1;
3518 PL_laststype = OP_STAT;
3520 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
3521 /* PL_warn_nl is constant */
3522 GCC_DIAG_IGNORE(-Wformat-nonliteral);
3523 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3528 PL_laststype = OP_STAT;
3529 fd = PerlIO_fileno(fp);
3531 (void)PerlIO_close(fp);
3532 SETERRNO(EBADF,RMS_IFI);
3535 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3536 if (PL_laststatval < 0) {
3537 (void)PerlIO_close(fp);
3538 SETERRNO(EBADF,RMS_IFI);
3541 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3542 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3543 (void)PerlIO_close(fp);
3545 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3546 FT_RETURNNO; /* special case NFS directories */
3547 FT_RETURNYES; /* null file is anything */
3552 /* now scan s to look for textiness */
3554 #if defined(DOSISH) || defined(USEMYBINMODE)
3555 /* ignore trailing ^Z on short files */
3556 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3561 if (! is_invariant_string((U8 *) s, len)) {
3564 /* Here contains a variant under UTF-8 . See if the entire string is
3565 * UTF-8. But the buffer may end in a partial character, so consider
3566 * it UTF-8 if the first non-UTF8 char is an ending partial */
3567 if (is_utf8_string_loc((U8 *) s, len, &ep)
3568 || ep + UTF8SKIP(ep) > (U8 *) (s + len))
3570 if (PL_op->op_type == OP_FTTEXT) {
3579 /* Here, is not UTF-8 or is entirely ASCII. Look through the buffer for
3580 * things that wouldn't be in ASCII text or rich ASCII text. Count these
3582 for (i = 0; i < len; i++, s++) {
3583 if (!*s) { /* null never allowed in text */
3587 #ifdef USE_LOCALE_CTYPE
3588 if (IN_LC_RUNTIME(LC_CTYPE)) {
3589 if ( isPRINT_LC(*s) || isSPACE_LC(*s)) {
3596 /* VT occurs so rarely in text, that we consider it odd */
3597 || (isSPACE_A(*s) && *s != VT_NATIVE)
3599 /* But there is a fair amount of backspaces and escapes in
3602 || *s == ESC_NATIVE)
3609 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3620 const char *tmps = NULL;
3624 SV * const sv = POPs;
3625 if (PL_op->op_flags & OPf_SPECIAL) {
3626 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3628 if (ckWARN(WARN_UNOPENED)) {
3629 Perl_warner(aTHX_ packWARN(WARN_UNOPENED),
3630 "chdir() on unopened filehandle %" SVf, sv);
3632 SETERRNO(EBADF,RMS_IFI);
3634 TAINT_PROPER("chdir");
3638 else if (!(gv = MAYBE_DEREF_GV(sv)))
3639 tmps = SvPV_nomg_const_nolen(sv);
3642 HV * const table = GvHVn(PL_envgv);
3645 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3646 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3648 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3652 tmps = SvPV_nolen_const(*svp);
3656 SETERRNO(EINVAL, LIB_INVARG);
3657 TAINT_PROPER("chdir");
3662 TAINT_PROPER("chdir");
3665 IO* const io = GvIO(gv);
3668 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3669 } else if (IoIFP(io)) {
3670 int fd = PerlIO_fileno(IoIFP(io));
3674 PUSHi(fchdir(fd) >= 0);
3684 DIE(aTHX_ PL_no_func, "fchdir");
3688 PUSHi( PerlDir_chdir(tmps) >= 0 );
3690 /* Clear the DEFAULT element of ENV so we'll get the new value
3692 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3699 SETERRNO(EBADF,RMS_IFI);
3706 /* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */
3710 dSP; dMARK; dTARGET;
3711 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3722 char * const tmps = POPpx;
3723 TAINT_PROPER("chroot");
3724 PUSHi( chroot(tmps) >= 0 );
3727 DIE(aTHX_ PL_no_func, "chroot");
3738 const char * const tmps2 = POPpconstx;
3739 const char * const tmps = SvPV_nolen_const(TOPs);
3740 TAINT_PROPER("rename");
3742 anum = PerlLIO_rename(tmps, tmps2);
3744 if (!(anum = PerlLIO_stat(tmps, &statbuf))) {
3745 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3748 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
3749 (void)UNLINK(tmps2);
3750 if (!(anum = link(tmps, tmps2)))
3751 anum = UNLINK(tmps);
3760 /* also used for: pp_symlink() */
3762 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3766 const int op_type = PL_op->op_type;
3770 if (op_type == OP_LINK)
3771 DIE(aTHX_ PL_no_func, "link");
3773 # ifndef HAS_SYMLINK
3774 if (op_type == OP_SYMLINK)
3775 DIE(aTHX_ PL_no_func, "symlink");
3779 const char * const tmps2 = POPpconstx;
3780 const char * const tmps = SvPV_nolen_const(TOPs);
3781 TAINT_PROPER(PL_op_desc[op_type]);
3783 # if defined(HAS_LINK)
3784 # if defined(HAS_SYMLINK)
3785 /* Both present - need to choose which. */
3786 (op_type == OP_LINK) ?
3787 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3789 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3790 PerlLIO_link(tmps, tmps2);
3793 # if defined(HAS_SYMLINK)
3794 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3795 symlink(tmps, tmps2);
3800 SETi( result >= 0 );
3805 /* also used for: pp_symlink() */
3810 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3820 char buf[MAXPATHLEN];
3825 /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
3826 * it is impossible to know whether the result was truncated. */
3827 len = readlink(tmps, buf, sizeof(buf) - 1);
3836 RETSETUNDEF; /* just pretend it's a normal file */
3840 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3842 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3844 char * const save_filename = filename;
3849 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3851 PERL_ARGS_ASSERT_DOONELINER;
3853 Newx(cmdline, size, char);
3854 my_strlcpy(cmdline, cmd, size);
3855 my_strlcat(cmdline, " ", size);
3856 for (s = cmdline + strlen(cmdline); *filename; ) {
3860 if (s - cmdline < size)
3861 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3862 myfp = PerlProc_popen(cmdline, "r");
3866 SV * const tmpsv = sv_newmortal();
3867 /* Need to save/restore 'PL_rs' ?? */
3868 s = sv_gets(tmpsv, myfp, 0);
3869 (void)PerlProc_pclose(myfp);
3873 #ifdef HAS_SYS_ERRLIST
3878 /* you don't see this */
3879 const char * const errmsg = Strerror(e) ;
3882 if (instr(s, errmsg)) {
3889 #define EACCES EPERM
3891 if (instr(s, "cannot make"))
3892 SETERRNO(EEXIST,RMS_FEX);
3893 else if (instr(s, "existing file"))
3894 SETERRNO(EEXIST,RMS_FEX);
3895 else if (instr(s, "ile exists"))
3896 SETERRNO(EEXIST,RMS_FEX);
3897 else if (instr(s, "non-exist"))
3898 SETERRNO(ENOENT,RMS_FNF);
3899 else if (instr(s, "does not exist"))
3900 SETERRNO(ENOENT,RMS_FNF);
3901 else if (instr(s, "not empty"))
3902 SETERRNO(EBUSY,SS_DEVOFFLINE);
3903 else if (instr(s, "cannot access"))
3904 SETERRNO(EACCES,RMS_PRV);
3906 SETERRNO(EPERM,RMS_PRV);
3909 else { /* some mkdirs return no failure indication */
3911 anum = (PerlLIO_stat(save_filename, &statbuf) >= 0);
3912 if (PL_op->op_type == OP_RMDIR)
3917 SETERRNO(EACCES,RMS_PRV); /* a guess */
3926 /* This macro removes trailing slashes from a directory name.
3927 * Different operating and file systems take differently to
3928 * trailing slashes. According to POSIX 1003.1 1996 Edition
3929 * any number of trailing slashes should be allowed.
3930 * Thusly we snip them away so that even non-conforming
3931 * systems are happy.
3932 * We should probably do this "filtering" for all
3933 * the functions that expect (potentially) directory names:
3934 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3935 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3937 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3938 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3941 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3942 (tmps) = savepvn((tmps), (len)); \
3952 const unsigned int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPu : 0777;
3954 TRIMSLASHES(tmps,len,copy);
3956 TAINT_PROPER("mkdir");
3958 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3962 SETi( dooneliner("mkdir", tmps) );
3963 oldumask = PerlLIO_umask(0);
3964 PerlLIO_umask(oldumask);
3965 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3980 TRIMSLASHES(tmps,len,copy);
3981 TAINT_PROPER("rmdir");
3983 SETi( PerlDir_rmdir(tmps) >= 0 );
3985 SETi( dooneliner("rmdir", tmps) );
3992 /* Directory calls. */
3996 #if defined(Direntry_t) && defined(HAS_READDIR)
3998 const char * const dirname = POPpconstx;
3999 GV * const gv = MUTABLE_GV(POPs);
4000 IO * const io = GvIOn(gv);
4002 if ((IoIFP(io) || IoOFP(io)))
4003 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
4004 "Opening filehandle %"HEKf" also as a directory",
4005 HEKfARG(GvENAME_HEK(gv)) );
4007 PerlDir_close(IoDIRP(io));
4008 if (!(IoDIRP(io) = PerlDir_open(dirname)))
4014 SETERRNO(EBADF,RMS_DIR);
4017 DIE(aTHX_ PL_no_dir_func, "opendir");
4023 #if !defined(Direntry_t) || !defined(HAS_READDIR)
4024 DIE(aTHX_ PL_no_dir_func, "readdir");
4026 #if !defined(I_DIRENT) && !defined(VMS)
4027 Direntry_t *readdir (DIR *);
4032 const I32 gimme = GIMME_V;
4033 GV * const gv = MUTABLE_GV(POPs);
4034 const Direntry_t *dp;
4035 IO * const io = GvIOn(gv);
4038 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4039 "readdir() attempted on invalid dirhandle %"HEKf,
4040 HEKfARG(GvENAME_HEK(gv)));
4045 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
4049 sv = newSVpvn(dp->d_name, dp->d_namlen);
4051 sv = newSVpv(dp->d_name, 0);
4053 if (!(IoFLAGS(io) & IOf_UNTAINT))
4056 } while (gimme == G_ARRAY);
4058 if (!dp && gimme != G_ARRAY)
4065 SETERRNO(EBADF,RMS_ISI);
4066 if (gimme == G_ARRAY)
4075 #if defined(HAS_TELLDIR) || defined(telldir)
4077 /* XXX does _anyone_ need this? --AD 2/20/1998 */
4078 /* XXX netbsd still seemed to.
4079 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
4080 --JHI 1999-Feb-02 */
4081 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
4082 long telldir (DIR *);
4084 GV * const gv = MUTABLE_GV(POPs);
4085 IO * const io = GvIOn(gv);
4088 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4089 "telldir() attempted on invalid dirhandle %"HEKf,
4090 HEKfARG(GvENAME_HEK(gv)));
4094 PUSHi( PerlDir_tell(IoDIRP(io)) );
4098 SETERRNO(EBADF,RMS_ISI);
4101 DIE(aTHX_ PL_no_dir_func, "telldir");
4107 #if defined(HAS_SEEKDIR) || defined(seekdir)
4109 const long along = POPl;
4110 GV * const gv = MUTABLE_GV(POPs);
4111 IO * const io = GvIOn(gv);
4114 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4115 "seekdir() attempted on invalid dirhandle %"HEKf,
4116 HEKfARG(GvENAME_HEK(gv)));
4119 (void)PerlDir_seek(IoDIRP(io), along);
4124 SETERRNO(EBADF,RMS_ISI);
4127 DIE(aTHX_ PL_no_dir_func, "seekdir");
4133 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4135 GV * const gv = MUTABLE_GV(POPs);
4136 IO * const io = GvIOn(gv);
4139 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4140 "rewinddir() attempted on invalid dirhandle %"HEKf,
4141 HEKfARG(GvENAME_HEK(gv)));
4144 (void)PerlDir_rewind(IoDIRP(io));
4148 SETERRNO(EBADF,RMS_ISI);
4151 DIE(aTHX_ PL_no_dir_func, "rewinddir");
4157 #if defined(Direntry_t) && defined(HAS_READDIR)
4159 GV * const gv = MUTABLE_GV(POPs);
4160 IO * const io = GvIOn(gv);
4163 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4164 "closedir() attempted on invalid dirhandle %"HEKf,
4165 HEKfARG(GvENAME_HEK(gv)));
4168 #ifdef VOID_CLOSEDIR
4169 PerlDir_close(IoDIRP(io));
4171 if (PerlDir_close(IoDIRP(io)) < 0) {
4172 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4181 SETERRNO(EBADF,RMS_IFI);
4184 DIE(aTHX_ PL_no_dir_func, "closedir");
4188 /* Process control. */
4195 #ifdef HAS_SIGPROCMASK
4196 sigset_t oldmask, newmask;
4200 PERL_FLUSHALL_FOR_CHILD;
4201 #ifdef HAS_SIGPROCMASK
4202 sigfillset(&newmask);
4203 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4205 childpid = PerlProc_fork();
4206 if (childpid == 0) {
4210 for (sig = 1; sig < SIG_SIZE; sig++)
4211 PL_psig_pend[sig] = 0;
4213 #ifdef HAS_SIGPROCMASK
4216 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4223 #ifdef PERL_USES_PL_PIDSTATUS
4224 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4230 # if (defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)) || defined(__amigaos4__)
4235 PERL_FLUSHALL_FOR_CHILD;
4236 childpid = PerlProc_fork();
4242 DIE(aTHX_ PL_no_func, "fork");
4249 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4254 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4255 childpid = wait4pid(-1, &argflags, 0);
4257 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4262 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4263 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4264 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4266 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4271 DIE(aTHX_ PL_no_func, "wait");
4277 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4279 const int optype = POPi;
4280 const Pid_t pid = TOPi;
4284 result = amigaos_waitpid(aTHX_ optype, pid, &argflags);
4285 STATUS_NATIVE_CHILD_SET((result >= 0) ? argflags : -1);
4286 result = result == 0 ? pid : -1;
4290 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4291 result = wait4pid(pid, &argflags, optype);
4293 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4298 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4299 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4300 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4302 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4304 # endif /* __amigaos4__ */
4308 DIE(aTHX_ PL_no_func, "waitpid");
4314 dSP; dMARK; dORIGMARK; dTARGET;
4315 #if defined(__LIBCATAMOUNT__)
4316 PL_statusvalue = -1;
4321 # ifdef __amigaos4__
4329 while (++MARK <= SP) {
4330 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4335 TAINT_PROPER("system");
4337 PERL_FLUSHALL_FOR_CHILD;
4338 #if (defined(HAS_FORK) || defined(__amigaos4__)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4341 struct UserData userdata;
4348 bool child_success = FALSE;
4349 #ifdef HAS_SIGPROCMASK
4350 sigset_t newset, oldset;
4353 if (PerlProc_pipe(pp) >= 0)
4356 amigaos_fork_set_userdata(aTHX_
4362 pthread_create(&proc,NULL,amigaos_system_child,(void *)&userdata);
4363 child_success = proc > 0;
4365 #ifdef HAS_SIGPROCMASK
4366 sigemptyset(&newset);
4367 sigaddset(&newset, SIGCHLD);
4368 sigprocmask(SIG_BLOCK, &newset, &oldset);
4370 while ((childpid = PerlProc_fork()) == -1) {
4371 if (errno != EAGAIN) {
4376 PerlLIO_close(pp[0]);
4377 PerlLIO_close(pp[1]);
4379 #ifdef HAS_SIGPROCMASK
4380 sigprocmask(SIG_SETMASK, &oldset, NULL);
4386 child_success = childpid > 0;
4388 if (child_success) {
4389 Sigsave_t ihand,qhand; /* place to save signals during system() */
4392 #ifndef __amigaos4__
4394 PerlLIO_close(pp[1]);
4397 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4398 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4401 result = pthread_join(proc, (void **)&status);
4404 result = wait4pid(childpid, &status, 0);
4405 } while (result == -1 && errno == EINTR);
4408 #ifdef HAS_SIGPROCMASK
4409 sigprocmask(SIG_SETMASK, &oldset, NULL);
4411 (void)rsignal_restore(SIGINT, &ihand);
4412 (void)rsignal_restore(SIGQUIT, &qhand);
4414 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4415 do_execfree(); /* free any memory child malloced on fork */
4422 while (n < sizeof(int)) {
4423 n1 = PerlLIO_read(pp[0],
4424 (void*)(((char*)&errkid)+n),
4430 PerlLIO_close(pp[0]);
4431 if (n) { /* Error */
4432 if (n != sizeof(int))
4433 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4434 errno = errkid; /* Propagate errno from kid */
4436 /* The pipe always has something in it
4437 * so n alone is not enough. */
4441 STATUS_NATIVE_CHILD_SET(-1);
4445 XPUSHi(STATUS_CURRENT);
4448 #ifndef __amigaos4__
4449 #ifdef HAS_SIGPROCMASK
4450 sigprocmask(SIG_SETMASK, &oldset, NULL);
4453 PerlLIO_close(pp[0]);
4454 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
4455 if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
4459 if (PL_op->op_flags & OPf_STACKED) {
4460 SV * const really = *++MARK;
4461 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4463 else if (SP - MARK != 1)
4464 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4466 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4468 #endif /* __amigaos4__ */
4471 #else /* ! FORK or VMS or OS/2 */
4474 if (PL_op->op_flags & OPf_STACKED) {
4475 SV * const really = *++MARK;
4476 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4477 value = (I32)do_aspawn(really, MARK, SP);
4479 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4482 else if (SP - MARK != 1) {
4483 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4484 value = (I32)do_aspawn(NULL, MARK, SP);
4486 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4490 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4492 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4494 STATUS_NATIVE_CHILD_SET(value);
4497 XPUSHi(result ? value : STATUS_CURRENT);
4498 #endif /* !FORK or VMS or OS/2 */
4505 dSP; dMARK; dORIGMARK; dTARGET;
4510 while (++MARK <= SP) {
4511 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4516 TAINT_PROPER("exec");
4519 PERL_FLUSHALL_FOR_CHILD;
4520 if (PL_op->op_flags & OPf_STACKED) {
4521 SV * const really = *++MARK;
4522 value = (I32)do_aexec(really, MARK, SP);
4524 else if (SP - MARK != 1)
4526 value = (I32)vms_do_aexec(NULL, MARK, SP);
4528 value = (I32)do_aexec(NULL, MARK, SP);
4532 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4534 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4546 XPUSHi( getppid() );
4549 DIE(aTHX_ PL_no_func, "getppid");
4559 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4562 pgrp = (I32)BSD_GETPGRP(pid);
4564 if (pid != 0 && pid != PerlProc_getpid())
4565 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4571 DIE(aTHX_ PL_no_func, "getpgrp");
4581 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4582 if (MAXARG > 0) pid = TOPs ? TOPi : 0;
4589 TAINT_PROPER("setpgrp");
4591 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4593 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4594 || (pid != 0 && pid != PerlProc_getpid()))
4596 DIE(aTHX_ "setpgrp can't take arguments");
4598 SETi( setpgrp() >= 0 );
4599 #endif /* USE_BSDPGRP */
4602 DIE(aTHX_ PL_no_func, "setpgrp");
4606 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4607 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4609 # define PRIORITY_WHICH_T(which) which
4614 #ifdef HAS_GETPRIORITY
4616 const int who = POPi;
4617 const int which = TOPi;
4618 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4621 DIE(aTHX_ PL_no_func, "getpriority");
4627 #ifdef HAS_SETPRIORITY
4629 const int niceval = POPi;
4630 const int who = POPi;
4631 const int which = TOPi;
4632 TAINT_PROPER("setpriority");
4633 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4636 DIE(aTHX_ PL_no_func, "setpriority");
4640 #undef PRIORITY_WHICH_T
4648 XPUSHn( time(NULL) );
4650 XPUSHi( time(NULL) );
4659 struct tms timesbuf;
4662 (void)PerlProc_times(×buf);
4664 mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
4665 if (GIMME_V == G_ARRAY) {
4666 mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
4667 mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
4668 mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
4676 if (GIMME_V == G_ARRAY) {
4683 DIE(aTHX_ "times not implemented");
4685 #endif /* HAS_TIMES */
4688 /* The 32 bit int year limits the times we can represent to these
4689 boundaries with a few days wiggle room to account for time zone
4692 /* Sat Jan 3 00:00:00 -2147481748 */
4693 #define TIME_LOWER_BOUND -67768100567755200.0
4694 /* Sun Dec 29 12:00:00 2147483647 */
4695 #define TIME_UPPER_BOUND 67767976233316800.0
4698 /* also used for: pp_localtime() */
4706 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4707 static const char * const dayname[] =
4708 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4709 static const char * const monname[] =
4710 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4711 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4713 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4716 when = (Time64_T)now;
4719 NV input = Perl_floor(POPn);
4720 const bool pl_isnan = Perl_isnan(input);
4721 when = (Time64_T)input;
4722 if (UNLIKELY(pl_isnan || when != input)) {
4723 /* diag_listed_as: gmtime(%f) too large */
4724 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4725 "%s(%.0" NVff ") too large", opname, input);
4733 if ( TIME_LOWER_BOUND > when ) {
4734 /* diag_listed_as: gmtime(%f) too small */
4735 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4736 "%s(%.0" NVff ") too small", opname, when);
4739 else if( when > TIME_UPPER_BOUND ) {
4740 /* diag_listed_as: gmtime(%f) too small */
4741 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4742 "%s(%.0" NVff ") too large", opname, when);
4746 if (PL_op->op_type == OP_LOCALTIME)
4747 err = Perl_localtime64_r(&when, &tmbuf);
4749 err = Perl_gmtime64_r(&when, &tmbuf);
4753 /* diag_listed_as: gmtime(%f) failed */
4754 /* XXX %lld broken for quads */
4756 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4757 "%s(%.0" NVff ") failed", opname, when);
4760 if (GIMME_V != G_ARRAY) { /* scalar context */
4767 Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %"IVdf,
4768 dayname[tmbuf.tm_wday],
4769 monname[tmbuf.tm_mon],
4774 (IV)tmbuf.tm_year + 1900);
4777 else { /* list context */
4783 mPUSHi(tmbuf.tm_sec);
4784 mPUSHi(tmbuf.tm_min);
4785 mPUSHi(tmbuf.tm_hour);
4786 mPUSHi(tmbuf.tm_mday);
4787 mPUSHi(tmbuf.tm_mon);
4788 mPUSHn(tmbuf.tm_year);
4789 mPUSHi(tmbuf.tm_wday);
4790 mPUSHi(tmbuf.tm_yday);
4791 mPUSHi(tmbuf.tm_isdst);
4800 /* alarm() takes an unsigned int number of seconds, and return the
4801 * unsigned int number of seconds remaining in the previous alarm
4802 * (alarms don't stack). Therefore negative return values are not
4806 /* Note that while the C library function alarm() as such has
4807 * no errors defined (or in other words, properly behaving client
4808 * code shouldn't expect any), alarm() being obsoleted by
4809 * setitimer() and often being implemented in terms of
4810 * setitimer(), can fail. */
4811 /* diag_listed_as: %s() with negative argument */
4812 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4813 "alarm() with negative argument");
4814 SETERRNO(EINVAL, LIB_INVARG);
4818 unsigned int retval = alarm(anum);
4819 if ((int)retval < 0) /* Strictly speaking "cannot happen". */
4825 DIE(aTHX_ PL_no_func, "alarm");
4836 (void)time(&lasttime);
4837 if (MAXARG < 1 || (!TOPs && !POPs))
4842 /* diag_listed_as: %s() with negative argument */
4843 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4844 "sleep() with negative argument");
4845 SETERRNO(EINVAL, LIB_INVARG);
4849 PerlProc_sleep((unsigned int)duration);
4853 XPUSHi(when - lasttime);
4857 /* Shared memory. */
4858 /* Merged with some message passing. */
4860 /* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */
4864 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4865 dSP; dMARK; dTARGET;
4866 const int op_type = PL_op->op_type;
4871 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4874 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4877 value = (I32)(do_semop(MARK, SP) >= 0);
4880 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4888 return Perl_pp_semget(aTHX);
4894 /* also used for: pp_msgget() pp_shmget() */
4898 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4899 dSP; dMARK; dTARGET;
4900 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4907 DIE(aTHX_ "System V IPC is not implemented on this machine");
4911 /* also used for: pp_msgctl() pp_shmctl() */
4915 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4916 dSP; dMARK; dTARGET;
4917 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4925 PUSHp(zero_but_true, ZBTLEN);
4929 return Perl_pp_semget(aTHX);
4933 /* I can't const this further without getting warnings about the types of
4934 various arrays passed in from structures. */
4936 S_space_join_names_mortal(pTHX_ char *const *array)
4940 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4943 target = newSVpvs_flags("", SVs_TEMP);
4945 sv_catpv(target, *array);
4948 sv_catpvs(target, " ");
4951 target = sv_mortalcopy(&PL_sv_no);
4956 /* Get system info. */
4958 /* also used for: pp_ghbyaddr() pp_ghbyname() */
4962 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4964 I32 which = PL_op->op_type;
4967 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4968 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4969 struct hostent *gethostbyname(Netdb_name_t);
4970 struct hostent *gethostent(void);
4972 struct hostent *hent = NULL;
4976 if (which == OP_GHBYNAME) {
4977 #ifdef HAS_GETHOSTBYNAME
4978 const char* const name = POPpbytex;
4979 hent = PerlSock_gethostbyname(name);
4981 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4984 else if (which == OP_GHBYADDR) {
4985 #ifdef HAS_GETHOSTBYADDR
4986 const int addrtype = POPi;
4987 SV * const addrsv = POPs;
4989 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4991 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4993 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4997 #ifdef HAS_GETHOSTENT
4998 hent = PerlSock_gethostent();
5000 DIE(aTHX_ PL_no_sock_func, "gethostent");
5003 #ifdef HOST_NOT_FOUND
5005 #ifdef USE_REENTRANT_API
5006 # ifdef USE_GETHOSTENT_ERRNO
5007 h_errno = PL_reentrant_buffer->_gethostent_errno;
5010 STATUS_UNIX_SET(h_errno);
5014 if (GIMME_V != G_ARRAY) {
5015 PUSHs(sv = sv_newmortal());
5017 if (which == OP_GHBYNAME) {
5019 sv_setpvn(sv, hent->h_addr, hent->h_length);
5022 sv_setpv(sv, (char*)hent->h_name);
5028 mPUSHs(newSVpv((char*)hent->h_name, 0));
5029 PUSHs(space_join_names_mortal(hent->h_aliases));
5030 mPUSHi(hent->h_addrtype);
5031 len = hent->h_length;
5034 for (elem = hent->h_addr_list; elem && *elem; elem++) {
5035 mXPUSHp(*elem, len);
5039 mPUSHp(hent->h_addr, len);
5041 PUSHs(sv_mortalcopy(&PL_sv_no));
5046 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5050 /* also used for: pp_gnbyaddr() pp_gnbyname() */
5054 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
5056 I32 which = PL_op->op_type;
5058 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
5059 struct netent *getnetbyaddr(Netdb_net_t, int);
5060 struct netent *getnetbyname(Netdb_name_t);
5061 struct netent *getnetent(void);
5063 struct netent *nent;
5065 if (which == OP_GNBYNAME){
5066 #ifdef HAS_GETNETBYNAME
5067 const char * const name = POPpbytex;
5068 nent = PerlSock_getnetbyname(name);
5070 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
5073 else if (which == OP_GNBYADDR) {
5074 #ifdef HAS_GETNETBYADDR
5075 const int addrtype = POPi;
5076 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
5077 nent = PerlSock_getnetbyaddr(addr, addrtype);
5079 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
5083 #ifdef HAS_GETNETENT
5084 nent = PerlSock_getnetent();
5086 DIE(aTHX_ PL_no_sock_func, "getnetent");
5089 #ifdef HOST_NOT_FOUND
5091 #ifdef USE_REENTRANT_API
5092 # ifdef USE_GETNETENT_ERRNO
5093 h_errno = PL_reentrant_buffer->_getnetent_errno;
5096 STATUS_UNIX_SET(h_errno);
5101 if (GIMME_V != G_ARRAY) {
5102 PUSHs(sv = sv_newmortal());
5104 if (which == OP_GNBYNAME)
5105 sv_setiv(sv, (IV)nent->n_net);
5107 sv_setpv(sv, nent->n_name);
5113 mPUSHs(newSVpv(nent->n_name, 0));
5114 PUSHs(space_join_names_mortal(nent->n_aliases));
5115 mPUSHi(nent->n_addrtype);
5116 mPUSHi(nent->n_net);
5121 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5126 /* also used for: pp_gpbyname() pp_gpbynumber() */
5130 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
5132 I32 which = PL_op->op_type;
5134 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
5135 struct protoent *getprotobyname(Netdb_name_t);
5136 struct protoent *getprotobynumber(int);
5137 struct protoent *getprotoent(void);
5139 struct protoent *pent;
5141 if (which == OP_GPBYNAME) {
5142 #ifdef HAS_GETPROTOBYNAME
5143 const char* const name = POPpbytex;
5144 pent = PerlSock_getprotobyname(name);
5146 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
5149 else if (which == OP_GPBYNUMBER) {
5150 #ifdef HAS_GETPROTOBYNUMBER
5151 const int number = POPi;
5152 pent = PerlSock_getprotobynumber(number);
5154 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
5158 #ifdef HAS_GETPROTOENT
5159 pent = PerlSock_getprotoent();
5161 DIE(aTHX_ PL_no_sock_func, "getprotoent");
5165 if (GIMME_V != G_ARRAY) {
5166 PUSHs(sv = sv_newmortal());
5168 if (which == OP_GPBYNAME)
5169 sv_setiv(sv, (IV)pent->p_proto);
5171 sv_setpv(sv, pent->p_name);
5177 mPUSHs(newSVpv(pent->p_name, 0));
5178 PUSHs(space_join_names_mortal(pent->p_aliases));
5179 mPUSHi(pent->p_proto);
5184 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5189 /* also used for: pp_gsbyname() pp_gsbyport() */
5193 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
5195 I32 which = PL_op->op_type;
5197 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
5198 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
5199 struct servent *getservbyport(int, Netdb_name_t);
5200 struct servent *getservent(void);
5202 struct servent *sent;
5204 if (which == OP_GSBYNAME) {
5205 #ifdef HAS_GETSERVBYNAME
5206 const char * const proto = POPpbytex;
5207 const char * const name = POPpbytex;
5208 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5210 DIE(aTHX_ PL_no_sock_func, "getservbyname");
5213 else if (which == OP_GSBYPORT) {
5214 #ifdef HAS_GETSERVBYPORT
5215 const char * const proto = POPpbytex;
5216 unsigned short port = (unsigned short)POPu;
5217 port = PerlSock_htons(port);
5218 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5220 DIE(aTHX_ PL_no_sock_func, "getservbyport");
5224 #ifdef HAS_GETSERVENT
5225 sent = PerlSock_getservent();
5227 DIE(aTHX_ PL_no_sock_func, "getservent");
5231 if (GIMME_V != G_ARRAY) {
5232 PUSHs(sv = sv_newmortal());
5234 if (which == OP_GSBYNAME) {
5235 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5238 sv_setpv(sv, sent->s_name);
5244 mPUSHs(newSVpv(sent->s_name, 0));
5245 PUSHs(space_join_names_mortal(sent->s_aliases));
5246 mPUSHi(PerlSock_ntohs(sent->s_port));
5247 mPUSHs(newSVpv(sent->s_proto, 0));
5252 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5257 /* also used for: pp_snetent() pp_sprotoent() pp_sservent() */
5262 const int stayopen = TOPi;
5263 switch(PL_op->op_type) {
5265 #ifdef HAS_SETHOSTENT
5266 PerlSock_sethostent(stayopen);
5268 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5271 #ifdef HAS_SETNETENT
5273 PerlSock_setnetent(stayopen);
5275 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5279 #ifdef HAS_SETPROTOENT
5280 PerlSock_setprotoent(stayopen);
5282 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5286 #ifdef HAS_SETSERVENT
5287 PerlSock_setservent(stayopen);
5289 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5297 /* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent()
5298 * pp_eservent() pp_sgrent() pp_spwent() */
5303 switch(PL_op->op_type) {
5305 #ifdef HAS_ENDHOSTENT
5306 PerlSock_endhostent();
5308 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5312 #ifdef HAS_ENDNETENT
5313 PerlSock_endnetent();
5315 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5319 #ifdef HAS_ENDPROTOENT
5320 PerlSock_endprotoent();
5322 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5326 #ifdef HAS_ENDSERVENT
5327 PerlSock_endservent();
5329 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5333 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5336 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5340 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5343 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5347 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5350 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5354 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5357 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5366 /* also used for: pp_gpwnam() pp_gpwuid() */
5372 I32 which = PL_op->op_type;
5374 struct passwd *pwent = NULL;
5376 * We currently support only the SysV getsp* shadow password interface.
5377 * The interface is declared in <shadow.h> and often one needs to link
5378 * with -lsecurity or some such.
5379 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5382 * AIX getpwnam() is clever enough to return the encrypted password
5383 * only if the caller (euid?) is root.
5385 * There are at least three other shadow password APIs. Many platforms
5386 * seem to contain more than one interface for accessing the shadow
5387 * password databases, possibly for compatibility reasons.
5388 * The getsp*() is by far he simplest one, the other two interfaces
5389 * are much more complicated, but also very similar to each other.
5394 * struct pr_passwd *getprpw*();
5395 * The password is in
5396 * char getprpw*(...).ufld.fd_encrypt[]
5397 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5402 * struct es_passwd *getespw*();
5403 * The password is in
5404 * char *(getespw*(...).ufld.fd_encrypt)
5405 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5408 * struct userpw *getuserpw();
5409 * The password is in
5410 * char *(getuserpw(...)).spw_upw_passwd
5411 * (but the de facto standard getpwnam() should work okay)
5413 * Mention I_PROT here so that Configure probes for it.
5415 * In HP-UX for getprpw*() the manual page claims that one should include
5416 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5417 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5418 * and pp_sys.c already includes <shadow.h> if there is such.
5420 * Note that <sys/security.h> is already probed for, but currently
5421 * it is only included in special cases.
5423 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5424 * be preferred interface, even though also the getprpw*() interface
5425 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5426 * One also needs to call set_auth_parameters() in main() before
5427 * doing anything else, whether one is using getespw*() or getprpw*().
5429 * Note that accessing the shadow databases can be magnitudes
5430 * slower than accessing the standard databases.
5435 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5436 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5437 * the pw_comment is left uninitialized. */
5438 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5444 const char* const name = POPpbytex;
5445 pwent = getpwnam(name);
5451 pwent = getpwuid(uid);
5455 # ifdef HAS_GETPWENT
5457 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5458 if (pwent) pwent = getpwnam(pwent->pw_name);
5461 DIE(aTHX_ PL_no_func, "getpwent");
5467 if (GIMME_V != G_ARRAY) {
5468 PUSHs(sv = sv_newmortal());
5470 if (which == OP_GPWNAM)
5471 sv_setuid(sv, pwent->pw_uid);
5473 sv_setpv(sv, pwent->pw_name);
5479 mPUSHs(newSVpv(pwent->pw_name, 0));
5483 /* If we have getspnam(), we try to dig up the shadow
5484 * password. If we are underprivileged, the shadow
5485 * interface will set the errno to EACCES or similar,
5486 * and return a null pointer. If this happens, we will
5487 * use the dummy password (usually "*" or "x") from the
5488 * standard password database.
5490 * In theory we could skip the shadow call completely
5491 * if euid != 0 but in practice we cannot know which
5492 * security measures are guarding the shadow databases
5493 * on a random platform.
5495 * Resist the urge to use additional shadow interfaces.
5496 * Divert the urge to writing an extension instead.
5499 /* Some AIX setups falsely(?) detect some getspnam(), which
5500 * has a different API than the Solaris/IRIX one. */
5501 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5504 const struct spwd * const spwent = getspnam(pwent->pw_name);
5505 /* Save and restore errno so that
5506 * underprivileged attempts seem
5507 * to have never made the unsuccessful
5508 * attempt to retrieve the shadow password. */
5510 if (spwent && spwent->sp_pwdp)
5511 sv_setpv(sv, spwent->sp_pwdp);
5515 if (!SvPOK(sv)) /* Use the standard password, then. */
5516 sv_setpv(sv, pwent->pw_passwd);
5519 /* passwd is tainted because user himself can diddle with it.
5520 * admittedly not much and in a very limited way, but nevertheless. */
5523 sv_setuid(PUSHmortal, pwent->pw_uid);
5524 sv_setgid(PUSHmortal, pwent->pw_gid);
5526 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5527 * because of the poor interface of the Perl getpw*(),
5528 * not because there's some standard/convention saying so.
5529 * A better interface would have been to return a hash,
5530 * but we are accursed by our history, alas. --jhi. */
5532 mPUSHi(pwent->pw_change);
5535 mPUSHi(pwent->pw_quota);
5538 mPUSHs(newSVpv(pwent->pw_age, 0));
5540 /* I think that you can never get this compiled, but just in case. */
5541 PUSHs(sv_mortalcopy(&PL_sv_no));
5546 /* pw_class and pw_comment are mutually exclusive--.
5547 * see the above note for pw_change, pw_quota, and pw_age. */
5549 mPUSHs(newSVpv(pwent->pw_class, 0));
5552 mPUSHs(newSVpv(pwent->pw_comment, 0));
5554 /* I think that you can never get this compiled, but just in case. */
5555 PUSHs(sv_mortalcopy(&PL_sv_no));
5560 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5562 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5564 /* pw_gecos is tainted because user himself can diddle with it. */
5567 mPUSHs(newSVpv(pwent->pw_dir, 0));
5569 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5570 /* pw_shell is tainted because user himself can diddle with it. */
5574 mPUSHi(pwent->pw_expire);
5579 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5584 /* also used for: pp_ggrgid() pp_ggrnam() */
5590 const I32 which = PL_op->op_type;
5591 const struct group *grent;
5593 if (which == OP_GGRNAM) {
5594 const char* const name = POPpbytex;
5595 grent = (const struct group *)getgrnam(name);
5597 else if (which == OP_GGRGID) {
5599 const Gid_t gid = POPu;
5600 #elif Gid_t_sign == -1
5601 const Gid_t gid = POPi;
5603 # error "Unexpected Gid_t_sign"
5605 grent = (const struct group *)getgrgid(gid);
5609 grent = (struct group *)getgrent();
5611 DIE(aTHX_ PL_no_func, "getgrent");
5615 if (GIMME_V != G_ARRAY) {
5616 SV * const sv = sv_newmortal();
5620 if (which == OP_GGRNAM)
5621 sv_setgid(sv, grent->gr_gid);
5623 sv_setpv(sv, grent->gr_name);
5629 mPUSHs(newSVpv(grent->gr_name, 0));
5632 mPUSHs(newSVpv(grent->gr_passwd, 0));
5634 PUSHs(sv_mortalcopy(&PL_sv_no));
5637 sv_setgid(PUSHmortal, grent->gr_gid);
5639 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5640 /* In UNICOS/mk (_CRAYMPP) the multithreading
5641 * versions (getgrnam_r, getgrgid_r)
5642 * seem to return an illegal pointer
5643 * as the group members list, gr_mem.
5644 * getgrent() doesn't even have a _r version
5645 * but the gr_mem is poisonous anyway.
5646 * So yes, you cannot get the list of group
5647 * members if building multithreaded in UNICOS/mk. */
5648 PUSHs(space_join_names_mortal(grent->gr_mem));
5654 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5664 if (!(tmps = PerlProc_getlogin()))
5666 sv_setpv_mg(TARG, tmps);
5670 DIE(aTHX_ PL_no_func, "getlogin");
5674 /* Miscellaneous. */
5679 dSP; dMARK; dORIGMARK; dTARGET;
5680 I32 items = SP - MARK;
5681 unsigned long a[20];
5686 while (++MARK <= SP) {
5687 if (SvTAINTED(*MARK)) {
5693 TAINT_PROPER("syscall");
5696 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5697 * or where sizeof(long) != sizeof(char*). But such machines will
5698 * not likely have syscall implemented either, so who cares?
5700 while (++MARK <= SP) {
5701 if (SvNIOK(*MARK) || !i)
5702 a[i++] = SvIV(*MARK);
5703 else if (*MARK == &PL_sv_undef)
5706 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5712 DIE(aTHX_ "Too many args to syscall");
5714 DIE(aTHX_ "Too few args to syscall");
5716 retval = syscall(a[0]);
5719 retval = syscall(a[0],a[1]);
5722 retval = syscall(a[0],a[1],a[2]);
5725 retval = syscall(a[0],a[1],a[2],a[3]);
5728 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5731 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5734 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5737 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5744 DIE(aTHX_ PL_no_func, "syscall");
5748 #ifdef FCNTL_EMULATE_FLOCK
5750 /* XXX Emulate flock() with fcntl().
5751 What's really needed is a good file locking module.
5755 fcntl_emulate_flock(int fd, int operation)
5760 switch (operation & ~LOCK_NB) {
5762 flock.l_type = F_RDLCK;
5765 flock.l_type = F_WRLCK;
5768 flock.l_type = F_UNLCK;
5774 flock.l_whence = SEEK_SET;
5775 flock.l_start = flock.l_len = (Off_t)0;
5777 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5778 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5779 errno = EWOULDBLOCK;
5783 #endif /* FCNTL_EMULATE_FLOCK */
5785 #ifdef LOCKF_EMULATE_FLOCK
5787 /* XXX Emulate flock() with lockf(). This is just to increase
5788 portability of scripts. The calls are not completely
5789 interchangeable. What's really needed is a good file
5793 /* The lockf() constants might have been defined in <unistd.h>.
5794 Unfortunately, <unistd.h> causes troubles on some mixed
5795 (BSD/POSIX) systems, such as SunOS 4.1.3.
5797 Further, the lockf() constants aren't POSIX, so they might not be
5798 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5799 just stick in the SVID values and be done with it. Sigh.
5803 # define F_ULOCK 0 /* Unlock a previously locked region */
5806 # define F_LOCK 1 /* Lock a region for exclusive use */
5809 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5812 # define F_TEST 3 /* Test a region for other processes locks */
5816 lockf_emulate_flock(int fd, int operation)
5822 /* flock locks entire file so for lockf we need to do the same */
5823 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5824 if (pos > 0) /* is seekable and needs to be repositioned */
5825 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5826 pos = -1; /* seek failed, so don't seek back afterwards */
5829 switch (operation) {
5831 /* LOCK_SH - get a shared lock */
5833 /* LOCK_EX - get an exclusive lock */
5835 i = lockf (fd, F_LOCK, 0);
5838 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5839 case LOCK_SH|LOCK_NB:
5840 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5841 case LOCK_EX|LOCK_NB:
5842 i = lockf (fd, F_TLOCK, 0);
5844 if ((errno == EAGAIN) || (errno == EACCES))
5845 errno = EWOULDBLOCK;
5848 /* LOCK_UN - unlock (non-blocking is a no-op) */
5850 case LOCK_UN|LOCK_NB:
5851 i = lockf (fd, F_ULOCK, 0);
5854 /* Default - can't decipher operation */
5861 if (pos > 0) /* need to restore position of the handle */
5862 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5867 #endif /* LOCKF_EMULATE_FLOCK */
5870 * ex: set ts=8 sts=4 sw=4 et: