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 U8 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 GV *oldgv = PL_defoutgv;
1297 PERL_ARGS_ASSERT_SETDEFOUT;
1299 SvREFCNT_inc_simple_void_NN(gv);
1301 SvREFCNT_dec(oldgv);
1308 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1309 GV * egv = GvEGVx(PL_defoutgv);
1314 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1315 gvp = hv && HvENAME(hv)
1316 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1318 if (gvp && *gvp == egv) {
1319 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1323 mXPUSHs(newRV(MUTABLE_SV(egv)));
1327 if (!GvIO(newdefout))
1328 gv_IOadd(newdefout);
1329 setdefout(newdefout);
1339 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1340 IO *const io = GvIO(gv);
1346 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1348 const U8 gimme = GIMME_V;
1349 Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1350 if (gimme == G_SCALAR) {
1352 SvSetMagicSV_nosteal(TARG, TOPs);
1357 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1358 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1360 SETERRNO(EBADF,RMS_IFI);
1364 sv_setpvs(TARG, " ");
1365 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1366 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1367 /* Find out how many bytes the char needs */
1368 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1371 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1372 SvCUR_set(TARG,1+len);
1376 else SvUTF8_off(TARG);
1382 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1385 const U8 gimme = GIMME_V;
1387 PERL_ARGS_ASSERT_DOFORM;
1390 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1392 cx = cx_pushblock(CXt_FORMAT, gimme, PL_stack_sp, PL_savestack_ix);
1393 cx_pushformat(cx, cv, retop, gv);
1394 if (CvDEPTH(cv) >= 2)
1395 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1396 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1398 setdefout(gv); /* locally select filehandle so $% et al work */
1416 gv = MUTABLE_GV(POPs);
1433 tmpsv = sv_newmortal();
1434 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1435 DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
1437 IoFLAGS(io) &= ~IOf_DIDTOP;
1438 RETURNOP(doform(cv,gv,PL_op->op_next));
1444 GV * const gv = CX_CUR()->blk_format.gv;
1445 IO * const io = GvIOp(gv);
1450 bool is_return = cBOOL(PL_op->op_type == OP_RETURN);
1452 if (is_return || !io || !(ofp = IoOFP(io)))
1455 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1456 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1458 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1459 PL_formtarget != PL_toptarget)
1463 if (!IoTOP_GV(io)) {
1466 if (!IoTOP_NAME(io)) {
1468 if (!IoFMT_NAME(io))
1469 IoFMT_NAME(io) = savepv(GvNAME(gv));
1470 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1471 HEKfARG(GvNAME_HEK(gv))));
1472 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1473 if ((topgv && GvFORM(topgv)) ||
1474 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1475 IoTOP_NAME(io) = savesvpv(topname);
1477 IoTOP_NAME(io) = savepvs("top");
1479 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1480 if (!topgv || !GvFORM(topgv)) {
1481 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1484 IoTOP_GV(io) = topgv;
1486 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1487 I32 lines = IoLINES_LEFT(io);
1488 const char *s = SvPVX_const(PL_formtarget);
1489 if (lines <= 0) /* Yow, header didn't even fit!!! */
1491 while (lines-- > 0) {
1492 s = strchr(s, '\n');
1498 const STRLEN save = SvCUR(PL_formtarget);
1499 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1500 do_print(PL_formtarget, ofp);
1501 SvCUR_set(PL_formtarget, save);
1502 sv_chop(PL_formtarget, s);
1503 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1506 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1507 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1508 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1510 PL_formtarget = PL_toptarget;
1511 IoFLAGS(io) |= IOf_DIDTOP;
1513 assert(fgv); /* IoTOP_GV(io) should have been set above */
1516 SV * const sv = sv_newmortal();
1517 gv_efullname4(sv, fgv, NULL, FALSE);
1518 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1520 return doform(cv, gv, PL_op);
1525 assert(CxTYPE(cx) == CXt_FORMAT);
1526 SP = PL_stack_base + cx->blk_oldsp; /* ignore retval of formline */
1530 retop = cx->blk_sub.retop;
1534 /* XXX the semantics of doing 'return' in a format aren't documented.
1535 * Currently we ignore any args to 'return' and just return
1536 * a single undef in both scalar and list contexts
1538 PUSHs(&PL_sv_undef);
1539 else if (!io || !(fp = IoOFP(io))) {
1540 if (io && IoIFP(io))
1541 report_wrongway_fh(gv, '<');
1547 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1548 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1550 if (!do_print(PL_formtarget, fp))
1553 FmLINES(PL_formtarget) = 0;
1554 SvCUR_set(PL_formtarget, 0);
1555 *SvEND(PL_formtarget) = '\0';
1556 if (IoFLAGS(io) & IOf_FLUSH)
1557 (void)PerlIO_flush(fp);
1561 PL_formtarget = PL_bodytarget;
1567 dSP; dMARK; dORIGMARK;
1571 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1572 IO *const io = GvIO(gv);
1574 /* Treat empty list as "" */
1575 if (MARK == SP) XPUSHs(&PL_sv_no);
1578 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1580 if (MARK == ORIGMARK) {
1583 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1586 return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1588 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1595 SETERRNO(EBADF,RMS_IFI);
1598 else if (!(fp = IoOFP(io))) {
1600 report_wrongway_fh(gv, '<');
1601 else if (ckWARN(WARN_CLOSED))
1603 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1607 SV *sv = sv_newmortal();
1608 do_sprintf(sv, SP - MARK, MARK + 1);
1609 if (!do_print(sv, fp))
1612 if (IoFLAGS(io) & IOf_FLUSH)
1613 if (PerlIO_flush(fp) == EOF)
1622 PUSHs(&PL_sv_undef);
1629 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1630 const int mode = POPi;
1631 SV * const sv = POPs;
1632 GV * const gv = MUTABLE_GV(POPs);
1635 /* Need TIEHANDLE method ? */
1636 const char * const tmps = SvPV_const(sv, len);
1637 if (do_open_raw(gv, tmps, len, mode, perm)) {
1638 IoLINES(GvIOp(gv)) = 0;
1642 PUSHs(&PL_sv_undef);
1648 /* also used for: pp_read() and pp_recv() (where supported) */
1652 dSP; dMARK; dORIGMARK; dTARGET;
1666 bool charstart = FALSE;
1667 STRLEN charskip = 0;
1669 GV * const gv = MUTABLE_GV(*++MARK);
1672 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1673 && gv && (io = GvIO(gv)) )
1675 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1677 return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1678 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1687 sv_setpvs(bufsv, "");
1688 length = SvIVx(*++MARK);
1690 DIE(aTHX_ "Negative length");
1693 offset = SvIVx(*++MARK);
1697 if (!io || !IoIFP(io)) {
1699 SETERRNO(EBADF,RMS_IFI);
1703 /* Note that fd can here validly be -1, don't check it yet. */
1704 fd = PerlIO_fileno(IoIFP(io));
1706 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1707 if (PL_op->op_type == OP_SYSREAD || PL_op->op_type == OP_RECV) {
1708 Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
1709 "%s() is deprecated on :utf8 handles",
1712 buffer = SvPVutf8_force(bufsv, blen);
1713 /* UTF-8 may not have been set if they are all low bytes */
1718 buffer = SvPV_force(bufsv, blen);
1719 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1721 if (DO_UTF8(bufsv)) {
1722 blen = sv_len_utf8_nomg(bufsv);
1731 if (PL_op->op_type == OP_RECV) {
1732 Sock_size_t bufsize;
1733 char namebuf[MAXPATHLEN];
1735 SETERRNO(EBADF,SS_IVCHAN);
1738 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1739 bufsize = sizeof (struct sockaddr_in);
1741 bufsize = sizeof namebuf;
1743 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1747 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1748 /* 'offset' means 'flags' here */
1749 count = PerlSock_recvfrom(fd, buffer, length, offset,
1750 (struct sockaddr *)namebuf, &bufsize);
1753 /* MSG_TRUNC can give oversized count; quietly lose it */
1756 SvCUR_set(bufsv, count);
1757 *SvEND(bufsv) = '\0';
1758 (void)SvPOK_only(bufsv);
1762 /* This should not be marked tainted if the fp is marked clean */
1763 if (!(IoFLAGS(io) & IOf_UNTAINT))
1764 SvTAINTED_on(bufsv);
1766 #if defined(__CYGWIN__)
1767 /* recvfrom() on cygwin doesn't set bufsize at all for
1768 connected sockets, leaving us with trash in the returned
1769 name, so use the same test as the Win32 code to check if it
1770 wasn't set, and set it [perl #118843] */
1771 if (bufsize == sizeof namebuf)
1774 sv_setpvn(TARG, namebuf, bufsize);
1780 if (-offset > (SSize_t)blen)
1781 DIE(aTHX_ "Offset outside string");
1784 if (DO_UTF8(bufsv)) {
1785 /* convert offset-as-chars to offset-as-bytes */
1786 if (offset >= (SSize_t)blen)
1787 offset += SvCUR(bufsv) - blen;
1789 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1793 /* Reestablish the fd in case it shifted from underneath us. */
1794 fd = PerlIO_fileno(IoIFP(io));
1796 orig_size = SvCUR(bufsv);
1797 /* Allocating length + offset + 1 isn't perfect in the case of reading
1798 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1800 (should be 2 * length + offset + 1, or possibly something longer if
1801 IN_ENCODING Is true) */
1802 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1803 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1804 Zero(buffer+orig_size, offset-orig_size, char);
1806 buffer = buffer + offset;
1808 read_target = bufsv;
1810 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1811 concatenate it to the current buffer. */
1813 /* Truncate the existing buffer to the start of where we will be
1815 SvCUR_set(bufsv, offset);
1817 read_target = sv_newmortal();
1818 SvUPGRADE(read_target, SVt_PV);
1819 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1822 if (PL_op->op_type == OP_SYSREAD) {
1823 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1824 if (IoTYPE(io) == IoTYPE_SOCKET) {
1826 SETERRNO(EBADF,SS_IVCHAN);
1830 count = PerlSock_recv(fd, buffer, length, 0);
1836 SETERRNO(EBADF,RMS_IFI);
1840 count = PerlLIO_read(fd, buffer, length);
1845 count = PerlIO_read(IoIFP(io), buffer, length);
1846 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1847 if (count == 0 && PerlIO_error(IoIFP(io)))
1851 if (IoTYPE(io) == IoTYPE_WRONLY)
1852 report_wrongway_fh(gv, '>');
1855 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1856 *SvEND(read_target) = '\0';
1857 (void)SvPOK_only(read_target);
1858 if (fp_utf8 && !IN_BYTES) {
1859 /* Look at utf8 we got back and count the characters */
1860 const char *bend = buffer + count;
1861 while (buffer < bend) {
1863 skip = UTF8SKIP(buffer);
1866 if (buffer - charskip + skip > bend) {
1867 /* partial character - try for rest of it */
1868 length = skip - (bend-buffer);
1869 offset = bend - SvPVX_const(bufsv);
1881 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1882 provided amount read (count) was what was requested (length)
1884 if (got < wanted && count == length) {
1885 length = wanted - got;
1886 offset = bend - SvPVX_const(bufsv);
1889 /* return value is character count */
1893 else if (buffer_utf8) {
1894 /* Let svcatsv upgrade the bytes we read in to utf8.
1895 The buffer is a mortal so will be freed soon. */
1896 sv_catsv_nomg(bufsv, read_target);
1899 /* This should not be marked tainted if the fp is marked clean */
1900 if (!(IoFLAGS(io) & IOf_UNTAINT))
1901 SvTAINTED_on(bufsv);
1912 /* also used for: pp_send() where defined */
1916 dSP; dMARK; dORIGMARK; dTARGET;
1921 STRLEN orig_blen_bytes;
1922 const int op_type = PL_op->op_type;
1925 GV *const gv = MUTABLE_GV(*++MARK);
1926 IO *const io = GvIO(gv);
1929 if (op_type == OP_SYSWRITE && io) {
1930 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1932 if (MARK == SP - 1) {
1934 mXPUSHi(sv_len(sv));
1938 return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1939 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1949 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1951 if (io && IoIFP(io))
1952 report_wrongway_fh(gv, '<');
1955 SETERRNO(EBADF,RMS_IFI);
1958 fd = PerlIO_fileno(IoIFP(io));
1960 SETERRNO(EBADF,SS_IVCHAN);
1965 /* Do this first to trigger any overloading. */
1966 buffer = SvPV_const(bufsv, blen);
1967 orig_blen_bytes = blen;
1968 doing_utf8 = DO_UTF8(bufsv);
1970 if (PerlIO_isutf8(IoIFP(io))) {
1971 Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
1972 "%s() is deprecated on :utf8 handles",
1974 if (!SvUTF8(bufsv)) {
1975 /* We don't modify the original scalar. */
1976 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1977 buffer = (char *) tmpbuf;
1981 else if (doing_utf8) {
1982 STRLEN tmplen = blen;
1983 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1986 buffer = (char *) tmpbuf;
1990 assert((char *)result == buffer);
1991 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1996 if (op_type == OP_SEND) {
1997 const int flags = SvIVx(*++MARK);
2000 char * const sockbuf = SvPVx(*++MARK, mlen);
2001 retval = PerlSock_sendto(fd, buffer, blen,
2002 flags, (struct sockaddr *)sockbuf, mlen);
2005 retval = PerlSock_send(fd, buffer, blen, flags);
2011 Size_t length = 0; /* This length is in characters. */
2017 /* The SV is bytes, and we've had to upgrade it. */
2018 blen_chars = orig_blen_bytes;
2020 /* The SV really is UTF-8. */
2021 /* Don't call sv_len_utf8 on a magical or overloaded
2022 scalar, as we might get back a different result. */
2023 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
2030 length = blen_chars;
2032 #if Size_t_size > IVSIZE
2033 length = (Size_t)SvNVx(*++MARK);
2035 length = (Size_t)SvIVx(*++MARK);
2037 if ((SSize_t)length < 0) {
2039 DIE(aTHX_ "Negative length");
2044 offset = SvIVx(*++MARK);
2046 if (-offset > (IV)blen_chars) {
2048 DIE(aTHX_ "Offset outside string");
2050 offset += blen_chars;
2051 } else if (offset > (IV)blen_chars) {
2053 DIE(aTHX_ "Offset outside string");
2057 if (length > blen_chars - offset)
2058 length = blen_chars - offset;
2060 /* Here we convert length from characters to bytes. */
2061 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
2062 /* Either we had to convert the SV, or the SV is magical, or
2063 the SV has overloading, in which case we can't or mustn't
2064 or mustn't call it again. */
2066 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
2067 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
2069 /* It's a real UTF-8 SV, and it's not going to change under
2070 us. Take advantage of any cache. */
2072 I32 len_I32 = length;
2074 /* Convert the start and end character positions to bytes.
2075 Remember that the second argument to sv_pos_u2b is relative
2077 sv_pos_u2b(bufsv, &start, &len_I32);
2084 buffer = buffer+offset;
2086 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2087 if (IoTYPE(io) == IoTYPE_SOCKET) {
2088 retval = PerlSock_send(fd, buffer, length, 0);
2093 /* See the note at doio.c:do_print about filesize limits. --jhi */
2094 retval = PerlLIO_write(fd, buffer, length);
2102 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2105 #if Size_t_size > IVSIZE
2125 * in Perl 5.12 and later, the additional parameter is a bitmask:
2128 * 2 = eof() <- ARGV magic
2130 * I'll rely on the compiler's trace flow analysis to decide whether to
2131 * actually assign this out here, or punt it into the only block where it is
2132 * used. Doing it out here is DRY on the condition logic.
2137 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2143 if (PL_op->op_flags & OPf_SPECIAL) {
2144 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2148 gv = PL_last_in_gv; /* eof */
2156 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2157 return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2160 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2161 if (io && !IoIFP(io)) {
2162 if ((IoFLAGS(io) & IOf_START) && av_tindex(GvAVn(gv)) < 0) {
2165 IoFLAGS(io) &= ~IOf_START;
2166 do_open6(gv, "-", 1, NULL, NULL, 0);
2174 *svp = newSVpvs("-");
2176 else if (!nextargv(gv, FALSE))
2181 PUSHs(boolSV(do_eof(gv)));
2191 if (MAXARG != 0 && (TOPs || POPs))
2192 PL_last_in_gv = MUTABLE_GV(POPs);
2199 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2201 return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2206 SETERRNO(EBADF,RMS_IFI);
2211 #if LSEEKSIZE > IVSIZE
2212 PUSHn( do_tell(gv) );
2214 PUSHi( do_tell(gv) );
2220 /* also used for: pp_seek() */
2225 const int whence = POPi;
2226 #if LSEEKSIZE > IVSIZE
2227 const Off_t offset = (Off_t)SvNVx(POPs);
2229 const Off_t offset = (Off_t)SvIVx(POPs);
2232 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2233 IO *const io = GvIO(gv);
2236 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2238 #if LSEEKSIZE > IVSIZE
2239 SV *const offset_sv = newSVnv((NV) offset);
2241 SV *const offset_sv = newSViv(offset);
2244 return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2249 if (PL_op->op_type == OP_SEEK)
2250 PUSHs(boolSV(do_seek(gv, offset, whence)));
2252 const Off_t sought = do_sysseek(gv, offset, whence);
2254 PUSHs(&PL_sv_undef);
2256 SV* const sv = sought ?
2257 #if LSEEKSIZE > IVSIZE
2262 : newSVpvn(zero_but_true, ZBTLEN);
2272 /* There seems to be no consensus on the length type of truncate()
2273 * and ftruncate(), both off_t and size_t have supporters. In
2274 * general one would think that when using large files, off_t is
2275 * at least as wide as size_t, so using an off_t should be okay. */
2276 /* XXX Configure probe for the length type of *truncate() needed XXX */
2279 #if Off_t_size > IVSIZE
2284 /* Checking for length < 0 is problematic as the type might or
2285 * might not be signed: if it is not, clever compilers will moan. */
2286 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2289 SV * const sv = POPs;
2294 if (PL_op->op_flags & OPf_SPECIAL
2295 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2296 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2303 TAINT_PROPER("truncate");
2304 if (!(fp = IoIFP(io))) {
2308 int fd = PerlIO_fileno(fp);
2310 SETERRNO(EBADF,RMS_IFI);
2314 SETERRNO(EINVAL, LIB_INVARG);
2319 if (ftruncate(fd, len) < 0)
2321 if (my_chsize(fd, len) < 0)
2329 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2330 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2331 goto do_ftruncate_io;
2334 const char * const name = SvPV_nomg_const_nolen(sv);
2335 TAINT_PROPER("truncate");
2337 if (truncate(name, len) < 0)
2344 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
2345 mode |= O_LARGEFILE; /* Transparently largefiley. */
2348 /* On open(), the Win32 CRT tries to seek around text
2349 * files using 32-bit offsets, which causes the open()
2350 * to fail on large files, so open in binary mode.
2354 tmpfd = PerlLIO_open(name, mode);
2359 if (my_chsize(tmpfd, len) < 0)
2361 PerlLIO_close(tmpfd);
2370 SETERRNO(EBADF,RMS_IFI);
2376 /* also used for: pp_fcntl() */
2381 SV * const argsv = POPs;
2382 const unsigned int func = POPu;
2384 GV * const gv = MUTABLE_GV(POPs);
2385 IO * const io = GvIOn(gv);
2391 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2395 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2398 s = SvPV_force(argsv, len);
2399 need = IOCPARM_LEN(func);
2401 s = Sv_Grow(argsv, need + 1);
2402 SvCUR_set(argsv, need);
2405 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2408 retval = SvIV(argsv);
2409 s = INT2PTR(char*,retval); /* ouch */
2412 optype = PL_op->op_type;
2413 TAINT_PROPER(PL_op_desc[optype]);
2415 if (optype == OP_IOCTL)
2417 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2419 DIE(aTHX_ "ioctl is not implemented");
2423 DIE(aTHX_ "fcntl is not implemented");
2425 #if defined(OS2) && defined(__EMX__)
2426 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2428 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2432 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2434 if (s[SvCUR(argsv)] != 17)
2435 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2437 s[SvCUR(argsv)] = 0; /* put our null back */
2438 SvSETMAGIC(argsv); /* Assume it has changed */
2447 PUSHp(zero_but_true, ZBTLEN);
2458 const int argtype = POPi;
2459 GV * const gv = MUTABLE_GV(POPs);
2460 IO *const io = GvIO(gv);
2461 PerlIO *const fp = io ? IoIFP(io) : NULL;
2463 /* XXX Looks to me like io is always NULL at this point */
2465 (void)PerlIO_flush(fp);
2466 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2471 SETERRNO(EBADF,RMS_IFI);
2476 DIE(aTHX_ PL_no_func, "flock");
2487 const int protocol = POPi;
2488 const int type = POPi;
2489 const int domain = POPi;
2490 GV * const gv = MUTABLE_GV(POPs);
2491 IO * const io = GvIOn(gv);
2495 do_close(gv, FALSE);
2497 TAINT_PROPER("socket");
2498 fd = PerlSock_socket(domain, type, protocol);
2502 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2503 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2504 IoTYPE(io) = IoTYPE_SOCKET;
2505 if (!IoIFP(io) || !IoOFP(io)) {
2506 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2507 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2508 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2511 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2512 /* ensure close-on-exec */
2513 if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0)
2523 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2526 const int protocol = POPi;
2527 const int type = POPi;
2528 const int domain = POPi;
2530 GV * const gv2 = MUTABLE_GV(POPs);
2531 IO * const io2 = GvIOn(gv2);
2532 GV * const gv1 = MUTABLE_GV(POPs);
2533 IO * const io1 = GvIOn(gv1);
2536 do_close(gv1, FALSE);
2538 do_close(gv2, FALSE);
2540 TAINT_PROPER("socketpair");
2541 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2543 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2544 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2545 IoTYPE(io1) = IoTYPE_SOCKET;
2546 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2547 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2548 IoTYPE(io2) = IoTYPE_SOCKET;
2549 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2550 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2551 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2552 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2553 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2554 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2555 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2558 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2559 /* ensure close-on-exec */
2560 if ((fd[0] > PL_maxsysfd && fcntl(fd[0], F_SETFD, FD_CLOEXEC) < 0) ||
2561 (fd[1] > PL_maxsysfd && fcntl(fd[1], F_SETFD, FD_CLOEXEC) < 0))
2567 DIE(aTHX_ PL_no_sock_func, "socketpair");
2573 /* also used for: pp_connect() */
2578 SV * const addrsv = POPs;
2579 /* OK, so on what platform does bind modify addr? */
2581 GV * const gv = MUTABLE_GV(POPs);
2582 IO * const io = GvIOn(gv);
2589 fd = PerlIO_fileno(IoIFP(io));
2593 addr = SvPV_const(addrsv, len);
2594 op_type = PL_op->op_type;
2595 TAINT_PROPER(PL_op_desc[op_type]);
2596 if ((op_type == OP_BIND
2597 ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
2598 : PerlSock_connect(fd, (struct sockaddr *)addr, len))
2606 SETERRNO(EBADF,SS_IVCHAN);
2613 const int backlog = POPi;
2614 GV * const gv = MUTABLE_GV(POPs);
2615 IO * const io = GvIOn(gv);
2620 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2627 SETERRNO(EBADF,SS_IVCHAN);
2635 char namebuf[MAXPATHLEN];
2636 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2637 Sock_size_t len = sizeof (struct sockaddr_in);
2639 Sock_size_t len = sizeof namebuf;
2641 GV * const ggv = MUTABLE_GV(POPs);
2642 GV * const ngv = MUTABLE_GV(POPs);
2645 IO * const gstio = GvIO(ggv);
2646 if (!gstio || !IoIFP(gstio))
2650 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2653 /* Some platforms indicate zero length when an AF_UNIX client is
2654 * not bound. Simulate a non-zero-length sockaddr structure in
2656 namebuf[0] = 0; /* sun_len */
2657 namebuf[1] = AF_UNIX; /* sun_family */
2665 do_close(ngv, FALSE);
2666 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2667 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2668 IoTYPE(nstio) = IoTYPE_SOCKET;
2669 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2670 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2671 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2672 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2675 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2676 /* ensure close-on-exec */
2677 if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0)
2681 #ifdef __SCO_VERSION__
2682 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2685 PUSHp(namebuf, len);
2689 report_evil_fh(ggv);
2690 SETERRNO(EBADF,SS_IVCHAN);
2700 const int how = POPi;
2701 GV * const gv = MUTABLE_GV(POPs);
2702 IO * const io = GvIOn(gv);
2707 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2712 SETERRNO(EBADF,SS_IVCHAN);
2717 /* also used for: pp_gsockopt() */
2722 const int optype = PL_op->op_type;
2723 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2724 const unsigned int optname = (unsigned int) POPi;
2725 const unsigned int lvl = (unsigned int) POPi;
2726 GV * const gv = MUTABLE_GV(POPs);
2727 IO * const io = GvIOn(gv);
2734 fd = PerlIO_fileno(IoIFP(io));
2740 (void)SvPOK_only(sv);
2744 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2747 /* XXX Configure test: does getsockopt set the length properly? */
2756 #if defined(__SYMBIAN32__)
2757 # define SETSOCKOPT_OPTION_VALUE_T void *
2759 # define SETSOCKOPT_OPTION_VALUE_T const char *
2761 /* XXX TODO: We need to have a proper type (a Configure probe,
2762 * etc.) for what the C headers think of the third argument of
2763 * setsockopt(), the option_value read-only buffer: is it
2764 * a "char *", or a "void *", const or not. Some compilers
2765 * don't take kindly to e.g. assuming that "char *" implicitly
2766 * promotes to a "void *", or to explicitly promoting/demoting
2767 * consts to non/vice versa. The "const void *" is the SUS
2768 * definition, but that does not fly everywhere for the above
2770 SETSOCKOPT_OPTION_VALUE_T buf;
2774 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2778 aint = (int)SvIV(sv);
2779 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2782 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2792 SETERRNO(EBADF,SS_IVCHAN);
2799 /* also used for: pp_getsockname() */
2804 const int optype = PL_op->op_type;
2805 GV * const gv = MUTABLE_GV(POPs);
2806 IO * const io = GvIOn(gv);
2814 sv = sv_2mortal(newSV(257));
2815 (void)SvPOK_only(sv);
2819 fd = PerlIO_fileno(IoIFP(io));
2823 case OP_GETSOCKNAME:
2824 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2827 case OP_GETPEERNAME:
2828 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2830 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2832 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";
2833 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2834 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2835 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2836 sizeof(u_short) + sizeof(struct in_addr))) {
2843 #ifdef BOGUS_GETNAME_RETURN
2844 /* Interactive Unix, getpeername() and getsockname()
2845 does not return valid namelen */
2846 if (len == BOGUS_GETNAME_RETURN)
2847 len = sizeof(struct sockaddr);
2856 SETERRNO(EBADF,SS_IVCHAN);
2865 /* also used for: pp_lstat() */
2876 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2877 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2878 if (PL_op->op_type == OP_LSTAT) {
2879 if (gv != PL_defgv) {
2880 do_fstat_warning_check:
2881 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2882 "lstat() on filehandle%s%"SVf,
2885 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2887 } else if (PL_laststype != OP_LSTAT)
2888 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2889 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2892 if (gv != PL_defgv) {
2896 PL_laststype = OP_STAT;
2897 PL_statgv = gv ? gv : (GV *)io;
2898 sv_setpvs(PL_statname, "");
2904 int fd = PerlIO_fileno(IoIFP(io));
2906 PL_laststatval = -1;
2907 SETERRNO(EBADF,RMS_IFI);
2909 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
2912 } else if (IoDIRP(io)) {
2914 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2917 PL_laststatval = -1;
2920 else PL_laststatval = -1;
2921 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2924 if (PL_laststatval < 0) {
2930 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2931 io = MUTABLE_IO(SvRV(sv));
2932 if (PL_op->op_type == OP_LSTAT)
2933 goto do_fstat_warning_check;
2934 goto do_fstat_have_io;
2937 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2938 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2940 PL_laststype = PL_op->op_type;
2941 file = SvPV_nolen_const(PL_statname);
2942 if (PL_op->op_type == OP_LSTAT)
2943 PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
2945 PL_laststatval = PerlLIO_stat(file, &PL_statcache);
2946 if (PL_laststatval < 0) {
2947 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
2948 /* PL_warn_nl is constant */
2949 GCC_DIAG_IGNORE(-Wformat-nonliteral);
2950 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2958 if (gimme != G_ARRAY) {
2959 if (gimme != G_VOID)
2960 XPUSHs(boolSV(max));
2966 mPUSHi(PL_statcache.st_dev);
2967 #if ST_INO_SIZE > IVSIZE
2968 mPUSHn(PL_statcache.st_ino);
2970 # if ST_INO_SIGN <= 0
2971 mPUSHi(PL_statcache.st_ino);
2973 mPUSHu(PL_statcache.st_ino);
2976 mPUSHu(PL_statcache.st_mode);
2977 mPUSHu(PL_statcache.st_nlink);
2979 sv_setuid(PUSHmortal, PL_statcache.st_uid);
2980 sv_setgid(PUSHmortal, PL_statcache.st_gid);
2982 #ifdef USE_STAT_RDEV
2983 mPUSHi(PL_statcache.st_rdev);
2985 PUSHs(newSVpvs_flags("", SVs_TEMP));
2987 #if Off_t_size > IVSIZE
2988 mPUSHn(PL_statcache.st_size);
2990 mPUSHi(PL_statcache.st_size);
2993 mPUSHn(PL_statcache.st_atime);
2994 mPUSHn(PL_statcache.st_mtime);
2995 mPUSHn(PL_statcache.st_ctime);
2997 mPUSHi(PL_statcache.st_atime);
2998 mPUSHi(PL_statcache.st_mtime);
2999 mPUSHi(PL_statcache.st_ctime);
3001 #ifdef USE_STAT_BLOCKS
3002 mPUSHu(PL_statcache.st_blksize);
3003 mPUSHu(PL_statcache.st_blocks);
3005 PUSHs(newSVpvs_flags("", SVs_TEMP));
3006 PUSHs(newSVpvs_flags("", SVs_TEMP));
3012 /* All filetest ops avoid manipulating the perl stack pointer in their main
3013 bodies (since commit d2c4d2d1e22d3125), and return using either
3014 S_ft_return_false() or S_ft_return_true(). These two helper functions are
3015 the only two which manipulate the perl stack. To ensure that no stack
3016 manipulation macros are used, the filetest ops avoid defining a local copy
3017 of the stack pointer with dSP. */
3019 /* If the next filetest is stacked up with this one
3020 (PL_op->op_private & OPpFT_STACKING), we leave
3021 the original argument on the stack for success,
3022 and skip the stacked operators on failure.
3023 The next few macros/functions take care of this.
3027 S_ft_return_false(pTHX_ SV *ret) {
3031 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
3035 if (PL_op->op_private & OPpFT_STACKING) {
3036 while (OP_IS_FILETEST(next->op_type)
3037 && next->op_private & OPpFT_STACKED)
3038 next = next->op_next;
3043 PERL_STATIC_INLINE OP *
3044 S_ft_return_true(pTHX_ SV *ret) {
3046 if (PL_op->op_flags & OPf_REF)
3047 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
3048 else if (!(PL_op->op_private & OPpFT_STACKING))
3054 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
3055 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
3056 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
3058 #define tryAMAGICftest_MG(chr) STMT_START { \
3059 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
3060 && PL_op->op_flags & OPf_KIDS) { \
3061 OP *next = S_try_amagic_ftest(aTHX_ chr); \
3062 if (next) return next; \
3067 S_try_amagic_ftest(pTHX_ char chr) {
3068 SV *const arg = *PL_stack_sp;
3071 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
3075 const char tmpchr = chr;
3076 SV * const tmpsv = amagic_call(arg,
3077 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
3078 ftest_amg, AMGf_unary);
3083 return SvTRUE(tmpsv)
3084 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
3090 /* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec()
3096 /* Not const, because things tweak this below. Not bool, because there's
3097 no guarantee that OPpFT_ACCESS is <= CHAR_MAX */
3098 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3099 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3100 /* Giving some sort of initial value silences compilers. */
3102 int access_mode = R_OK;
3104 int access_mode = 0;
3107 /* access_mode is never used, but leaving use_access in makes the
3108 conditional compiling below much clearer. */
3111 Mode_t stat_mode = S_IRUSR;
3113 bool effective = FALSE;
3116 switch (PL_op->op_type) {
3117 case OP_FTRREAD: opchar = 'R'; break;
3118 case OP_FTRWRITE: opchar = 'W'; break;
3119 case OP_FTREXEC: opchar = 'X'; break;
3120 case OP_FTEREAD: opchar = 'r'; break;
3121 case OP_FTEWRITE: opchar = 'w'; break;
3122 case OP_FTEEXEC: opchar = 'x'; break;
3124 tryAMAGICftest_MG(opchar);
3126 switch (PL_op->op_type) {
3128 #if !(defined(HAS_ACCESS) && defined(R_OK))
3134 #if defined(HAS_ACCESS) && defined(W_OK)
3139 stat_mode = S_IWUSR;
3143 #if defined(HAS_ACCESS) && defined(X_OK)
3148 stat_mode = S_IXUSR;
3152 #ifdef PERL_EFF_ACCESS
3155 stat_mode = S_IWUSR;
3159 #ifndef PERL_EFF_ACCESS
3166 #ifdef PERL_EFF_ACCESS
3171 stat_mode = S_IXUSR;
3177 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3178 const char *name = SvPV_nolen(*PL_stack_sp);
3180 # ifdef PERL_EFF_ACCESS
3181 result = PERL_EFF_ACCESS(name, access_mode);
3183 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3189 result = access(name, access_mode);
3191 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3202 result = my_stat_flags(0);
3205 if (cando(stat_mode, effective, &PL_statcache))
3211 /* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */
3216 const int op_type = PL_op->op_type;
3220 case OP_FTIS: opchar = 'e'; break;
3221 case OP_FTSIZE: opchar = 's'; break;
3222 case OP_FTMTIME: opchar = 'M'; break;
3223 case OP_FTCTIME: opchar = 'C'; break;
3224 case OP_FTATIME: opchar = 'A'; break;
3226 tryAMAGICftest_MG(opchar);
3228 result = my_stat_flags(0);
3231 if (op_type == OP_FTIS)
3234 /* You can't dTARGET inside OP_FTIS, because you'll get
3235 "panic: pad_sv po" - the op is not flagged to have a target. */
3239 #if Off_t_size > IVSIZE
3240 sv_setnv(TARG, (NV)PL_statcache.st_size);
3242 sv_setiv(TARG, (IV)PL_statcache.st_size);
3247 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3251 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3255 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3259 return SvTRUE_nomg(TARG)
3260 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3265 /* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned()
3266 * pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock()
3267 * pp_ftsuid() pp_ftsvtx() pp_ftzero() */
3274 switch (PL_op->op_type) {
3275 case OP_FTROWNED: opchar = 'O'; break;
3276 case OP_FTEOWNED: opchar = 'o'; break;
3277 case OP_FTZERO: opchar = 'z'; break;
3278 case OP_FTSOCK: opchar = 'S'; break;
3279 case OP_FTCHR: opchar = 'c'; break;
3280 case OP_FTBLK: opchar = 'b'; break;
3281 case OP_FTFILE: opchar = 'f'; break;
3282 case OP_FTDIR: opchar = 'd'; break;
3283 case OP_FTPIPE: opchar = 'p'; break;
3284 case OP_FTSUID: opchar = 'u'; break;
3285 case OP_FTSGID: opchar = 'g'; break;
3286 case OP_FTSVTX: opchar = 'k'; break;
3288 tryAMAGICftest_MG(opchar);
3290 /* I believe that all these three are likely to be defined on most every
3291 system these days. */
3293 if(PL_op->op_type == OP_FTSUID) {
3298 if(PL_op->op_type == OP_FTSGID) {
3303 if(PL_op->op_type == OP_FTSVTX) {
3308 result = my_stat_flags(0);
3311 switch (PL_op->op_type) {
3313 if (PL_statcache.st_uid == PerlProc_getuid())
3317 if (PL_statcache.st_uid == PerlProc_geteuid())
3321 if (PL_statcache.st_size == 0)
3325 if (S_ISSOCK(PL_statcache.st_mode))
3329 if (S_ISCHR(PL_statcache.st_mode))
3333 if (S_ISBLK(PL_statcache.st_mode))
3337 if (S_ISREG(PL_statcache.st_mode))
3341 if (S_ISDIR(PL_statcache.st_mode))
3345 if (S_ISFIFO(PL_statcache.st_mode))
3350 if (PL_statcache.st_mode & S_ISUID)
3356 if (PL_statcache.st_mode & S_ISGID)
3362 if (PL_statcache.st_mode & S_ISVTX)
3374 tryAMAGICftest_MG('l');
3375 result = my_lstat_flags(0);
3379 if (S_ISLNK(PL_statcache.st_mode))
3392 tryAMAGICftest_MG('t');
3394 if (PL_op->op_flags & OPf_REF)
3397 SV *tmpsv = *PL_stack_sp;
3398 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3399 name = SvPV_nomg(tmpsv, namelen);
3400 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3404 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3405 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3406 else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX)
3411 SETERRNO(EBADF,RMS_IFI);
3414 if (PerlLIO_isatty(fd))
3420 /* also used for: pp_ftbinary() */
3434 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3436 if (PL_op->op_flags & OPf_REF)
3438 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3443 gv = MAYBE_DEREF_GV_nomg(sv);
3447 if (gv == PL_defgv) {
3449 io = SvTYPE(PL_statgv) == SVt_PVIO
3453 goto really_filename;
3458 sv_setpvs(PL_statname, "");
3459 io = GvIO(PL_statgv);
3461 PL_laststatval = -1;
3462 PL_laststype = OP_STAT;
3463 if (io && IoIFP(io)) {
3465 if (! PerlIO_has_base(IoIFP(io)))
3466 DIE(aTHX_ "-T and -B not implemented on filehandles");
3467 fd = PerlIO_fileno(IoIFP(io));
3469 SETERRNO(EBADF,RMS_IFI);
3472 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3473 if (PL_laststatval < 0)
3475 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3476 if (PL_op->op_type == OP_FTTEXT)
3481 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3482 i = PerlIO_getc(IoIFP(io));
3484 (void)PerlIO_ungetc(IoIFP(io),i);
3486 /* null file is anything */
3489 len = PerlIO_get_bufsiz(IoIFP(io));
3490 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3491 /* sfio can have large buffers - limit to 512 */
3496 SETERRNO(EBADF,RMS_IFI);
3498 SETERRNO(EBADF,RMS_IFI);
3507 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3509 file = SvPVX_const(PL_statname);
3511 if (!(fp = PerlIO_open(file, "r"))) {
3513 PL_laststatval = -1;
3514 PL_laststype = OP_STAT;
3516 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
3517 /* PL_warn_nl is constant */
3518 GCC_DIAG_IGNORE(-Wformat-nonliteral);
3519 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3524 PL_laststype = OP_STAT;
3525 fd = PerlIO_fileno(fp);
3527 (void)PerlIO_close(fp);
3528 SETERRNO(EBADF,RMS_IFI);
3531 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3532 if (PL_laststatval < 0) {
3534 (void)PerlIO_close(fp);
3538 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3539 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3540 (void)PerlIO_close(fp);
3542 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3543 FT_RETURNNO; /* special case NFS directories */
3544 FT_RETURNYES; /* null file is anything */
3549 /* now scan s to look for textiness */
3551 #if defined(DOSISH) || defined(USEMYBINMODE)
3552 /* ignore trailing ^Z on short files */
3553 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3558 if (! is_invariant_string((U8 *) s, len)) {
3561 /* Here contains a variant under UTF-8 . See if the entire string is
3562 * UTF-8. But the buffer may end in a partial character, so consider
3563 * it UTF-8 if the first non-UTF8 char is an ending partial */
3564 if (is_utf8_string_loc((U8 *) s, len, &ep)
3565 || ep + UTF8SKIP(ep) > (U8 *) (s + len))
3567 if (PL_op->op_type == OP_FTTEXT) {
3576 /* Here, is not UTF-8 or is entirely ASCII. Look through the buffer for
3577 * things that wouldn't be in ASCII text or rich ASCII text. Count these
3579 for (i = 0; i < len; i++, s++) {
3580 if (!*s) { /* null never allowed in text */
3584 #ifdef USE_LOCALE_CTYPE
3585 if (IN_LC_RUNTIME(LC_CTYPE)) {
3586 if ( isPRINT_LC(*s) || isSPACE_LC(*s)) {
3593 /* VT occurs so rarely in text, that we consider it odd */
3594 || (isSPACE_A(*s) && *s != VT_NATIVE)
3596 /* But there is a fair amount of backspaces and escapes in
3599 || *s == ESC_NATIVE)
3606 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3617 const char *tmps = NULL;
3621 SV * const sv = POPs;
3622 if (PL_op->op_flags & OPf_SPECIAL) {
3623 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3625 if (ckWARN(WARN_UNOPENED)) {
3626 Perl_warner(aTHX_ packWARN(WARN_UNOPENED),
3627 "chdir() on unopened filehandle %" SVf, sv);
3629 SETERRNO(EBADF,RMS_IFI);
3631 TAINT_PROPER("chdir");
3635 else if (!(gv = MAYBE_DEREF_GV(sv)))
3636 tmps = SvPV_nomg_const_nolen(sv);
3639 HV * const table = GvHVn(PL_envgv);
3642 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3643 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3645 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3649 tmps = SvPV_nolen_const(*svp);
3653 SETERRNO(EINVAL, LIB_INVARG);
3654 TAINT_PROPER("chdir");
3659 TAINT_PROPER("chdir");
3662 IO* const io = GvIO(gv);
3665 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3666 } else if (IoIFP(io)) {
3667 int fd = PerlIO_fileno(IoIFP(io));
3671 PUSHi(fchdir(fd) >= 0);
3681 DIE(aTHX_ PL_no_func, "fchdir");
3685 PUSHi( PerlDir_chdir(tmps) >= 0 );
3687 /* Clear the DEFAULT element of ENV so we'll get the new value
3689 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3696 SETERRNO(EBADF,RMS_IFI);
3703 /* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */
3707 dSP; dMARK; dTARGET;
3708 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3719 char * const tmps = POPpx;
3720 TAINT_PROPER("chroot");
3721 PUSHi( chroot(tmps) >= 0 );
3724 DIE(aTHX_ PL_no_func, "chroot");
3735 const char * const tmps2 = POPpconstx;
3736 const char * const tmps = SvPV_nolen_const(TOPs);
3737 TAINT_PROPER("rename");
3739 anum = PerlLIO_rename(tmps, tmps2);
3741 if (!(anum = PerlLIO_stat(tmps, &statbuf))) {
3742 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3745 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
3746 (void)UNLINK(tmps2);
3747 if (!(anum = link(tmps, tmps2)))
3748 anum = UNLINK(tmps);
3757 /* also used for: pp_symlink() */
3759 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3763 const int op_type = PL_op->op_type;
3767 if (op_type == OP_LINK)
3768 DIE(aTHX_ PL_no_func, "link");
3770 # ifndef HAS_SYMLINK
3771 if (op_type == OP_SYMLINK)
3772 DIE(aTHX_ PL_no_func, "symlink");
3776 const char * const tmps2 = POPpconstx;
3777 const char * const tmps = SvPV_nolen_const(TOPs);
3778 TAINT_PROPER(PL_op_desc[op_type]);
3780 # if defined(HAS_LINK)
3781 # if defined(HAS_SYMLINK)
3782 /* Both present - need to choose which. */
3783 (op_type == OP_LINK) ?
3784 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3786 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3787 PerlLIO_link(tmps, tmps2);
3790 # if defined(HAS_SYMLINK)
3791 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3792 symlink(tmps, tmps2);
3797 SETi( result >= 0 );
3802 /* also used for: pp_symlink() */
3807 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3817 char buf[MAXPATHLEN];
3822 /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
3823 * it is impossible to know whether the result was truncated. */
3824 len = readlink(tmps, buf, sizeof(buf) - 1);
3833 RETSETUNDEF; /* just pretend it's a normal file */
3837 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3839 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3841 char * const save_filename = filename;
3846 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3848 PERL_ARGS_ASSERT_DOONELINER;
3850 Newx(cmdline, size, char);
3851 my_strlcpy(cmdline, cmd, size);
3852 my_strlcat(cmdline, " ", size);
3853 for (s = cmdline + strlen(cmdline); *filename; ) {
3857 if (s - cmdline < size)
3858 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3859 myfp = PerlProc_popen(cmdline, "r");
3863 SV * const tmpsv = sv_newmortal();
3864 /* Need to save/restore 'PL_rs' ?? */
3865 s = sv_gets(tmpsv, myfp, 0);
3866 (void)PerlProc_pclose(myfp);
3870 #ifdef HAS_SYS_ERRLIST
3875 /* you don't see this */
3876 const char * const errmsg = Strerror(e) ;
3879 if (instr(s, errmsg)) {
3886 #define EACCES EPERM
3888 if (instr(s, "cannot make"))
3889 SETERRNO(EEXIST,RMS_FEX);
3890 else if (instr(s, "existing file"))
3891 SETERRNO(EEXIST,RMS_FEX);
3892 else if (instr(s, "ile exists"))
3893 SETERRNO(EEXIST,RMS_FEX);
3894 else if (instr(s, "non-exist"))
3895 SETERRNO(ENOENT,RMS_FNF);
3896 else if (instr(s, "does not exist"))
3897 SETERRNO(ENOENT,RMS_FNF);
3898 else if (instr(s, "not empty"))
3899 SETERRNO(EBUSY,SS_DEVOFFLINE);
3900 else if (instr(s, "cannot access"))
3901 SETERRNO(EACCES,RMS_PRV);
3903 SETERRNO(EPERM,RMS_PRV);
3906 else { /* some mkdirs return no failure indication */
3908 anum = (PerlLIO_stat(save_filename, &statbuf) >= 0);
3909 if (PL_op->op_type == OP_RMDIR)
3914 SETERRNO(EACCES,RMS_PRV); /* a guess */
3923 /* This macro removes trailing slashes from a directory name.
3924 * Different operating and file systems take differently to
3925 * trailing slashes. According to POSIX 1003.1 1996 Edition
3926 * any number of trailing slashes should be allowed.
3927 * Thusly we snip them away so that even non-conforming
3928 * systems are happy.
3929 * We should probably do this "filtering" for all
3930 * the functions that expect (potentially) directory names:
3931 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3932 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3934 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3935 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3938 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3939 (tmps) = savepvn((tmps), (len)); \
3949 const unsigned int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPu : 0777;
3951 TRIMSLASHES(tmps,len,copy);
3953 TAINT_PROPER("mkdir");
3955 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3959 SETi( dooneliner("mkdir", tmps) );
3960 oldumask = PerlLIO_umask(0);
3961 PerlLIO_umask(oldumask);
3962 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3977 TRIMSLASHES(tmps,len,copy);
3978 TAINT_PROPER("rmdir");
3980 SETi( PerlDir_rmdir(tmps) >= 0 );
3982 SETi( dooneliner("rmdir", tmps) );
3989 /* Directory calls. */
3993 #if defined(Direntry_t) && defined(HAS_READDIR)
3995 const char * const dirname = POPpconstx;
3996 GV * const gv = MUTABLE_GV(POPs);
3997 IO * const io = GvIOn(gv);
3999 if ((IoIFP(io) || IoOFP(io)))
4000 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
4001 "Opening filehandle %"HEKf" also as a directory",
4002 HEKfARG(GvENAME_HEK(gv)) );
4004 PerlDir_close(IoDIRP(io));
4005 if (!(IoDIRP(io) = PerlDir_open(dirname)))
4011 SETERRNO(EBADF,RMS_DIR);
4014 DIE(aTHX_ PL_no_dir_func, "opendir");
4020 #if !defined(Direntry_t) || !defined(HAS_READDIR)
4021 DIE(aTHX_ PL_no_dir_func, "readdir");
4023 #if !defined(I_DIRENT) && !defined(VMS)
4024 Direntry_t *readdir (DIR *);
4029 const U8 gimme = GIMME_V;
4030 GV * const gv = MUTABLE_GV(POPs);
4031 const Direntry_t *dp;
4032 IO * const io = GvIOn(gv);
4035 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4036 "readdir() attempted on invalid dirhandle %"HEKf,
4037 HEKfARG(GvENAME_HEK(gv)));
4042 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
4046 sv = newSVpvn(dp->d_name, dp->d_namlen);
4048 sv = newSVpv(dp->d_name, 0);
4050 if (!(IoFLAGS(io) & IOf_UNTAINT))
4053 } while (gimme == G_ARRAY);
4055 if (!dp && gimme != G_ARRAY)
4062 SETERRNO(EBADF,RMS_ISI);
4063 if (gimme == G_ARRAY)
4072 #if defined(HAS_TELLDIR) || defined(telldir)
4074 /* XXX does _anyone_ need this? --AD 2/20/1998 */
4075 /* XXX netbsd still seemed to.
4076 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
4077 --JHI 1999-Feb-02 */
4078 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
4079 long telldir (DIR *);
4081 GV * const gv = MUTABLE_GV(POPs);
4082 IO * const io = GvIOn(gv);
4085 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4086 "telldir() attempted on invalid dirhandle %"HEKf,
4087 HEKfARG(GvENAME_HEK(gv)));
4091 PUSHi( PerlDir_tell(IoDIRP(io)) );
4095 SETERRNO(EBADF,RMS_ISI);
4098 DIE(aTHX_ PL_no_dir_func, "telldir");
4104 #if defined(HAS_SEEKDIR) || defined(seekdir)
4106 const long along = POPl;
4107 GV * const gv = MUTABLE_GV(POPs);
4108 IO * const io = GvIOn(gv);
4111 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4112 "seekdir() attempted on invalid dirhandle %"HEKf,
4113 HEKfARG(GvENAME_HEK(gv)));
4116 (void)PerlDir_seek(IoDIRP(io), along);
4121 SETERRNO(EBADF,RMS_ISI);
4124 DIE(aTHX_ PL_no_dir_func, "seekdir");
4130 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4132 GV * const gv = MUTABLE_GV(POPs);
4133 IO * const io = GvIOn(gv);
4136 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4137 "rewinddir() attempted on invalid dirhandle %"HEKf,
4138 HEKfARG(GvENAME_HEK(gv)));
4141 (void)PerlDir_rewind(IoDIRP(io));
4145 SETERRNO(EBADF,RMS_ISI);
4148 DIE(aTHX_ PL_no_dir_func, "rewinddir");
4154 #if defined(Direntry_t) && defined(HAS_READDIR)
4156 GV * const gv = MUTABLE_GV(POPs);
4157 IO * const io = GvIOn(gv);
4160 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4161 "closedir() attempted on invalid dirhandle %"HEKf,
4162 HEKfARG(GvENAME_HEK(gv)));
4165 #ifdef VOID_CLOSEDIR
4166 PerlDir_close(IoDIRP(io));
4168 if (PerlDir_close(IoDIRP(io)) < 0) {
4169 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4178 SETERRNO(EBADF,RMS_IFI);
4181 DIE(aTHX_ PL_no_dir_func, "closedir");
4185 /* Process control. */
4192 #ifdef HAS_SIGPROCMASK
4193 sigset_t oldmask, newmask;
4197 PERL_FLUSHALL_FOR_CHILD;
4198 #ifdef HAS_SIGPROCMASK
4199 sigfillset(&newmask);
4200 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4202 childpid = PerlProc_fork();
4203 if (childpid == 0) {
4207 for (sig = 1; sig < SIG_SIZE; sig++)
4208 PL_psig_pend[sig] = 0;
4210 #ifdef HAS_SIGPROCMASK
4213 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4220 #ifdef PERL_USES_PL_PIDSTATUS
4221 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4227 # if (defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)) || defined(__amigaos4__)
4232 PERL_FLUSHALL_FOR_CHILD;
4233 childpid = PerlProc_fork();
4239 DIE(aTHX_ PL_no_func, "fork");
4246 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4251 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4252 childpid = wait4pid(-1, &argflags, 0);
4254 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4259 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4260 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4261 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4263 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4268 DIE(aTHX_ PL_no_func, "wait");
4274 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4276 const int optype = POPi;
4277 const Pid_t pid = TOPi;
4281 result = amigaos_waitpid(aTHX_ optype, pid, &argflags);
4282 STATUS_NATIVE_CHILD_SET((result >= 0) ? argflags : -1);
4283 result = result == 0 ? pid : -1;
4287 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4288 result = wait4pid(pid, &argflags, optype);
4290 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4295 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4296 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4297 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4299 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4301 # endif /* __amigaos4__ */
4305 DIE(aTHX_ PL_no_func, "waitpid");
4311 dSP; dMARK; dORIGMARK; dTARGET;
4312 #if defined(__LIBCATAMOUNT__)
4313 PL_statusvalue = -1;
4318 # ifdef __amigaos4__
4326 while (++MARK <= SP) {
4327 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4332 TAINT_PROPER("system");
4334 PERL_FLUSHALL_FOR_CHILD;
4335 #if (defined(HAS_FORK) || defined(__amigaos4__)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4338 struct UserData userdata;
4345 bool child_success = FALSE;
4346 #ifdef HAS_SIGPROCMASK
4347 sigset_t newset, oldset;
4350 if (PerlProc_pipe(pp) >= 0)
4353 amigaos_fork_set_userdata(aTHX_
4359 pthread_create(&proc,NULL,amigaos_system_child,(void *)&userdata);
4360 child_success = proc > 0;
4362 #ifdef HAS_SIGPROCMASK
4363 sigemptyset(&newset);
4364 sigaddset(&newset, SIGCHLD);
4365 sigprocmask(SIG_BLOCK, &newset, &oldset);
4367 while ((childpid = PerlProc_fork()) == -1) {
4368 if (errno != EAGAIN) {
4373 PerlLIO_close(pp[0]);
4374 PerlLIO_close(pp[1]);
4376 #ifdef HAS_SIGPROCMASK
4377 sigprocmask(SIG_SETMASK, &oldset, NULL);
4383 child_success = childpid > 0;
4385 if (child_success) {
4386 Sigsave_t ihand,qhand; /* place to save signals during system() */
4389 #ifndef __amigaos4__
4391 PerlLIO_close(pp[1]);
4394 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4395 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4398 result = pthread_join(proc, (void **)&status);
4401 result = wait4pid(childpid, &status, 0);
4402 } while (result == -1 && errno == EINTR);
4405 #ifdef HAS_SIGPROCMASK
4406 sigprocmask(SIG_SETMASK, &oldset, NULL);
4408 (void)rsignal_restore(SIGINT, &ihand);
4409 (void)rsignal_restore(SIGQUIT, &qhand);
4411 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4412 do_execfree(); /* free any memory child malloced on fork */
4419 while (n < sizeof(int)) {
4420 n1 = PerlLIO_read(pp[0],
4421 (void*)(((char*)&errkid)+n),
4427 PerlLIO_close(pp[0]);
4428 if (n) { /* Error */
4429 if (n != sizeof(int))
4430 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4431 errno = errkid; /* Propagate errno from kid */
4433 /* The pipe always has something in it
4434 * so n alone is not enough. */
4438 STATUS_NATIVE_CHILD_SET(-1);
4442 XPUSHi(STATUS_CURRENT);
4445 #ifndef __amigaos4__
4446 #ifdef HAS_SIGPROCMASK
4447 sigprocmask(SIG_SETMASK, &oldset, NULL);
4450 PerlLIO_close(pp[0]);
4451 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
4452 if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
4456 if (PL_op->op_flags & OPf_STACKED) {
4457 SV * const really = *++MARK;
4458 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4460 else if (SP - MARK != 1)
4461 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4463 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4465 #endif /* __amigaos4__ */
4468 #else /* ! FORK or VMS or OS/2 */
4471 if (PL_op->op_flags & OPf_STACKED) {
4472 SV * const really = *++MARK;
4473 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4474 value = (I32)do_aspawn(really, MARK, SP);
4476 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4479 else if (SP - MARK != 1) {
4480 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4481 value = (I32)do_aspawn(NULL, MARK, SP);
4483 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4487 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4489 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4491 STATUS_NATIVE_CHILD_SET(value);
4494 XPUSHi(result ? value : STATUS_CURRENT);
4495 #endif /* !FORK or VMS or OS/2 */
4502 dSP; dMARK; dORIGMARK; dTARGET;
4507 while (++MARK <= SP) {
4508 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4513 TAINT_PROPER("exec");
4516 PERL_FLUSHALL_FOR_CHILD;
4517 if (PL_op->op_flags & OPf_STACKED) {
4518 SV * const really = *++MARK;
4519 value = (I32)do_aexec(really, MARK, SP);
4521 else if (SP - MARK != 1)
4523 value = (I32)vms_do_aexec(NULL, MARK, SP);
4525 value = (I32)do_aexec(NULL, MARK, SP);
4529 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4531 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4543 XPUSHi( getppid() );
4546 DIE(aTHX_ PL_no_func, "getppid");
4556 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4559 pgrp = (I32)BSD_GETPGRP(pid);
4561 if (pid != 0 && pid != PerlProc_getpid())
4562 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4568 DIE(aTHX_ PL_no_func, "getpgrp");
4578 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4579 if (MAXARG > 0) pid = TOPs ? TOPi : 0;
4586 TAINT_PROPER("setpgrp");
4588 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4590 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4591 || (pid != 0 && pid != PerlProc_getpid()))
4593 DIE(aTHX_ "setpgrp can't take arguments");
4595 SETi( setpgrp() >= 0 );
4596 #endif /* USE_BSDPGRP */
4599 DIE(aTHX_ PL_no_func, "setpgrp");
4603 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4604 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4606 # define PRIORITY_WHICH_T(which) which
4611 #ifdef HAS_GETPRIORITY
4613 const int who = POPi;
4614 const int which = TOPi;
4615 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4618 DIE(aTHX_ PL_no_func, "getpriority");
4624 #ifdef HAS_SETPRIORITY
4626 const int niceval = POPi;
4627 const int who = POPi;
4628 const int which = TOPi;
4629 TAINT_PROPER("setpriority");
4630 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4633 DIE(aTHX_ PL_no_func, "setpriority");
4637 #undef PRIORITY_WHICH_T
4645 XPUSHn( time(NULL) );
4647 XPUSHi( time(NULL) );
4656 struct tms timesbuf;
4659 (void)PerlProc_times(×buf);
4661 mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
4662 if (GIMME_V == G_ARRAY) {
4663 mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
4664 mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
4665 mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
4673 if (GIMME_V == G_ARRAY) {
4680 DIE(aTHX_ "times not implemented");
4682 #endif /* HAS_TIMES */
4685 /* The 32 bit int year limits the times we can represent to these
4686 boundaries with a few days wiggle room to account for time zone
4689 /* Sat Jan 3 00:00:00 -2147481748 */
4690 #define TIME_LOWER_BOUND -67768100567755200.0
4691 /* Sun Dec 29 12:00:00 2147483647 */
4692 #define TIME_UPPER_BOUND 67767976233316800.0
4695 /* also used for: pp_localtime() */
4703 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4704 static const char * const dayname[] =
4705 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4706 static const char * const monname[] =
4707 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4708 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4710 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4713 when = (Time64_T)now;
4716 NV input = Perl_floor(POPn);
4717 const bool pl_isnan = Perl_isnan(input);
4718 when = (Time64_T)input;
4719 if (UNLIKELY(pl_isnan || when != input)) {
4720 /* diag_listed_as: gmtime(%f) too large */
4721 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4722 "%s(%.0" NVff ") too large", opname, input);
4730 if ( TIME_LOWER_BOUND > when ) {
4731 /* diag_listed_as: gmtime(%f) too small */
4732 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4733 "%s(%.0" NVff ") too small", opname, when);
4736 else if( when > TIME_UPPER_BOUND ) {
4737 /* diag_listed_as: gmtime(%f) too small */
4738 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4739 "%s(%.0" NVff ") too large", opname, when);
4743 if (PL_op->op_type == OP_LOCALTIME)
4744 err = Perl_localtime64_r(&when, &tmbuf);
4746 err = Perl_gmtime64_r(&when, &tmbuf);
4750 /* diag_listed_as: gmtime(%f) failed */
4751 /* XXX %lld broken for quads */
4753 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4754 "%s(%.0" NVff ") failed", opname, when);
4757 if (GIMME_V != G_ARRAY) { /* scalar context */
4764 Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %"IVdf,
4765 dayname[tmbuf.tm_wday],
4766 monname[tmbuf.tm_mon],
4771 (IV)tmbuf.tm_year + 1900);
4774 else { /* list context */
4780 mPUSHi(tmbuf.tm_sec);
4781 mPUSHi(tmbuf.tm_min);
4782 mPUSHi(tmbuf.tm_hour);
4783 mPUSHi(tmbuf.tm_mday);
4784 mPUSHi(tmbuf.tm_mon);
4785 mPUSHn(tmbuf.tm_year);
4786 mPUSHi(tmbuf.tm_wday);
4787 mPUSHi(tmbuf.tm_yday);
4788 mPUSHi(tmbuf.tm_isdst);
4797 /* alarm() takes an unsigned int number of seconds, and return the
4798 * unsigned int number of seconds remaining in the previous alarm
4799 * (alarms don't stack). Therefore negative return values are not
4803 /* Note that while the C library function alarm() as such has
4804 * no errors defined (or in other words, properly behaving client
4805 * code shouldn't expect any), alarm() being obsoleted by
4806 * setitimer() and often being implemented in terms of
4807 * setitimer(), can fail. */
4808 /* diag_listed_as: %s() with negative argument */
4809 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4810 "alarm() with negative argument");
4811 SETERRNO(EINVAL, LIB_INVARG);
4815 unsigned int retval = alarm(anum);
4816 if ((int)retval < 0) /* Strictly speaking "cannot happen". */
4822 DIE(aTHX_ PL_no_func, "alarm");
4833 (void)time(&lasttime);
4834 if (MAXARG < 1 || (!TOPs && !POPs))
4839 /* diag_listed_as: %s() with negative argument */
4840 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4841 "sleep() with negative argument");
4842 SETERRNO(EINVAL, LIB_INVARG);
4846 PerlProc_sleep((unsigned int)duration);
4850 XPUSHi(when - lasttime);
4854 /* Shared memory. */
4855 /* Merged with some message passing. */
4857 /* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */
4861 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4862 dSP; dMARK; dTARGET;
4863 const int op_type = PL_op->op_type;
4868 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4871 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4874 value = (I32)(do_semop(MARK, SP) >= 0);
4877 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4885 return Perl_pp_semget(aTHX);
4891 /* also used for: pp_msgget() pp_shmget() */
4895 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4896 dSP; dMARK; dTARGET;
4897 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4904 DIE(aTHX_ "System V IPC is not implemented on this machine");
4908 /* also used for: pp_msgctl() pp_shmctl() */
4912 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4913 dSP; dMARK; dTARGET;
4914 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4922 PUSHp(zero_but_true, ZBTLEN);
4926 return Perl_pp_semget(aTHX);
4930 /* I can't const this further without getting warnings about the types of
4931 various arrays passed in from structures. */
4933 S_space_join_names_mortal(pTHX_ char *const *array)
4937 if (array && *array) {
4938 target = newSVpvs_flags("", SVs_TEMP);
4940 sv_catpv(target, *array);
4943 sv_catpvs(target, " ");
4946 target = sv_mortalcopy(&PL_sv_no);
4951 /* Get system info. */
4953 /* also used for: pp_ghbyaddr() pp_ghbyname() */
4957 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4959 I32 which = PL_op->op_type;
4962 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4963 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4964 struct hostent *gethostbyname(Netdb_name_t);
4965 struct hostent *gethostent(void);
4967 struct hostent *hent = NULL;
4971 if (which == OP_GHBYNAME) {
4972 #ifdef HAS_GETHOSTBYNAME
4973 const char* const name = POPpbytex;
4974 hent = PerlSock_gethostbyname(name);
4976 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4979 else if (which == OP_GHBYADDR) {
4980 #ifdef HAS_GETHOSTBYADDR
4981 const int addrtype = POPi;
4982 SV * const addrsv = POPs;
4984 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4986 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4988 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4992 #ifdef HAS_GETHOSTENT
4993 hent = PerlSock_gethostent();
4995 DIE(aTHX_ PL_no_sock_func, "gethostent");
4998 #ifdef HOST_NOT_FOUND
5000 #ifdef USE_REENTRANT_API
5001 # ifdef USE_GETHOSTENT_ERRNO
5002 h_errno = PL_reentrant_buffer->_gethostent_errno;
5005 STATUS_UNIX_SET(h_errno);
5009 if (GIMME_V != G_ARRAY) {
5010 PUSHs(sv = sv_newmortal());
5012 if (which == OP_GHBYNAME) {
5014 sv_setpvn(sv, hent->h_addr, hent->h_length);
5017 sv_setpv(sv, (char*)hent->h_name);
5023 mPUSHs(newSVpv((char*)hent->h_name, 0));
5024 PUSHs(space_join_names_mortal(hent->h_aliases));
5025 mPUSHi(hent->h_addrtype);
5026 len = hent->h_length;
5029 for (elem = hent->h_addr_list; elem && *elem; elem++) {
5030 mXPUSHp(*elem, len);
5034 mPUSHp(hent->h_addr, len);
5036 PUSHs(sv_mortalcopy(&PL_sv_no));
5041 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5045 /* also used for: pp_gnbyaddr() pp_gnbyname() */
5049 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
5051 I32 which = PL_op->op_type;
5053 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
5054 struct netent *getnetbyaddr(Netdb_net_t, int);
5055 struct netent *getnetbyname(Netdb_name_t);
5056 struct netent *getnetent(void);
5058 struct netent *nent;
5060 if (which == OP_GNBYNAME){
5061 #ifdef HAS_GETNETBYNAME
5062 const char * const name = POPpbytex;
5063 nent = PerlSock_getnetbyname(name);
5065 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
5068 else if (which == OP_GNBYADDR) {
5069 #ifdef HAS_GETNETBYADDR
5070 const int addrtype = POPi;
5071 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
5072 nent = PerlSock_getnetbyaddr(addr, addrtype);
5074 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
5078 #ifdef HAS_GETNETENT
5079 nent = PerlSock_getnetent();
5081 DIE(aTHX_ PL_no_sock_func, "getnetent");
5084 #ifdef HOST_NOT_FOUND
5086 #ifdef USE_REENTRANT_API
5087 # ifdef USE_GETNETENT_ERRNO
5088 h_errno = PL_reentrant_buffer->_getnetent_errno;
5091 STATUS_UNIX_SET(h_errno);
5096 if (GIMME_V != G_ARRAY) {
5097 PUSHs(sv = sv_newmortal());
5099 if (which == OP_GNBYNAME)
5100 sv_setiv(sv, (IV)nent->n_net);
5102 sv_setpv(sv, nent->n_name);
5108 mPUSHs(newSVpv(nent->n_name, 0));
5109 PUSHs(space_join_names_mortal(nent->n_aliases));
5110 mPUSHi(nent->n_addrtype);
5111 mPUSHi(nent->n_net);
5116 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5121 /* also used for: pp_gpbyname() pp_gpbynumber() */
5125 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
5127 I32 which = PL_op->op_type;
5129 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
5130 struct protoent *getprotobyname(Netdb_name_t);
5131 struct protoent *getprotobynumber(int);
5132 struct protoent *getprotoent(void);
5134 struct protoent *pent;
5136 if (which == OP_GPBYNAME) {
5137 #ifdef HAS_GETPROTOBYNAME
5138 const char* const name = POPpbytex;
5139 pent = PerlSock_getprotobyname(name);
5141 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
5144 else if (which == OP_GPBYNUMBER) {
5145 #ifdef HAS_GETPROTOBYNUMBER
5146 const int number = POPi;
5147 pent = PerlSock_getprotobynumber(number);
5149 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
5153 #ifdef HAS_GETPROTOENT
5154 pent = PerlSock_getprotoent();
5156 DIE(aTHX_ PL_no_sock_func, "getprotoent");
5160 if (GIMME_V != G_ARRAY) {
5161 PUSHs(sv = sv_newmortal());
5163 if (which == OP_GPBYNAME)
5164 sv_setiv(sv, (IV)pent->p_proto);
5166 sv_setpv(sv, pent->p_name);
5172 mPUSHs(newSVpv(pent->p_name, 0));
5173 PUSHs(space_join_names_mortal(pent->p_aliases));
5174 mPUSHi(pent->p_proto);
5179 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5184 /* also used for: pp_gsbyname() pp_gsbyport() */
5188 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
5190 I32 which = PL_op->op_type;
5192 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
5193 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
5194 struct servent *getservbyport(int, Netdb_name_t);
5195 struct servent *getservent(void);
5197 struct servent *sent;
5199 if (which == OP_GSBYNAME) {
5200 #ifdef HAS_GETSERVBYNAME
5201 const char * const proto = POPpbytex;
5202 const char * const name = POPpbytex;
5203 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5205 DIE(aTHX_ PL_no_sock_func, "getservbyname");
5208 else if (which == OP_GSBYPORT) {
5209 #ifdef HAS_GETSERVBYPORT
5210 const char * const proto = POPpbytex;
5211 unsigned short port = (unsigned short)POPu;
5212 port = PerlSock_htons(port);
5213 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5215 DIE(aTHX_ PL_no_sock_func, "getservbyport");
5219 #ifdef HAS_GETSERVENT
5220 sent = PerlSock_getservent();
5222 DIE(aTHX_ PL_no_sock_func, "getservent");
5226 if (GIMME_V != G_ARRAY) {
5227 PUSHs(sv = sv_newmortal());
5229 if (which == OP_GSBYNAME) {
5230 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5233 sv_setpv(sv, sent->s_name);
5239 mPUSHs(newSVpv(sent->s_name, 0));
5240 PUSHs(space_join_names_mortal(sent->s_aliases));
5241 mPUSHi(PerlSock_ntohs(sent->s_port));
5242 mPUSHs(newSVpv(sent->s_proto, 0));
5247 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5252 /* also used for: pp_snetent() pp_sprotoent() pp_sservent() */
5257 const int stayopen = TOPi;
5258 switch(PL_op->op_type) {
5260 #ifdef HAS_SETHOSTENT
5261 PerlSock_sethostent(stayopen);
5263 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5266 #ifdef HAS_SETNETENT
5268 PerlSock_setnetent(stayopen);
5270 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5274 #ifdef HAS_SETPROTOENT
5275 PerlSock_setprotoent(stayopen);
5277 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5281 #ifdef HAS_SETSERVENT
5282 PerlSock_setservent(stayopen);
5284 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5292 /* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent()
5293 * pp_eservent() pp_sgrent() pp_spwent() */
5298 switch(PL_op->op_type) {
5300 #ifdef HAS_ENDHOSTENT
5301 PerlSock_endhostent();
5303 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5307 #ifdef HAS_ENDNETENT
5308 PerlSock_endnetent();
5310 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5314 #ifdef HAS_ENDPROTOENT
5315 PerlSock_endprotoent();
5317 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5321 #ifdef HAS_ENDSERVENT
5322 PerlSock_endservent();
5324 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5328 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5331 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5335 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5338 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5342 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5345 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5349 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5352 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5361 /* also used for: pp_gpwnam() pp_gpwuid() */
5367 I32 which = PL_op->op_type;
5369 struct passwd *pwent = NULL;
5371 * We currently support only the SysV getsp* shadow password interface.
5372 * The interface is declared in <shadow.h> and often one needs to link
5373 * with -lsecurity or some such.
5374 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5377 * AIX getpwnam() is clever enough to return the encrypted password
5378 * only if the caller (euid?) is root.
5380 * There are at least three other shadow password APIs. Many platforms
5381 * seem to contain more than one interface for accessing the shadow
5382 * password databases, possibly for compatibility reasons.
5383 * The getsp*() is by far he simplest one, the other two interfaces
5384 * are much more complicated, but also very similar to each other.
5389 * struct pr_passwd *getprpw*();
5390 * The password is in
5391 * char getprpw*(...).ufld.fd_encrypt[]
5392 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5397 * struct es_passwd *getespw*();
5398 * The password is in
5399 * char *(getespw*(...).ufld.fd_encrypt)
5400 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5403 * struct userpw *getuserpw();
5404 * The password is in
5405 * char *(getuserpw(...)).spw_upw_passwd
5406 * (but the de facto standard getpwnam() should work okay)
5408 * Mention I_PROT here so that Configure probes for it.
5410 * In HP-UX for getprpw*() the manual page claims that one should include
5411 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5412 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5413 * and pp_sys.c already includes <shadow.h> if there is such.
5415 * Note that <sys/security.h> is already probed for, but currently
5416 * it is only included in special cases.
5418 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5419 * be preferred interface, even though also the getprpw*() interface
5420 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5421 * One also needs to call set_auth_parameters() in main() before
5422 * doing anything else, whether one is using getespw*() or getprpw*().
5424 * Note that accessing the shadow databases can be magnitudes
5425 * slower than accessing the standard databases.
5430 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5431 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5432 * the pw_comment is left uninitialized. */
5433 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5439 const char* const name = POPpbytex;
5440 pwent = getpwnam(name);
5446 pwent = getpwuid(uid);
5450 # ifdef HAS_GETPWENT
5452 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5453 if (pwent) pwent = getpwnam(pwent->pw_name);
5456 DIE(aTHX_ PL_no_func, "getpwent");
5462 if (GIMME_V != G_ARRAY) {
5463 PUSHs(sv = sv_newmortal());
5465 if (which == OP_GPWNAM)
5466 sv_setuid(sv, pwent->pw_uid);
5468 sv_setpv(sv, pwent->pw_name);
5474 mPUSHs(newSVpv(pwent->pw_name, 0));
5478 /* If we have getspnam(), we try to dig up the shadow
5479 * password. If we are underprivileged, the shadow
5480 * interface will set the errno to EACCES or similar,
5481 * and return a null pointer. If this happens, we will
5482 * use the dummy password (usually "*" or "x") from the
5483 * standard password database.
5485 * In theory we could skip the shadow call completely
5486 * if euid != 0 but in practice we cannot know which
5487 * security measures are guarding the shadow databases
5488 * on a random platform.
5490 * Resist the urge to use additional shadow interfaces.
5491 * Divert the urge to writing an extension instead.
5494 /* Some AIX setups falsely(?) detect some getspnam(), which
5495 * has a different API than the Solaris/IRIX one. */
5496 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5499 const struct spwd * const spwent = getspnam(pwent->pw_name);
5500 /* Save and restore errno so that
5501 * underprivileged attempts seem
5502 * to have never made the unsuccessful
5503 * attempt to retrieve the shadow password. */
5505 if (spwent && spwent->sp_pwdp)
5506 sv_setpv(sv, spwent->sp_pwdp);
5510 if (!SvPOK(sv)) /* Use the standard password, then. */
5511 sv_setpv(sv, pwent->pw_passwd);
5514 /* passwd is tainted because user himself can diddle with it.
5515 * admittedly not much and in a very limited way, but nevertheless. */
5518 sv_setuid(PUSHmortal, pwent->pw_uid);
5519 sv_setgid(PUSHmortal, pwent->pw_gid);
5521 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5522 * because of the poor interface of the Perl getpw*(),
5523 * not because there's some standard/convention saying so.
5524 * A better interface would have been to return a hash,
5525 * but we are accursed by our history, alas. --jhi. */
5527 mPUSHi(pwent->pw_change);
5530 mPUSHi(pwent->pw_quota);
5533 mPUSHs(newSVpv(pwent->pw_age, 0));
5535 /* I think that you can never get this compiled, but just in case. */
5536 PUSHs(sv_mortalcopy(&PL_sv_no));
5541 /* pw_class and pw_comment are mutually exclusive--.
5542 * see the above note for pw_change, pw_quota, and pw_age. */
5544 mPUSHs(newSVpv(pwent->pw_class, 0));
5547 mPUSHs(newSVpv(pwent->pw_comment, 0));
5549 /* I think that you can never get this compiled, but just in case. */
5550 PUSHs(sv_mortalcopy(&PL_sv_no));
5555 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5557 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5559 /* pw_gecos is tainted because user himself can diddle with it. */
5562 mPUSHs(newSVpv(pwent->pw_dir, 0));
5564 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5565 /* pw_shell is tainted because user himself can diddle with it. */
5569 mPUSHi(pwent->pw_expire);
5574 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5579 /* also used for: pp_ggrgid() pp_ggrnam() */
5585 const I32 which = PL_op->op_type;
5586 const struct group *grent;
5588 if (which == OP_GGRNAM) {
5589 const char* const name = POPpbytex;
5590 grent = (const struct group *)getgrnam(name);
5592 else if (which == OP_GGRGID) {
5594 const Gid_t gid = POPu;
5595 #elif Gid_t_sign == -1
5596 const Gid_t gid = POPi;
5598 # error "Unexpected Gid_t_sign"
5600 grent = (const struct group *)getgrgid(gid);
5604 grent = (struct group *)getgrent();
5606 DIE(aTHX_ PL_no_func, "getgrent");
5610 if (GIMME_V != G_ARRAY) {
5611 SV * const sv = sv_newmortal();
5615 if (which == OP_GGRNAM)
5616 sv_setgid(sv, grent->gr_gid);
5618 sv_setpv(sv, grent->gr_name);
5624 mPUSHs(newSVpv(grent->gr_name, 0));
5627 mPUSHs(newSVpv(grent->gr_passwd, 0));
5629 PUSHs(sv_mortalcopy(&PL_sv_no));
5632 sv_setgid(PUSHmortal, grent->gr_gid);
5634 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5635 /* In UNICOS/mk (_CRAYMPP) the multithreading
5636 * versions (getgrnam_r, getgrgid_r)
5637 * seem to return an illegal pointer
5638 * as the group members list, gr_mem.
5639 * getgrent() doesn't even have a _r version
5640 * but the gr_mem is poisonous anyway.
5641 * So yes, you cannot get the list of group
5642 * members if building multithreaded in UNICOS/mk. */
5643 PUSHs(space_join_names_mortal(grent->gr_mem));
5649 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5659 if (!(tmps = PerlProc_getlogin()))
5661 sv_setpv_mg(TARG, tmps);
5665 DIE(aTHX_ PL_no_func, "getlogin");
5669 /* Miscellaneous. */
5674 dSP; dMARK; dORIGMARK; dTARGET;
5675 I32 items = SP - MARK;
5676 unsigned long a[20];
5681 while (++MARK <= SP) {
5682 if (SvTAINTED(*MARK)) {
5688 TAINT_PROPER("syscall");
5691 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5692 * or where sizeof(long) != sizeof(char*). But such machines will
5693 * not likely have syscall implemented either, so who cares?
5695 while (++MARK <= SP) {
5696 if (SvNIOK(*MARK) || !i)
5697 a[i++] = SvIV(*MARK);
5698 else if (*MARK == &PL_sv_undef)
5701 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5707 DIE(aTHX_ "Too many args to syscall");
5709 DIE(aTHX_ "Too few args to syscall");
5711 retval = syscall(a[0]);
5714 retval = syscall(a[0],a[1]);
5717 retval = syscall(a[0],a[1],a[2]);
5720 retval = syscall(a[0],a[1],a[2],a[3]);
5723 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5726 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5729 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5732 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5739 DIE(aTHX_ PL_no_func, "syscall");
5743 #ifdef FCNTL_EMULATE_FLOCK
5745 /* XXX Emulate flock() with fcntl().
5746 What's really needed is a good file locking module.
5750 fcntl_emulate_flock(int fd, int operation)
5755 switch (operation & ~LOCK_NB) {
5757 flock.l_type = F_RDLCK;
5760 flock.l_type = F_WRLCK;
5763 flock.l_type = F_UNLCK;
5769 flock.l_whence = SEEK_SET;
5770 flock.l_start = flock.l_len = (Off_t)0;
5772 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5773 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5774 errno = EWOULDBLOCK;
5778 #endif /* FCNTL_EMULATE_FLOCK */
5780 #ifdef LOCKF_EMULATE_FLOCK
5782 /* XXX Emulate flock() with lockf(). This is just to increase
5783 portability of scripts. The calls are not completely
5784 interchangeable. What's really needed is a good file
5788 /* The lockf() constants might have been defined in <unistd.h>.
5789 Unfortunately, <unistd.h> causes troubles on some mixed
5790 (BSD/POSIX) systems, such as SunOS 4.1.3.
5792 Further, the lockf() constants aren't POSIX, so they might not be
5793 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5794 just stick in the SVID values and be done with it. Sigh.
5798 # define F_ULOCK 0 /* Unlock a previously locked region */
5801 # define F_LOCK 1 /* Lock a region for exclusive use */
5804 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5807 # define F_TEST 3 /* Test a region for other processes locks */
5811 lockf_emulate_flock(int fd, int operation)
5817 /* flock locks entire file so for lockf we need to do the same */
5818 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5819 if (pos > 0) /* is seekable and needs to be repositioned */
5820 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5821 pos = -1; /* seek failed, so don't seek back afterwards */
5824 switch (operation) {
5826 /* LOCK_SH - get a shared lock */
5828 /* LOCK_EX - get an exclusive lock */
5830 i = lockf (fd, F_LOCK, 0);
5833 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5834 case LOCK_SH|LOCK_NB:
5835 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5836 case LOCK_EX|LOCK_NB:
5837 i = lockf (fd, F_TLOCK, 0);
5839 if ((errno == EAGAIN) || (errno == EACCES))
5840 errno = EWOULDBLOCK;
5843 /* LOCK_UN - unlock (non-blocking is a no-op) */
5845 case LOCK_UN|LOCK_NB:
5846 i = lockf (fd, F_ULOCK, 0);
5849 /* Default - can't decipher operation */
5856 if (pos > 0) /* need to restore position of the handle */
5857 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5862 #endif /* LOCKF_EMULATE_FLOCK */
5865 * ex: set ts=8 sts=4 sw=4 et: