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 SvPVCLEAR(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);
956 SV *stashname = SvOK(*MARK) ? *MARK : &PL_sv_no;
958 stashname = sv_2mortal(newSVpvs("main"));
960 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\""
961 " (perhaps you forgot to load \"%" SVf "\"?)",
962 methname, SVfARG(stashname), SVfARG(stashname));
964 else if (!(gv = gv_fetchmethod(stash, methname))) {
965 /* The effective name can only be NULL for stashes that have
966 * been deleted from the symbol table, which this one can't
967 * be, since we just looked it up by name.
969 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" HEKf "\"",
970 methname, HvENAME_HEK_NN(stash));
972 ENTER_with_name("call_TIE");
973 PUSHSTACKi(PERLSI_MAGIC);
975 EXTEND(SP,(I32)items);
979 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
985 if (sv_isobject(sv)) {
986 sv_unmagic(varsv, how);
987 /* Croak if a self-tie on an aggregate is attempted. */
988 if (varsv == SvRV(sv) &&
989 (SvTYPE(varsv) == SVt_PVAV ||
990 SvTYPE(varsv) == SVt_PVHV))
992 "Self-ties of arrays and hashes are not supported");
993 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
995 LEAVE_with_name("call_TIE");
996 SP = PL_stack_base + markoff;
1002 /* also used for: pp_dbmclose() */
1009 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1010 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1012 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1015 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1016 !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
1018 if ((mg = SvTIED_mg(sv, how))) {
1019 SV * const obj = SvRV(SvTIED_obj(sv, mg));
1021 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
1023 if (gv && isGV(gv) && (cv = GvCV(gv))) {
1025 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
1026 mXPUSHi(SvREFCNT(obj) - 1);
1028 ENTER_with_name("call_UNTIE");
1029 call_sv(MUTABLE_SV(cv), G_VOID);
1030 LEAVE_with_name("call_UNTIE");
1033 else if (mg && SvREFCNT(obj) > 1) {
1034 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
1035 "untie attempted while %" UVuf " inner references still exist",
1036 (UV)SvREFCNT(obj) - 1 ) ;
1040 sv_unmagic(sv, how) ;
1049 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1050 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1052 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1055 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1056 !(sv = defelem_target(sv, NULL))) goto ret_undef;
1058 if ((mg = SvTIED_mg(sv, how))) {
1059 SETs(SvTIED_obj(sv, mg));
1060 return NORMAL; /* PUTBACK not needed, pp_tied never moves SP */
1074 HV * const hv = MUTABLE_HV(POPs);
1075 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1076 stash = gv_stashsv(sv, 0);
1077 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1079 require_pv("AnyDBM_File.pm");
1081 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1082 DIE(aTHX_ "No dbm on this machine");
1092 mPUSHu(O_RDWR|O_CREAT);
1096 if (!SvOK(right)) right = &PL_sv_no;
1100 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1103 if (!sv_isobject(TOPs)) {
1111 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1113 if (sv_isobject(TOPs))
1118 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1119 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1136 struct timeval timebuf;
1137 struct timeval *tbuf = &timebuf;
1140 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1145 # if BYTEORDER & 0xf0000
1146 # define ORDERBYTE (0x88888888 - BYTEORDER)
1148 # define ORDERBYTE (0x4444 - BYTEORDER)
1154 for (i = 1; i <= 3; i++) {
1155 SV * const sv = SP[i];
1159 if (SvREADONLY(sv)) {
1160 if (!(SvPOK(sv) && SvCUR(sv) == 0))
1161 Perl_croak_no_modify();
1163 else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
1166 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1167 "Non-string passed as bitmask");
1168 SvPV_force_nomg_nolen(sv); /* force string conversion */
1175 /* little endians can use vecs directly */
1176 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1183 masksize = NFDBITS / NBBY;
1185 masksize = sizeof(long); /* documented int, everyone seems to use long */
1187 Zero(&fd_sets[0], 4, char*);
1190 # if SELECT_MIN_BITS == 1
1191 growsize = sizeof(fd_set);
1193 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1194 # undef SELECT_MIN_BITS
1195 # define SELECT_MIN_BITS __FD_SETSIZE
1197 /* If SELECT_MIN_BITS is greater than one we most probably will want
1198 * to align the sizes with SELECT_MIN_BITS/8 because for example
1199 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1200 * UNIX, Solaris, Darwin) the smallest quantum select() operates
1201 * on (sets/tests/clears bits) is 32 bits. */
1202 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1208 value = SvNV_nomg(sv);
1211 timebuf.tv_sec = (long)value;
1212 value -= (NV)timebuf.tv_sec;
1213 timebuf.tv_usec = (long)(value * 1000000.0);
1218 for (i = 1; i <= 3; i++) {
1220 if (!SvOK(sv) || SvCUR(sv) == 0) {
1227 Sv_Grow(sv, growsize);
1231 while (++j <= growsize) {
1235 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1237 Newx(fd_sets[i], growsize, char);
1238 for (offset = 0; offset < growsize; offset += masksize) {
1239 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1240 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1243 fd_sets[i] = SvPVX(sv);
1247 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1248 /* Can't make just the (void*) conditional because that would be
1249 * cpp #if within cpp macro, and not all compilers like that. */
1250 nfound = PerlSock_select(
1252 (Select_fd_set_t) fd_sets[1],
1253 (Select_fd_set_t) fd_sets[2],
1254 (Select_fd_set_t) fd_sets[3],
1255 (void*) tbuf); /* Workaround for compiler bug. */
1257 nfound = PerlSock_select(
1259 (Select_fd_set_t) fd_sets[1],
1260 (Select_fd_set_t) fd_sets[2],
1261 (Select_fd_set_t) fd_sets[3],
1264 for (i = 1; i <= 3; i++) {
1267 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1269 for (offset = 0; offset < growsize; offset += masksize) {
1270 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1271 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1273 Safefree(fd_sets[i]);
1280 if (GIMME_V == G_ARRAY && tbuf) {
1281 value = (NV)(timebuf.tv_sec) +
1282 (NV)(timebuf.tv_usec) / 1000000.0;
1287 DIE(aTHX_ "select not implemented");
1295 =for apidoc setdefout
1297 Sets C<PL_defoutgv>, the default file handle for output, to the passed in
1298 typeglob. As C<PL_defoutgv> "owns" a reference on its typeglob, the reference
1299 count of the passed in typeglob is increased by one, and the reference count
1300 of the typeglob that C<PL_defoutgv> points to is decreased by one.
1306 Perl_setdefout(pTHX_ GV *gv)
1308 GV *oldgv = PL_defoutgv;
1310 PERL_ARGS_ASSERT_SETDEFOUT;
1312 SvREFCNT_inc_simple_void_NN(gv);
1314 SvREFCNT_dec(oldgv);
1321 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1322 GV * egv = GvEGVx(PL_defoutgv);
1327 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1328 gvp = hv && HvENAME(hv)
1329 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1331 if (gvp && *gvp == egv) {
1332 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1336 mXPUSHs(newRV(MUTABLE_SV(egv)));
1340 if (!GvIO(newdefout))
1341 gv_IOadd(newdefout);
1342 setdefout(newdefout);
1352 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1353 IO *const io = GvIO(gv);
1359 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1361 const U8 gimme = GIMME_V;
1362 Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1363 if (gimme == G_SCALAR) {
1365 SvSetMagicSV_nosteal(TARG, TOPs);
1370 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1371 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1373 SETERRNO(EBADF,RMS_IFI);
1377 sv_setpvs(TARG, " ");
1378 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1379 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1380 /* Find out how many bytes the char needs */
1381 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1384 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1385 SvCUR_set(TARG,1+len);
1389 else SvUTF8_off(TARG);
1395 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1398 const U8 gimme = GIMME_V;
1400 PERL_ARGS_ASSERT_DOFORM;
1403 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1405 cx = cx_pushblock(CXt_FORMAT, gimme, PL_stack_sp, PL_savestack_ix);
1406 cx_pushformat(cx, cv, retop, gv);
1407 if (CvDEPTH(cv) >= 2)
1408 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1409 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1411 setdefout(gv); /* locally select filehandle so $% et al work */
1429 gv = MUTABLE_GV(POPs);
1446 tmpsv = sv_newmortal();
1447 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1448 DIE(aTHX_ "Undefined format \"%" SVf "\" called", SVfARG(tmpsv));
1450 IoFLAGS(io) &= ~IOf_DIDTOP;
1451 RETURNOP(doform(cv,gv,PL_op->op_next));
1457 GV * const gv = CX_CUR()->blk_format.gv;
1458 IO * const io = GvIOp(gv);
1463 bool is_return = cBOOL(PL_op->op_type == OP_RETURN);
1465 if (is_return || !io || !(ofp = IoOFP(io)))
1468 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1469 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1471 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1472 PL_formtarget != PL_toptarget)
1476 if (!IoTOP_GV(io)) {
1479 if (!IoTOP_NAME(io)) {
1481 if (!IoFMT_NAME(io))
1482 IoFMT_NAME(io) = savepv(GvNAME(gv));
1483 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%" HEKf "_TOP",
1484 HEKfARG(GvNAME_HEK(gv))));
1485 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1486 if ((topgv && GvFORM(topgv)) ||
1487 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1488 IoTOP_NAME(io) = savesvpv(topname);
1490 IoTOP_NAME(io) = savepvs("top");
1492 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1493 if (!topgv || !GvFORM(topgv)) {
1494 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1497 IoTOP_GV(io) = topgv;
1499 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1500 I32 lines = IoLINES_LEFT(io);
1501 const char *s = SvPVX_const(PL_formtarget);
1502 if (lines <= 0) /* Yow, header didn't even fit!!! */
1504 while (lines-- > 0) {
1505 s = strchr(s, '\n');
1511 const STRLEN save = SvCUR(PL_formtarget);
1512 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1513 do_print(PL_formtarget, ofp);
1514 SvCUR_set(PL_formtarget, save);
1515 sv_chop(PL_formtarget, s);
1516 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1519 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1520 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1521 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1523 PL_formtarget = PL_toptarget;
1524 IoFLAGS(io) |= IOf_DIDTOP;
1526 assert(fgv); /* IoTOP_GV(io) should have been set above */
1529 SV * const sv = sv_newmortal();
1530 gv_efullname4(sv, fgv, NULL, FALSE);
1531 DIE(aTHX_ "Undefined top format \"%" SVf "\" called", SVfARG(sv));
1533 return doform(cv, gv, PL_op);
1538 assert(CxTYPE(cx) == CXt_FORMAT);
1539 SP = PL_stack_base + cx->blk_oldsp; /* ignore retval of formline */
1543 retop = cx->blk_sub.retop;
1547 /* XXX the semantics of doing 'return' in a format aren't documented.
1548 * Currently we ignore any args to 'return' and just return
1549 * a single undef in both scalar and list contexts
1551 PUSHs(&PL_sv_undef);
1552 else if (!io || !(fp = IoOFP(io))) {
1553 if (io && IoIFP(io))
1554 report_wrongway_fh(gv, '<');
1560 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1561 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1563 if (!do_print(PL_formtarget, fp))
1566 FmLINES(PL_formtarget) = 0;
1567 SvCUR_set(PL_formtarget, 0);
1568 *SvEND(PL_formtarget) = '\0';
1569 if (IoFLAGS(io) & IOf_FLUSH)
1570 (void)PerlIO_flush(fp);
1574 PL_formtarget = PL_bodytarget;
1580 dSP; dMARK; dORIGMARK;
1584 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1585 IO *const io = GvIO(gv);
1587 /* Treat empty list as "" */
1588 if (MARK == SP) XPUSHs(&PL_sv_no);
1591 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1593 if (MARK == ORIGMARK) {
1596 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1599 return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1601 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1608 SETERRNO(EBADF,RMS_IFI);
1611 else if (!(fp = IoOFP(io))) {
1613 report_wrongway_fh(gv, '<');
1614 else if (ckWARN(WARN_CLOSED))
1616 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1620 SV *sv = sv_newmortal();
1621 do_sprintf(sv, SP - MARK, MARK + 1);
1622 if (!do_print(sv, fp))
1625 if (IoFLAGS(io) & IOf_FLUSH)
1626 if (PerlIO_flush(fp) == EOF)
1635 PUSHs(&PL_sv_undef);
1642 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1643 const int mode = POPi;
1644 SV * const sv = POPs;
1645 GV * const gv = MUTABLE_GV(POPs);
1648 /* Need TIEHANDLE method ? */
1649 const char * const tmps = SvPV_const(sv, len);
1650 if (do_open_raw(gv, tmps, len, mode, perm)) {
1651 IoLINES(GvIOp(gv)) = 0;
1655 PUSHs(&PL_sv_undef);
1661 /* also used for: pp_read() and pp_recv() (where supported) */
1665 dSP; dMARK; dORIGMARK; dTARGET;
1679 bool charstart = FALSE;
1680 STRLEN charskip = 0;
1682 GV * const gv = MUTABLE_GV(*++MARK);
1685 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1686 && gv && (io = GvIO(gv)) )
1688 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1690 return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1691 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1701 length = SvIVx(*++MARK);
1703 DIE(aTHX_ "Negative length");
1706 offset = SvIVx(*++MARK);
1710 if (!io || !IoIFP(io)) {
1712 SETERRNO(EBADF,RMS_IFI);
1716 /* Note that fd can here validly be -1, don't check it yet. */
1717 fd = PerlIO_fileno(IoIFP(io));
1719 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1720 if (PL_op->op_type == OP_SYSREAD || PL_op->op_type == OP_RECV) {
1721 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1722 "%s() is deprecated on :utf8 handles",
1725 buffer = SvPVutf8_force(bufsv, blen);
1726 /* UTF-8 may not have been set if they are all low bytes */
1731 buffer = SvPV_force(bufsv, blen);
1732 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1734 if (DO_UTF8(bufsv)) {
1735 blen = sv_len_utf8_nomg(bufsv);
1744 if (PL_op->op_type == OP_RECV) {
1745 Sock_size_t bufsize;
1746 char namebuf[MAXPATHLEN];
1748 SETERRNO(EBADF,SS_IVCHAN);
1751 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1752 bufsize = sizeof (struct sockaddr_in);
1754 bufsize = sizeof namebuf;
1756 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1760 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1761 /* 'offset' means 'flags' here */
1762 count = PerlSock_recvfrom(fd, buffer, length, offset,
1763 (struct sockaddr *)namebuf, &bufsize);
1766 /* MSG_TRUNC can give oversized count; quietly lose it */
1769 SvCUR_set(bufsv, count);
1770 *SvEND(bufsv) = '\0';
1771 (void)SvPOK_only(bufsv);
1775 /* This should not be marked tainted if the fp is marked clean */
1776 if (!(IoFLAGS(io) & IOf_UNTAINT))
1777 SvTAINTED_on(bufsv);
1779 #if defined(__CYGWIN__)
1780 /* recvfrom() on cygwin doesn't set bufsize at all for
1781 connected sockets, leaving us with trash in the returned
1782 name, so use the same test as the Win32 code to check if it
1783 wasn't set, and set it [perl #118843] */
1784 if (bufsize == sizeof namebuf)
1787 sv_setpvn(TARG, namebuf, bufsize);
1793 if (-offset > (SSize_t)blen)
1794 DIE(aTHX_ "Offset outside string");
1797 if (DO_UTF8(bufsv)) {
1798 /* convert offset-as-chars to offset-as-bytes */
1799 if (offset >= (SSize_t)blen)
1800 offset += SvCUR(bufsv) - blen;
1802 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1806 /* Reestablish the fd in case it shifted from underneath us. */
1807 fd = PerlIO_fileno(IoIFP(io));
1809 orig_size = SvCUR(bufsv);
1810 /* Allocating length + offset + 1 isn't perfect in the case of reading
1811 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1813 (should be 2 * length + offset + 1, or possibly something longer if
1814 IN_ENCODING Is true) */
1815 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1816 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1817 Zero(buffer+orig_size, offset-orig_size, char);
1819 buffer = buffer + offset;
1821 read_target = bufsv;
1823 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1824 concatenate it to the current buffer. */
1826 /* Truncate the existing buffer to the start of where we will be
1828 SvCUR_set(bufsv, offset);
1830 read_target = sv_newmortal();
1831 SvUPGRADE(read_target, SVt_PV);
1832 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1835 if (PL_op->op_type == OP_SYSREAD) {
1836 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1837 if (IoTYPE(io) == IoTYPE_SOCKET) {
1839 SETERRNO(EBADF,SS_IVCHAN);
1843 count = PerlSock_recv(fd, buffer, length, 0);
1849 SETERRNO(EBADF,RMS_IFI);
1853 count = PerlLIO_read(fd, buffer, length);
1858 count = PerlIO_read(IoIFP(io), buffer, length);
1859 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1860 if (count == 0 && PerlIO_error(IoIFP(io)))
1864 if (IoTYPE(io) == IoTYPE_WRONLY)
1865 report_wrongway_fh(gv, '>');
1868 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1869 *SvEND(read_target) = '\0';
1870 (void)SvPOK_only(read_target);
1871 if (fp_utf8 && !IN_BYTES) {
1872 /* Look at utf8 we got back and count the characters */
1873 const char *bend = buffer + count;
1874 while (buffer < bend) {
1876 skip = UTF8SKIP(buffer);
1879 if (buffer - charskip + skip > bend) {
1880 /* partial character - try for rest of it */
1881 length = skip - (bend-buffer);
1882 offset = bend - SvPVX_const(bufsv);
1894 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1895 provided amount read (count) was what was requested (length)
1897 if (got < wanted && count == length) {
1898 length = wanted - got;
1899 offset = bend - SvPVX_const(bufsv);
1902 /* return value is character count */
1906 else if (buffer_utf8) {
1907 /* Let svcatsv upgrade the bytes we read in to utf8.
1908 The buffer is a mortal so will be freed soon. */
1909 sv_catsv_nomg(bufsv, read_target);
1912 /* This should not be marked tainted if the fp is marked clean */
1913 if (!(IoFLAGS(io) & IOf_UNTAINT))
1914 SvTAINTED_on(bufsv);
1925 /* also used for: pp_send() where defined */
1929 dSP; dMARK; dORIGMARK; dTARGET;
1934 STRLEN orig_blen_bytes;
1935 const int op_type = PL_op->op_type;
1938 GV *const gv = MUTABLE_GV(*++MARK);
1939 IO *const io = GvIO(gv);
1942 if (op_type == OP_SYSWRITE && io) {
1943 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1945 if (MARK == SP - 1) {
1947 mXPUSHi(sv_len(sv));
1951 return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1952 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1962 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1964 if (io && IoIFP(io))
1965 report_wrongway_fh(gv, '<');
1968 SETERRNO(EBADF,RMS_IFI);
1971 fd = PerlIO_fileno(IoIFP(io));
1973 SETERRNO(EBADF,SS_IVCHAN);
1978 /* Do this first to trigger any overloading. */
1979 buffer = SvPV_const(bufsv, blen);
1980 orig_blen_bytes = blen;
1981 doing_utf8 = DO_UTF8(bufsv);
1983 if (PerlIO_isutf8(IoIFP(io))) {
1984 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1985 "%s() is deprecated on :utf8 handles",
1987 if (!SvUTF8(bufsv)) {
1988 /* We don't modify the original scalar. */
1989 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1990 buffer = (char *) tmpbuf;
1994 else if (doing_utf8) {
1995 STRLEN tmplen = blen;
1996 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1999 buffer = (char *) tmpbuf;
2003 assert((char *)result == buffer);
2004 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
2009 if (op_type == OP_SEND) {
2010 const int flags = SvIVx(*++MARK);
2013 char * const sockbuf = SvPVx(*++MARK, mlen);
2014 retval = PerlSock_sendto(fd, buffer, blen,
2015 flags, (struct sockaddr *)sockbuf, mlen);
2018 retval = PerlSock_send(fd, buffer, blen, flags);
2024 Size_t length = 0; /* This length is in characters. */
2030 /* The SV is bytes, and we've had to upgrade it. */
2031 blen_chars = orig_blen_bytes;
2033 /* The SV really is UTF-8. */
2034 /* Don't call sv_len_utf8 on a magical or overloaded
2035 scalar, as we might get back a different result. */
2036 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
2043 length = blen_chars;
2045 #if Size_t_size > IVSIZE
2046 length = (Size_t)SvNVx(*++MARK);
2048 length = (Size_t)SvIVx(*++MARK);
2050 if ((SSize_t)length < 0) {
2052 DIE(aTHX_ "Negative length");
2057 offset = SvIVx(*++MARK);
2059 if (-offset > (IV)blen_chars) {
2061 DIE(aTHX_ "Offset outside string");
2063 offset += blen_chars;
2064 } else if (offset > (IV)blen_chars) {
2066 DIE(aTHX_ "Offset outside string");
2070 if (length > blen_chars - offset)
2071 length = blen_chars - offset;
2073 /* Here we convert length from characters to bytes. */
2074 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
2075 /* Either we had to convert the SV, or the SV is magical, or
2076 the SV has overloading, in which case we can't or mustn't
2077 or mustn't call it again. */
2079 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
2080 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
2082 /* It's a real UTF-8 SV, and it's not going to change under
2083 us. Take advantage of any cache. */
2085 I32 len_I32 = length;
2087 /* Convert the start and end character positions to bytes.
2088 Remember that the second argument to sv_pos_u2b is relative
2090 sv_pos_u2b(bufsv, &start, &len_I32);
2097 buffer = buffer+offset;
2099 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2100 if (IoTYPE(io) == IoTYPE_SOCKET) {
2101 retval = PerlSock_send(fd, buffer, length, 0);
2106 /* See the note at doio.c:do_print about filesize limits. --jhi */
2107 retval = PerlLIO_write(fd, buffer, length);
2115 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2118 #if Size_t_size > IVSIZE
2138 * in Perl 5.12 and later, the additional parameter is a bitmask:
2141 * 2 = eof() <- ARGV magic
2143 * I'll rely on the compiler's trace flow analysis to decide whether to
2144 * actually assign this out here, or punt it into the only block where it is
2145 * used. Doing it out here is DRY on the condition logic.
2150 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2156 if (PL_op->op_flags & OPf_SPECIAL) {
2157 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2161 gv = PL_last_in_gv; /* eof */
2169 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2170 return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2173 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2174 if (io && !IoIFP(io)) {
2175 if ((IoFLAGS(io) & IOf_START) && av_tindex(GvAVn(gv)) < 0) {
2178 IoFLAGS(io) &= ~IOf_START;
2179 do_open6(gv, "-", 1, NULL, NULL, 0);
2187 *svp = newSVpvs("-");
2189 else if (!nextargv(gv, FALSE))
2194 PUSHs(boolSV(do_eof(gv)));
2204 if (MAXARG != 0 && (TOPs || POPs))
2205 PL_last_in_gv = MUTABLE_GV(POPs);
2212 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2214 return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2219 SETERRNO(EBADF,RMS_IFI);
2224 #if LSEEKSIZE > IVSIZE
2225 PUSHn( do_tell(gv) );
2227 PUSHi( do_tell(gv) );
2233 /* also used for: pp_seek() */
2238 const int whence = POPi;
2239 #if LSEEKSIZE > IVSIZE
2240 const Off_t offset = (Off_t)SvNVx(POPs);
2242 const Off_t offset = (Off_t)SvIVx(POPs);
2245 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2246 IO *const io = GvIO(gv);
2249 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2251 #if LSEEKSIZE > IVSIZE
2252 SV *const offset_sv = newSVnv((NV) offset);
2254 SV *const offset_sv = newSViv(offset);
2257 return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2262 if (PL_op->op_type == OP_SEEK)
2263 PUSHs(boolSV(do_seek(gv, offset, whence)));
2265 const Off_t sought = do_sysseek(gv, offset, whence);
2267 PUSHs(&PL_sv_undef);
2269 SV* const sv = sought ?
2270 #if LSEEKSIZE > IVSIZE
2275 : newSVpvn(zero_but_true, ZBTLEN);
2285 /* There seems to be no consensus on the length type of truncate()
2286 * and ftruncate(), both off_t and size_t have supporters. In
2287 * general one would think that when using large files, off_t is
2288 * at least as wide as size_t, so using an off_t should be okay. */
2289 /* XXX Configure probe for the length type of *truncate() needed XXX */
2292 #if Off_t_size > IVSIZE
2297 /* Checking for length < 0 is problematic as the type might or
2298 * might not be signed: if it is not, clever compilers will moan. */
2299 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2302 SV * const sv = POPs;
2307 if (PL_op->op_flags & OPf_SPECIAL
2308 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2309 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2316 TAINT_PROPER("truncate");
2317 if (!(fp = IoIFP(io))) {
2321 int fd = PerlIO_fileno(fp);
2323 SETERRNO(EBADF,RMS_IFI);
2327 SETERRNO(EINVAL, LIB_INVARG);
2332 if (ftruncate(fd, len) < 0)
2334 if (my_chsize(fd, len) < 0)
2342 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2343 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2344 goto do_ftruncate_io;
2347 const char * const name = SvPV_nomg_const_nolen(sv);
2348 TAINT_PROPER("truncate");
2350 if (truncate(name, len) < 0)
2357 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
2358 mode |= O_LARGEFILE; /* Transparently largefiley. */
2361 /* On open(), the Win32 CRT tries to seek around text
2362 * files using 32-bit offsets, which causes the open()
2363 * to fail on large files, so open in binary mode.
2367 tmpfd = PerlLIO_open(name, mode);
2372 if (my_chsize(tmpfd, len) < 0)
2374 PerlLIO_close(tmpfd);
2383 SETERRNO(EBADF,RMS_IFI);
2389 /* also used for: pp_fcntl() */
2394 SV * const argsv = POPs;
2395 const unsigned int func = POPu;
2397 GV * const gv = MUTABLE_GV(POPs);
2398 IO * const io = GvIOn(gv);
2404 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2408 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2411 s = SvPV_force(argsv, len);
2412 need = IOCPARM_LEN(func);
2414 s = Sv_Grow(argsv, need + 1);
2415 SvCUR_set(argsv, need);
2418 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2421 retval = SvIV(argsv);
2422 s = INT2PTR(char*,retval); /* ouch */
2425 optype = PL_op->op_type;
2426 TAINT_PROPER(PL_op_desc[optype]);
2428 if (optype == OP_IOCTL)
2430 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2432 DIE(aTHX_ "ioctl is not implemented");
2436 DIE(aTHX_ "fcntl is not implemented");
2438 #if defined(OS2) && defined(__EMX__)
2439 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2441 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2445 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2447 if (s[SvCUR(argsv)] != 17)
2448 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2450 s[SvCUR(argsv)] = 0; /* put our null back */
2451 SvSETMAGIC(argsv); /* Assume it has changed */
2460 PUSHp(zero_but_true, ZBTLEN);
2471 const int argtype = POPi;
2472 GV * const gv = MUTABLE_GV(POPs);
2473 IO *const io = GvIO(gv);
2474 PerlIO *const fp = io ? IoIFP(io) : NULL;
2476 /* XXX Looks to me like io is always NULL at this point */
2478 (void)PerlIO_flush(fp);
2479 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2484 SETERRNO(EBADF,RMS_IFI);
2489 DIE(aTHX_ PL_no_func, "flock");
2500 const int protocol = POPi;
2501 const int type = POPi;
2502 const int domain = POPi;
2503 GV * const gv = MUTABLE_GV(POPs);
2504 IO * const io = GvIOn(gv);
2508 do_close(gv, FALSE);
2510 TAINT_PROPER("socket");
2511 fd = PerlSock_socket(domain, type, protocol);
2515 IoIFP(io) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2516 IoOFP(io) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE);
2517 IoTYPE(io) = IoTYPE_SOCKET;
2518 if (!IoIFP(io) || !IoOFP(io)) {
2519 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2520 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2521 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2524 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2525 /* ensure close-on-exec */
2526 if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0)
2536 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2539 const int protocol = POPi;
2540 const int type = POPi;
2541 const int domain = POPi;
2543 GV * const gv2 = MUTABLE_GV(POPs);
2544 IO * const io2 = GvIOn(gv2);
2545 GV * const gv1 = MUTABLE_GV(POPs);
2546 IO * const io1 = GvIOn(gv1);
2549 do_close(gv1, FALSE);
2551 do_close(gv2, FALSE);
2553 TAINT_PROPER("socketpair");
2554 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2556 IoIFP(io1) = PerlIO_fdopen(fd[0], "r" SOCKET_OPEN_MODE);
2557 IoOFP(io1) = PerlIO_fdopen(fd[0], "w" SOCKET_OPEN_MODE);
2558 IoTYPE(io1) = IoTYPE_SOCKET;
2559 IoIFP(io2) = PerlIO_fdopen(fd[1], "r" SOCKET_OPEN_MODE);
2560 IoOFP(io2) = PerlIO_fdopen(fd[1], "w" SOCKET_OPEN_MODE);
2561 IoTYPE(io2) = IoTYPE_SOCKET;
2562 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2563 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2564 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2565 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2566 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2567 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2568 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2571 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2572 /* ensure close-on-exec */
2573 if ((fd[0] > PL_maxsysfd && fcntl(fd[0], F_SETFD, FD_CLOEXEC) < 0) ||
2574 (fd[1] > PL_maxsysfd && fcntl(fd[1], F_SETFD, FD_CLOEXEC) < 0))
2580 DIE(aTHX_ PL_no_sock_func, "socketpair");
2586 /* also used for: pp_connect() */
2591 SV * const addrsv = POPs;
2592 /* OK, so on what platform does bind modify addr? */
2594 GV * const gv = MUTABLE_GV(POPs);
2595 IO * const io = GvIOn(gv);
2602 fd = PerlIO_fileno(IoIFP(io));
2606 addr = SvPV_const(addrsv, len);
2607 op_type = PL_op->op_type;
2608 TAINT_PROPER(PL_op_desc[op_type]);
2609 if ((op_type == OP_BIND
2610 ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
2611 : PerlSock_connect(fd, (struct sockaddr *)addr, len))
2619 SETERRNO(EBADF,SS_IVCHAN);
2626 const int backlog = POPi;
2627 GV * const gv = MUTABLE_GV(POPs);
2628 IO * const io = GvIOn(gv);
2633 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2640 SETERRNO(EBADF,SS_IVCHAN);
2648 char namebuf[MAXPATHLEN];
2649 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2650 Sock_size_t len = sizeof (struct sockaddr_in);
2652 Sock_size_t len = sizeof namebuf;
2654 GV * const ggv = MUTABLE_GV(POPs);
2655 GV * const ngv = MUTABLE_GV(POPs);
2658 IO * const gstio = GvIO(ggv);
2659 if (!gstio || !IoIFP(gstio))
2663 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2666 /* Some platforms indicate zero length when an AF_UNIX client is
2667 * not bound. Simulate a non-zero-length sockaddr structure in
2669 namebuf[0] = 0; /* sun_len */
2670 namebuf[1] = AF_UNIX; /* sun_family */
2678 do_close(ngv, FALSE);
2679 IoIFP(nstio) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE);
2680 IoOFP(nstio) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE);
2681 IoTYPE(nstio) = IoTYPE_SOCKET;
2682 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2683 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2684 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2685 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2688 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2689 /* ensure close-on-exec */
2690 if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0)
2694 #ifdef __SCO_VERSION__
2695 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2698 PUSHp(namebuf, len);
2702 report_evil_fh(ggv);
2703 SETERRNO(EBADF,SS_IVCHAN);
2713 const int how = POPi;
2714 GV * const gv = MUTABLE_GV(POPs);
2715 IO * const io = GvIOn(gv);
2720 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2725 SETERRNO(EBADF,SS_IVCHAN);
2730 /* also used for: pp_gsockopt() */
2735 const int optype = PL_op->op_type;
2736 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2737 const unsigned int optname = (unsigned int) POPi;
2738 const unsigned int lvl = (unsigned int) POPi;
2739 GV * const gv = MUTABLE_GV(POPs);
2740 IO * const io = GvIOn(gv);
2747 fd = PerlIO_fileno(IoIFP(io));
2753 (void)SvPOK_only(sv);
2757 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2760 /* XXX Configure test: does getsockopt set the length properly? */
2769 #if defined(__SYMBIAN32__)
2770 # define SETSOCKOPT_OPTION_VALUE_T void *
2772 # define SETSOCKOPT_OPTION_VALUE_T const char *
2774 /* XXX TODO: We need to have a proper type (a Configure probe,
2775 * etc.) for what the C headers think of the third argument of
2776 * setsockopt(), the option_value read-only buffer: is it
2777 * a "char *", or a "void *", const or not. Some compilers
2778 * don't take kindly to e.g. assuming that "char *" implicitly
2779 * promotes to a "void *", or to explicitly promoting/demoting
2780 * consts to non/vice versa. The "const void *" is the SUS
2781 * definition, but that does not fly everywhere for the above
2783 SETSOCKOPT_OPTION_VALUE_T buf;
2787 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2791 aint = (int)SvIV(sv);
2792 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2795 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2805 SETERRNO(EBADF,SS_IVCHAN);
2812 /* also used for: pp_getsockname() */
2817 const int optype = PL_op->op_type;
2818 GV * const gv = MUTABLE_GV(POPs);
2819 IO * const io = GvIOn(gv);
2827 sv = sv_2mortal(newSV(257));
2828 (void)SvPOK_only(sv);
2832 fd = PerlIO_fileno(IoIFP(io));
2836 case OP_GETSOCKNAME:
2837 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2840 case OP_GETPEERNAME:
2841 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2843 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2845 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";
2846 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2847 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2848 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2849 sizeof(u_short) + sizeof(struct in_addr))) {
2856 #ifdef BOGUS_GETNAME_RETURN
2857 /* Interactive Unix, getpeername() and getsockname()
2858 does not return valid namelen */
2859 if (len == BOGUS_GETNAME_RETURN)
2860 len = sizeof(struct sockaddr);
2869 SETERRNO(EBADF,SS_IVCHAN);
2878 /* also used for: pp_lstat() */
2889 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2890 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2891 if (PL_op->op_type == OP_LSTAT) {
2892 if (gv != PL_defgv) {
2893 do_fstat_warning_check:
2894 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2895 "lstat() on filehandle%s%" SVf,
2898 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2900 } else if (PL_laststype != OP_LSTAT)
2901 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2902 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2905 if (gv != PL_defgv) {
2909 PL_laststype = OP_STAT;
2910 PL_statgv = gv ? gv : (GV *)io;
2911 SvPVCLEAR(PL_statname);
2917 int fd = PerlIO_fileno(IoIFP(io));
2919 PL_laststatval = -1;
2920 SETERRNO(EBADF,RMS_IFI);
2922 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
2925 } else if (IoDIRP(io)) {
2927 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2930 PL_laststatval = -1;
2933 else PL_laststatval = -1;
2934 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2937 if (PL_laststatval < 0) {
2943 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2944 io = MUTABLE_IO(SvRV(sv));
2945 if (PL_op->op_type == OP_LSTAT)
2946 goto do_fstat_warning_check;
2947 goto do_fstat_have_io;
2950 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2951 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2953 PL_laststype = PL_op->op_type;
2954 file = SvPV_nolen_const(PL_statname);
2955 if (PL_op->op_type == OP_LSTAT)
2956 PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
2958 PL_laststatval = PerlLIO_stat(file, &PL_statcache);
2959 if (PL_laststatval < 0) {
2960 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
2961 /* PL_warn_nl is constant */
2962 GCC_DIAG_IGNORE(-Wformat-nonliteral);
2963 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2971 if (gimme != G_ARRAY) {
2972 if (gimme != G_VOID)
2973 XPUSHs(boolSV(max));
2979 mPUSHi(PL_statcache.st_dev);
2980 #if ST_INO_SIZE > IVSIZE
2981 mPUSHn(PL_statcache.st_ino);
2983 # if ST_INO_SIGN <= 0
2984 mPUSHi(PL_statcache.st_ino);
2986 mPUSHu(PL_statcache.st_ino);
2989 mPUSHu(PL_statcache.st_mode);
2990 mPUSHu(PL_statcache.st_nlink);
2992 sv_setuid(PUSHmortal, PL_statcache.st_uid);
2993 sv_setgid(PUSHmortal, PL_statcache.st_gid);
2995 #ifdef USE_STAT_RDEV
2996 mPUSHi(PL_statcache.st_rdev);
2998 PUSHs(newSVpvs_flags("", SVs_TEMP));
3000 #if Off_t_size > IVSIZE
3001 mPUSHn(PL_statcache.st_size);
3003 mPUSHi(PL_statcache.st_size);
3006 mPUSHn(PL_statcache.st_atime);
3007 mPUSHn(PL_statcache.st_mtime);
3008 mPUSHn(PL_statcache.st_ctime);
3010 mPUSHi(PL_statcache.st_atime);
3011 mPUSHi(PL_statcache.st_mtime);
3012 mPUSHi(PL_statcache.st_ctime);
3014 #ifdef USE_STAT_BLOCKS
3015 mPUSHu(PL_statcache.st_blksize);
3016 mPUSHu(PL_statcache.st_blocks);
3018 PUSHs(newSVpvs_flags("", SVs_TEMP));
3019 PUSHs(newSVpvs_flags("", SVs_TEMP));
3025 /* All filetest ops avoid manipulating the perl stack pointer in their main
3026 bodies (since commit d2c4d2d1e22d3125), and return using either
3027 S_ft_return_false() or S_ft_return_true(). These two helper functions are
3028 the only two which manipulate the perl stack. To ensure that no stack
3029 manipulation macros are used, the filetest ops avoid defining a local copy
3030 of the stack pointer with dSP. */
3032 /* If the next filetest is stacked up with this one
3033 (PL_op->op_private & OPpFT_STACKING), we leave
3034 the original argument on the stack for success,
3035 and skip the stacked operators on failure.
3036 The next few macros/functions take care of this.
3040 S_ft_return_false(pTHX_ SV *ret) {
3044 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
3048 if (PL_op->op_private & OPpFT_STACKING) {
3049 while (OP_IS_FILETEST(next->op_type)
3050 && next->op_private & OPpFT_STACKED)
3051 next = next->op_next;
3056 PERL_STATIC_INLINE OP *
3057 S_ft_return_true(pTHX_ SV *ret) {
3059 if (PL_op->op_flags & OPf_REF)
3060 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
3061 else if (!(PL_op->op_private & OPpFT_STACKING))
3067 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
3068 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
3069 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
3071 #define tryAMAGICftest_MG(chr) STMT_START { \
3072 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
3073 && PL_op->op_flags & OPf_KIDS) { \
3074 OP *next = S_try_amagic_ftest(aTHX_ chr); \
3075 if (next) return next; \
3080 S_try_amagic_ftest(pTHX_ char chr) {
3081 SV *const arg = *PL_stack_sp;
3084 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
3088 const char tmpchr = chr;
3089 SV * const tmpsv = amagic_call(arg,
3090 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
3091 ftest_amg, AMGf_unary);
3096 return SvTRUE(tmpsv)
3097 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
3103 /* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec()
3109 /* Not const, because things tweak this below. Not bool, because there's
3110 no guarantee that OPpFT_ACCESS is <= CHAR_MAX */
3111 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3112 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3113 /* Giving some sort of initial value silences compilers. */
3115 int access_mode = R_OK;
3117 int access_mode = 0;
3120 /* access_mode is never used, but leaving use_access in makes the
3121 conditional compiling below much clearer. */
3124 Mode_t stat_mode = S_IRUSR;
3126 bool effective = FALSE;
3129 switch (PL_op->op_type) {
3130 case OP_FTRREAD: opchar = 'R'; break;
3131 case OP_FTRWRITE: opchar = 'W'; break;
3132 case OP_FTREXEC: opchar = 'X'; break;
3133 case OP_FTEREAD: opchar = 'r'; break;
3134 case OP_FTEWRITE: opchar = 'w'; break;
3135 case OP_FTEEXEC: opchar = 'x'; break;
3137 tryAMAGICftest_MG(opchar);
3139 switch (PL_op->op_type) {
3141 #if !(defined(HAS_ACCESS) && defined(R_OK))
3147 #if defined(HAS_ACCESS) && defined(W_OK)
3152 stat_mode = S_IWUSR;
3156 #if defined(HAS_ACCESS) && defined(X_OK)
3161 stat_mode = S_IXUSR;
3165 #ifdef PERL_EFF_ACCESS
3168 stat_mode = S_IWUSR;
3172 #ifndef PERL_EFF_ACCESS
3179 #ifdef PERL_EFF_ACCESS
3184 stat_mode = S_IXUSR;
3190 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3191 const char *name = SvPV_nolen(*PL_stack_sp);
3193 # ifdef PERL_EFF_ACCESS
3194 result = PERL_EFF_ACCESS(name, access_mode);
3196 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3202 result = access(name, access_mode);
3204 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3215 result = my_stat_flags(0);
3218 if (cando(stat_mode, effective, &PL_statcache))
3224 /* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */
3229 const int op_type = PL_op->op_type;
3233 case OP_FTIS: opchar = 'e'; break;
3234 case OP_FTSIZE: opchar = 's'; break;
3235 case OP_FTMTIME: opchar = 'M'; break;
3236 case OP_FTCTIME: opchar = 'C'; break;
3237 case OP_FTATIME: opchar = 'A'; break;
3239 tryAMAGICftest_MG(opchar);
3241 result = my_stat_flags(0);
3244 if (op_type == OP_FTIS)
3247 /* You can't dTARGET inside OP_FTIS, because you'll get
3248 "panic: pad_sv po" - the op is not flagged to have a target. */
3252 #if Off_t_size > IVSIZE
3253 sv_setnv(TARG, (NV)PL_statcache.st_size);
3255 sv_setiv(TARG, (IV)PL_statcache.st_size);
3260 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3264 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3268 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3272 return SvTRUE_nomg(TARG)
3273 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3278 /* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned()
3279 * pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock()
3280 * pp_ftsuid() pp_ftsvtx() pp_ftzero() */
3287 switch (PL_op->op_type) {
3288 case OP_FTROWNED: opchar = 'O'; break;
3289 case OP_FTEOWNED: opchar = 'o'; break;
3290 case OP_FTZERO: opchar = 'z'; break;
3291 case OP_FTSOCK: opchar = 'S'; break;
3292 case OP_FTCHR: opchar = 'c'; break;
3293 case OP_FTBLK: opchar = 'b'; break;
3294 case OP_FTFILE: opchar = 'f'; break;
3295 case OP_FTDIR: opchar = 'd'; break;
3296 case OP_FTPIPE: opchar = 'p'; break;
3297 case OP_FTSUID: opchar = 'u'; break;
3298 case OP_FTSGID: opchar = 'g'; break;
3299 case OP_FTSVTX: opchar = 'k'; break;
3301 tryAMAGICftest_MG(opchar);
3303 /* I believe that all these three are likely to be defined on most every
3304 system these days. */
3306 if(PL_op->op_type == OP_FTSUID) {
3311 if(PL_op->op_type == OP_FTSGID) {
3316 if(PL_op->op_type == OP_FTSVTX) {
3321 result = my_stat_flags(0);
3324 switch (PL_op->op_type) {
3326 if (PL_statcache.st_uid == PerlProc_getuid())
3330 if (PL_statcache.st_uid == PerlProc_geteuid())
3334 if (PL_statcache.st_size == 0)
3338 if (S_ISSOCK(PL_statcache.st_mode))
3342 if (S_ISCHR(PL_statcache.st_mode))
3346 if (S_ISBLK(PL_statcache.st_mode))
3350 if (S_ISREG(PL_statcache.st_mode))
3354 if (S_ISDIR(PL_statcache.st_mode))
3358 if (S_ISFIFO(PL_statcache.st_mode))
3363 if (PL_statcache.st_mode & S_ISUID)
3369 if (PL_statcache.st_mode & S_ISGID)
3375 if (PL_statcache.st_mode & S_ISVTX)
3387 tryAMAGICftest_MG('l');
3388 result = my_lstat_flags(0);
3392 if (S_ISLNK(PL_statcache.st_mode))
3405 tryAMAGICftest_MG('t');
3407 if (PL_op->op_flags & OPf_REF)
3410 SV *tmpsv = *PL_stack_sp;
3411 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3412 name = SvPV_nomg(tmpsv, namelen);
3413 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3417 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3418 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3419 else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX)
3424 SETERRNO(EBADF,RMS_IFI);
3427 if (PerlLIO_isatty(fd))
3433 /* also used for: pp_ftbinary() */
3447 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3449 if (PL_op->op_flags & OPf_REF)
3451 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3456 gv = MAYBE_DEREF_GV_nomg(sv);
3460 if (gv == PL_defgv) {
3462 io = SvTYPE(PL_statgv) == SVt_PVIO
3466 goto really_filename;
3471 SvPVCLEAR(PL_statname);
3472 io = GvIO(PL_statgv);
3474 PL_laststatval = -1;
3475 PL_laststype = OP_STAT;
3476 if (io && IoIFP(io)) {
3478 if (! PerlIO_has_base(IoIFP(io)))
3479 DIE(aTHX_ "-T and -B not implemented on filehandles");
3480 fd = PerlIO_fileno(IoIFP(io));
3482 SETERRNO(EBADF,RMS_IFI);
3485 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3486 if (PL_laststatval < 0)
3488 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3489 if (PL_op->op_type == OP_FTTEXT)
3494 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3495 i = PerlIO_getc(IoIFP(io));
3497 (void)PerlIO_ungetc(IoIFP(io),i);
3499 /* null file is anything */
3502 len = PerlIO_get_bufsiz(IoIFP(io));
3503 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3504 /* sfio can have large buffers - limit to 512 */
3509 SETERRNO(EBADF,RMS_IFI);
3511 SETERRNO(EBADF,RMS_IFI);
3520 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3522 file = SvPVX_const(PL_statname);
3524 if (!(fp = PerlIO_open(file, "r"))) {
3526 PL_laststatval = -1;
3527 PL_laststype = OP_STAT;
3529 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
3530 /* PL_warn_nl is constant */
3531 GCC_DIAG_IGNORE(-Wformat-nonliteral);
3532 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3537 PL_laststype = OP_STAT;
3538 fd = PerlIO_fileno(fp);
3540 (void)PerlIO_close(fp);
3541 SETERRNO(EBADF,RMS_IFI);
3544 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3545 if (PL_laststatval < 0) {
3547 (void)PerlIO_close(fp);
3551 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3552 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3553 (void)PerlIO_close(fp);
3555 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3556 FT_RETURNNO; /* special case NFS directories */
3557 FT_RETURNYES; /* null file is anything */
3562 /* now scan s to look for textiness */
3564 #if defined(DOSISH) || defined(USEMYBINMODE)
3565 /* ignore trailing ^Z on short files */
3566 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3571 if (! is_utf8_invariant_string((U8 *) s, len)) {
3573 /* Here contains a variant under UTF-8 . See if the entire string is
3575 if (is_utf8_fixed_width_buf_flags((U8 *) s, len, 0)) {
3576 if (PL_op->op_type == OP_FTTEXT) {
3585 /* Here, is not UTF-8 or is entirely ASCII. Look through the buffer for
3586 * things that wouldn't be in ASCII text or rich ASCII text. Count these
3588 for (i = 0; i < len; i++, s++) {
3589 if (!*s) { /* null never allowed in text */
3593 #ifdef USE_LOCALE_CTYPE
3594 if (IN_LC_RUNTIME(LC_CTYPE)) {
3595 if ( isPRINT_LC(*s) || isSPACE_LC(*s)) {
3602 /* VT occurs so rarely in text, that we consider it odd */
3603 || (isSPACE_A(*s) && *s != VT_NATIVE)
3605 /* But there is a fair amount of backspaces and escapes in
3608 || *s == ESC_NATIVE)
3615 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3626 const char *tmps = NULL;
3630 SV * const sv = POPs;
3631 if (PL_op->op_flags & OPf_SPECIAL) {
3632 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3634 if (ckWARN(WARN_UNOPENED)) {
3635 Perl_warner(aTHX_ packWARN(WARN_UNOPENED),
3636 "chdir() on unopened filehandle %" SVf, sv);
3638 SETERRNO(EBADF,RMS_IFI);
3640 TAINT_PROPER("chdir");
3644 else if (!(gv = MAYBE_DEREF_GV(sv)))
3645 tmps = SvPV_nomg_const_nolen(sv);
3648 HV * const table = GvHVn(PL_envgv);
3652 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3653 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3655 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3659 tmps = SvPV_nolen_const(*svp);
3663 SETERRNO(EINVAL, LIB_INVARG);
3664 TAINT_PROPER("chdir");
3669 TAINT_PROPER("chdir");
3672 IO* const io = GvIO(gv);
3675 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3676 } else if (IoIFP(io)) {
3677 int fd = PerlIO_fileno(IoIFP(io));
3681 PUSHi(fchdir(fd) >= 0);
3691 DIE(aTHX_ PL_no_func, "fchdir");
3695 PUSHi( PerlDir_chdir(tmps) >= 0 );
3697 /* Clear the DEFAULT element of ENV so we'll get the new value
3699 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3706 SETERRNO(EBADF,RMS_IFI);
3713 /* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */
3717 dSP; dMARK; dTARGET;
3718 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3729 char * const tmps = POPpx;
3730 TAINT_PROPER("chroot");
3731 PUSHi( chroot(tmps) >= 0 );
3734 DIE(aTHX_ PL_no_func, "chroot");
3745 const char * const tmps2 = POPpconstx;
3746 const char * const tmps = SvPV_nolen_const(TOPs);
3747 TAINT_PROPER("rename");
3749 anum = PerlLIO_rename(tmps, tmps2);
3751 if (!(anum = PerlLIO_stat(tmps, &statbuf))) {
3752 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3755 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
3756 (void)UNLINK(tmps2);
3757 if (!(anum = link(tmps, tmps2)))
3758 anum = UNLINK(tmps);
3767 /* also used for: pp_symlink() */
3769 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3773 const int op_type = PL_op->op_type;
3777 if (op_type == OP_LINK)
3778 DIE(aTHX_ PL_no_func, "link");
3780 # ifndef HAS_SYMLINK
3781 if (op_type == OP_SYMLINK)
3782 DIE(aTHX_ PL_no_func, "symlink");
3786 const char * const tmps2 = POPpconstx;
3787 const char * const tmps = SvPV_nolen_const(TOPs);
3788 TAINT_PROPER(PL_op_desc[op_type]);
3790 # if defined(HAS_LINK)
3791 # if defined(HAS_SYMLINK)
3792 /* Both present - need to choose which. */
3793 (op_type == OP_LINK) ?
3794 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3796 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3797 PerlLIO_link(tmps, tmps2);
3800 # if defined(HAS_SYMLINK)
3801 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3802 symlink(tmps, tmps2);
3807 SETi( result >= 0 );
3812 /* also used for: pp_symlink() */
3817 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3827 char buf[MAXPATHLEN];
3832 /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
3833 * it is impossible to know whether the result was truncated. */
3834 len = readlink(tmps, buf, sizeof(buf) - 1);
3843 RETSETUNDEF; /* just pretend it's a normal file */
3847 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3849 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3851 char * const save_filename = filename;
3856 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3858 PERL_ARGS_ASSERT_DOONELINER;
3860 Newx(cmdline, size, char);
3861 my_strlcpy(cmdline, cmd, size);
3862 my_strlcat(cmdline, " ", size);
3863 for (s = cmdline + strlen(cmdline); *filename; ) {
3867 if (s - cmdline < size)
3868 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3869 myfp = PerlProc_popen(cmdline, "r");
3873 SV * const tmpsv = sv_newmortal();
3874 /* Need to save/restore 'PL_rs' ?? */
3875 s = sv_gets(tmpsv, myfp, 0);
3876 (void)PerlProc_pclose(myfp);
3880 #ifdef HAS_SYS_ERRLIST
3885 /* you don't see this */
3886 const char * const errmsg = Strerror(e) ;
3889 if (instr(s, errmsg)) {
3896 #define EACCES EPERM
3898 if (instr(s, "cannot make"))
3899 SETERRNO(EEXIST,RMS_FEX);
3900 else if (instr(s, "existing file"))
3901 SETERRNO(EEXIST,RMS_FEX);
3902 else if (instr(s, "ile exists"))
3903 SETERRNO(EEXIST,RMS_FEX);
3904 else if (instr(s, "non-exist"))
3905 SETERRNO(ENOENT,RMS_FNF);
3906 else if (instr(s, "does not exist"))
3907 SETERRNO(ENOENT,RMS_FNF);
3908 else if (instr(s, "not empty"))
3909 SETERRNO(EBUSY,SS_DEVOFFLINE);
3910 else if (instr(s, "cannot access"))
3911 SETERRNO(EACCES,RMS_PRV);
3913 SETERRNO(EPERM,RMS_PRV);
3916 else { /* some mkdirs return no failure indication */
3918 anum = (PerlLIO_stat(save_filename, &statbuf) >= 0);
3919 if (PL_op->op_type == OP_RMDIR)
3924 SETERRNO(EACCES,RMS_PRV); /* a guess */
3933 /* This macro removes trailing slashes from a directory name.
3934 * Different operating and file systems take differently to
3935 * trailing slashes. According to POSIX 1003.1 1996 Edition
3936 * any number of trailing slashes should be allowed.
3937 * Thusly we snip them away so that even non-conforming
3938 * systems are happy.
3939 * We should probably do this "filtering" for all
3940 * the functions that expect (potentially) directory names:
3941 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3942 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3944 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3945 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3948 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3949 (tmps) = savepvn((tmps), (len)); \
3959 const unsigned int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPu : 0777;
3961 TRIMSLASHES(tmps,len,copy);
3963 TAINT_PROPER("mkdir");
3965 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3969 SETi( dooneliner("mkdir", tmps) );
3970 oldumask = PerlLIO_umask(0);
3971 PerlLIO_umask(oldumask);
3972 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3987 TRIMSLASHES(tmps,len,copy);
3988 TAINT_PROPER("rmdir");
3990 SETi( PerlDir_rmdir(tmps) >= 0 );
3992 SETi( dooneliner("rmdir", tmps) );
3999 /* Directory calls. */
4003 #if defined(Direntry_t) && defined(HAS_READDIR)
4005 const char * const dirname = POPpconstx;
4006 GV * const gv = MUTABLE_GV(POPs);
4007 IO * const io = GvIOn(gv);
4009 if ((IoIFP(io) || IoOFP(io)))
4010 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
4011 "Opening filehandle %" HEKf " also as a directory",
4012 HEKfARG(GvENAME_HEK(gv)) );
4014 PerlDir_close(IoDIRP(io));
4015 if (!(IoDIRP(io) = PerlDir_open(dirname)))
4021 SETERRNO(EBADF,RMS_DIR);
4024 DIE(aTHX_ PL_no_dir_func, "opendir");
4030 #if !defined(Direntry_t) || !defined(HAS_READDIR)
4031 DIE(aTHX_ PL_no_dir_func, "readdir");
4033 #if !defined(I_DIRENT) && !defined(VMS)
4034 Direntry_t *readdir (DIR *);
4039 const U8 gimme = GIMME_V;
4040 GV * const gv = MUTABLE_GV(POPs);
4041 const Direntry_t *dp;
4042 IO * const io = GvIOn(gv);
4045 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4046 "readdir() attempted on invalid dirhandle %" HEKf,
4047 HEKfARG(GvENAME_HEK(gv)));
4052 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
4056 sv = newSVpvn(dp->d_name, dp->d_namlen);
4058 sv = newSVpv(dp->d_name, 0);
4060 if (!(IoFLAGS(io) & IOf_UNTAINT))
4063 } while (gimme == G_ARRAY);
4065 if (!dp && gimme != G_ARRAY)
4072 SETERRNO(EBADF,RMS_ISI);
4073 if (gimme == G_ARRAY)
4082 #if defined(HAS_TELLDIR) || defined(telldir)
4084 /* XXX does _anyone_ need this? --AD 2/20/1998 */
4085 /* XXX netbsd still seemed to.
4086 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
4087 --JHI 1999-Feb-02 */
4088 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
4089 long telldir (DIR *);
4091 GV * const gv = MUTABLE_GV(POPs);
4092 IO * const io = GvIOn(gv);
4095 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4096 "telldir() attempted on invalid dirhandle %" HEKf,
4097 HEKfARG(GvENAME_HEK(gv)));
4101 PUSHi( PerlDir_tell(IoDIRP(io)) );
4105 SETERRNO(EBADF,RMS_ISI);
4108 DIE(aTHX_ PL_no_dir_func, "telldir");
4114 #if defined(HAS_SEEKDIR) || defined(seekdir)
4116 const long along = POPl;
4117 GV * const gv = MUTABLE_GV(POPs);
4118 IO * const io = GvIOn(gv);
4121 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4122 "seekdir() attempted on invalid dirhandle %" HEKf,
4123 HEKfARG(GvENAME_HEK(gv)));
4126 (void)PerlDir_seek(IoDIRP(io), along);
4131 SETERRNO(EBADF,RMS_ISI);
4134 DIE(aTHX_ PL_no_dir_func, "seekdir");
4140 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4142 GV * const gv = MUTABLE_GV(POPs);
4143 IO * const io = GvIOn(gv);
4146 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4147 "rewinddir() attempted on invalid dirhandle %" HEKf,
4148 HEKfARG(GvENAME_HEK(gv)));
4151 (void)PerlDir_rewind(IoDIRP(io));
4155 SETERRNO(EBADF,RMS_ISI);
4158 DIE(aTHX_ PL_no_dir_func, "rewinddir");
4164 #if defined(Direntry_t) && defined(HAS_READDIR)
4166 GV * const gv = MUTABLE_GV(POPs);
4167 IO * const io = GvIOn(gv);
4170 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4171 "closedir() attempted on invalid dirhandle %" HEKf,
4172 HEKfARG(GvENAME_HEK(gv)));
4175 #ifdef VOID_CLOSEDIR
4176 PerlDir_close(IoDIRP(io));
4178 if (PerlDir_close(IoDIRP(io)) < 0) {
4179 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4188 SETERRNO(EBADF,RMS_IFI);
4191 DIE(aTHX_ PL_no_dir_func, "closedir");
4195 /* Process control. */
4202 #ifdef HAS_SIGPROCMASK
4203 sigset_t oldmask, newmask;
4207 PERL_FLUSHALL_FOR_CHILD;
4208 #ifdef HAS_SIGPROCMASK
4209 sigfillset(&newmask);
4210 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4212 childpid = PerlProc_fork();
4213 if (childpid == 0) {
4217 for (sig = 1; sig < SIG_SIZE; sig++)
4218 PL_psig_pend[sig] = 0;
4220 #ifdef HAS_SIGPROCMASK
4223 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4230 #ifdef PERL_USES_PL_PIDSTATUS
4231 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4237 # if (defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)) || defined(__amigaos4__)
4242 PERL_FLUSHALL_FOR_CHILD;
4243 childpid = PerlProc_fork();
4249 DIE(aTHX_ PL_no_func, "fork");
4256 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4261 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4262 childpid = wait4pid(-1, &argflags, 0);
4264 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4269 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4270 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4271 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4273 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4278 DIE(aTHX_ PL_no_func, "wait");
4284 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4286 const int optype = POPi;
4287 const Pid_t pid = TOPi;
4291 result = amigaos_waitpid(aTHX_ optype, pid, &argflags);
4292 STATUS_NATIVE_CHILD_SET((result >= 0) ? argflags : -1);
4293 result = result == 0 ? pid : -1;
4297 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4298 result = wait4pid(pid, &argflags, optype);
4300 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4305 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4306 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4307 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4309 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4311 # endif /* __amigaos4__ */
4315 DIE(aTHX_ PL_no_func, "waitpid");
4321 dSP; dMARK; dORIGMARK; dTARGET;
4322 #if defined(__LIBCATAMOUNT__)
4323 PL_statusvalue = -1;
4328 # ifdef __amigaos4__
4336 while (++MARK <= SP) {
4337 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4342 TAINT_PROPER("system");
4344 PERL_FLUSHALL_FOR_CHILD;
4345 #if (defined(HAS_FORK) || defined(__amigaos4__)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4348 struct UserData userdata;
4355 bool child_success = FALSE;
4356 #ifdef HAS_SIGPROCMASK
4357 sigset_t newset, oldset;
4360 if (PerlProc_pipe(pp) >= 0)
4363 amigaos_fork_set_userdata(aTHX_
4369 pthread_create(&proc,NULL,amigaos_system_child,(void *)&userdata);
4370 child_success = proc > 0;
4372 #ifdef HAS_SIGPROCMASK
4373 sigemptyset(&newset);
4374 sigaddset(&newset, SIGCHLD);
4375 sigprocmask(SIG_BLOCK, &newset, &oldset);
4377 while ((childpid = PerlProc_fork()) == -1) {
4378 if (errno != EAGAIN) {
4383 PerlLIO_close(pp[0]);
4384 PerlLIO_close(pp[1]);
4386 #ifdef HAS_SIGPROCMASK
4387 sigprocmask(SIG_SETMASK, &oldset, NULL);
4393 child_success = childpid > 0;
4395 if (child_success) {
4396 Sigsave_t ihand,qhand; /* place to save signals during system() */
4399 #ifndef __amigaos4__
4401 PerlLIO_close(pp[1]);
4404 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4405 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4408 result = pthread_join(proc, (void **)&status);
4411 result = wait4pid(childpid, &status, 0);
4412 } while (result == -1 && errno == EINTR);
4415 #ifdef HAS_SIGPROCMASK
4416 sigprocmask(SIG_SETMASK, &oldset, NULL);
4418 (void)rsignal_restore(SIGINT, &ihand);
4419 (void)rsignal_restore(SIGQUIT, &qhand);
4421 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4422 do_execfree(); /* free any memory child malloced on fork */
4429 while (n < sizeof(int)) {
4430 n1 = PerlLIO_read(pp[0],
4431 (void*)(((char*)&errkid)+n),
4437 PerlLIO_close(pp[0]);
4438 if (n) { /* Error */
4439 if (n != sizeof(int))
4440 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4441 errno = errkid; /* Propagate errno from kid */
4443 /* The pipe always has something in it
4444 * so n alone is not enough. */
4448 STATUS_NATIVE_CHILD_SET(-1);
4452 XPUSHi(STATUS_CURRENT);
4455 #ifndef __amigaos4__
4456 #ifdef HAS_SIGPROCMASK
4457 sigprocmask(SIG_SETMASK, &oldset, NULL);
4460 PerlLIO_close(pp[0]);
4461 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
4462 if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
4466 if (PL_op->op_flags & OPf_STACKED) {
4467 SV * const really = *++MARK;
4468 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4470 else if (SP - MARK != 1)
4471 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4473 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4475 #endif /* __amigaos4__ */
4478 #else /* ! FORK or VMS or OS/2 */
4481 if (PL_op->op_flags & OPf_STACKED) {
4482 SV * const really = *++MARK;
4483 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4484 value = (I32)do_aspawn(really, MARK, SP);
4486 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4489 else if (SP - MARK != 1) {
4490 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4491 value = (I32)do_aspawn(NULL, MARK, SP);
4493 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4497 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4499 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4501 STATUS_NATIVE_CHILD_SET(value);
4504 XPUSHi(result ? value : STATUS_CURRENT);
4505 #endif /* !FORK or VMS or OS/2 */
4512 dSP; dMARK; dORIGMARK; dTARGET;
4517 while (++MARK <= SP) {
4518 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4523 TAINT_PROPER("exec");
4526 PERL_FLUSHALL_FOR_CHILD;
4527 if (PL_op->op_flags & OPf_STACKED) {
4528 SV * const really = *++MARK;
4529 value = (I32)do_aexec(really, MARK, SP);
4531 else if (SP - MARK != 1)
4533 value = (I32)vms_do_aexec(NULL, MARK, SP);
4535 value = (I32)do_aexec(NULL, MARK, SP);
4539 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4541 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4553 XPUSHi( getppid() );
4556 DIE(aTHX_ PL_no_func, "getppid");
4566 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4569 pgrp = (I32)BSD_GETPGRP(pid);
4571 if (pid != 0 && pid != PerlProc_getpid())
4572 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4578 DIE(aTHX_ PL_no_func, "getpgrp");
4588 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4589 if (MAXARG > 0) pid = TOPs ? TOPi : 0;
4596 TAINT_PROPER("setpgrp");
4598 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4600 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4601 || (pid != 0 && pid != PerlProc_getpid()))
4603 DIE(aTHX_ "setpgrp can't take arguments");
4605 SETi( setpgrp() >= 0 );
4606 #endif /* USE_BSDPGRP */
4609 DIE(aTHX_ PL_no_func, "setpgrp");
4613 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4614 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4616 # define PRIORITY_WHICH_T(which) which
4621 #ifdef HAS_GETPRIORITY
4623 const int who = POPi;
4624 const int which = TOPi;
4625 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4628 DIE(aTHX_ PL_no_func, "getpriority");
4634 #ifdef HAS_SETPRIORITY
4636 const int niceval = POPi;
4637 const int who = POPi;
4638 const int which = TOPi;
4639 TAINT_PROPER("setpriority");
4640 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4643 DIE(aTHX_ PL_no_func, "setpriority");
4647 #undef PRIORITY_WHICH_T
4655 XPUSHn( time(NULL) );
4657 XPUSHi( time(NULL) );
4666 struct tms timesbuf;
4669 (void)PerlProc_times(×buf);
4671 mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
4672 if (GIMME_V == G_ARRAY) {
4673 mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
4674 mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
4675 mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
4683 if (GIMME_V == G_ARRAY) {
4690 DIE(aTHX_ "times not implemented");
4692 #endif /* HAS_TIMES */
4695 /* The 32 bit int year limits the times we can represent to these
4696 boundaries with a few days wiggle room to account for time zone
4699 /* Sat Jan 3 00:00:00 -2147481748 */
4700 #define TIME_LOWER_BOUND -67768100567755200.0
4701 /* Sun Dec 29 12:00:00 2147483647 */
4702 #define TIME_UPPER_BOUND 67767976233316800.0
4705 /* also used for: pp_localtime() */
4713 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4714 static const char * const dayname[] =
4715 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4716 static const char * const monname[] =
4717 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4718 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4720 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4723 when = (Time64_T)now;
4726 NV input = Perl_floor(POPn);
4727 const bool pl_isnan = Perl_isnan(input);
4728 when = (Time64_T)input;
4729 if (UNLIKELY(pl_isnan || when != input)) {
4730 /* diag_listed_as: gmtime(%f) too large */
4731 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4732 "%s(%.0" NVff ") too large", opname, input);
4740 if ( TIME_LOWER_BOUND > when ) {
4741 /* diag_listed_as: gmtime(%f) too small */
4742 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4743 "%s(%.0" NVff ") too small", opname, when);
4746 else if( when > TIME_UPPER_BOUND ) {
4747 /* diag_listed_as: gmtime(%f) too small */
4748 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4749 "%s(%.0" NVff ") too large", opname, when);
4753 if (PL_op->op_type == OP_LOCALTIME)
4754 err = Perl_localtime64_r(&when, &tmbuf);
4756 err = Perl_gmtime64_r(&when, &tmbuf);
4760 /* diag_listed_as: gmtime(%f) failed */
4761 /* XXX %lld broken for quads */
4763 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4764 "%s(%.0" NVff ") failed", opname, when);
4767 if (GIMME_V != G_ARRAY) { /* scalar context */
4774 Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %" IVdf,
4775 dayname[tmbuf.tm_wday],
4776 monname[tmbuf.tm_mon],
4781 (IV)tmbuf.tm_year + 1900);
4784 else { /* list context */
4790 mPUSHi(tmbuf.tm_sec);
4791 mPUSHi(tmbuf.tm_min);
4792 mPUSHi(tmbuf.tm_hour);
4793 mPUSHi(tmbuf.tm_mday);
4794 mPUSHi(tmbuf.tm_mon);
4795 mPUSHn(tmbuf.tm_year);
4796 mPUSHi(tmbuf.tm_wday);
4797 mPUSHi(tmbuf.tm_yday);
4798 mPUSHi(tmbuf.tm_isdst);
4807 /* alarm() takes an unsigned int number of seconds, and return the
4808 * unsigned int number of seconds remaining in the previous alarm
4809 * (alarms don't stack). Therefore negative return values are not
4813 /* Note that while the C library function alarm() as such has
4814 * no errors defined (or in other words, properly behaving client
4815 * code shouldn't expect any), alarm() being obsoleted by
4816 * setitimer() and often being implemented in terms of
4817 * setitimer(), can fail. */
4818 /* diag_listed_as: %s() with negative argument */
4819 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4820 "alarm() with negative argument");
4821 SETERRNO(EINVAL, LIB_INVARG);
4825 unsigned int retval = alarm(anum);
4826 if ((int)retval < 0) /* Strictly speaking "cannot happen". */
4832 DIE(aTHX_ PL_no_func, "alarm");
4843 (void)time(&lasttime);
4844 if (MAXARG < 1 || (!TOPs && !POPs))
4849 /* diag_listed_as: %s() with negative argument */
4850 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4851 "sleep() with negative argument");
4852 SETERRNO(EINVAL, LIB_INVARG);
4856 PerlProc_sleep((unsigned int)duration);
4860 XPUSHi(when - lasttime);
4864 /* Shared memory. */
4865 /* Merged with some message passing. */
4867 /* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */
4871 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4872 dSP; dMARK; dTARGET;
4873 const int op_type = PL_op->op_type;
4878 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4881 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4884 value = (I32)(do_semop(MARK, SP) >= 0);
4887 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4895 return Perl_pp_semget(aTHX);
4901 /* also used for: pp_msgget() pp_shmget() */
4905 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4906 dSP; dMARK; dTARGET;
4907 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4914 DIE(aTHX_ "System V IPC is not implemented on this machine");
4918 /* also used for: pp_msgctl() pp_shmctl() */
4922 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4923 dSP; dMARK; dTARGET;
4924 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4932 PUSHp(zero_but_true, ZBTLEN);
4936 return Perl_pp_semget(aTHX);
4940 /* I can't const this further without getting warnings about the types of
4941 various arrays passed in from structures. */
4943 S_space_join_names_mortal(pTHX_ char *const *array)
4947 if (array && *array) {
4948 target = newSVpvs_flags("", SVs_TEMP);
4950 sv_catpv(target, *array);
4953 sv_catpvs(target, " ");
4956 target = sv_mortalcopy(&PL_sv_no);
4961 /* Get system info. */
4963 /* also used for: pp_ghbyaddr() pp_ghbyname() */
4967 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4969 I32 which = PL_op->op_type;
4972 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4973 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4974 struct hostent *gethostbyname(Netdb_name_t);
4975 struct hostent *gethostent(void);
4977 struct hostent *hent = NULL;
4981 if (which == OP_GHBYNAME) {
4982 #ifdef HAS_GETHOSTBYNAME
4983 const char* const name = POPpbytex;
4984 hent = PerlSock_gethostbyname(name);
4986 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4989 else if (which == OP_GHBYADDR) {
4990 #ifdef HAS_GETHOSTBYADDR
4991 const int addrtype = POPi;
4992 SV * const addrsv = POPs;
4994 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4996 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4998 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
5002 #ifdef HAS_GETHOSTENT
5003 hent = PerlSock_gethostent();
5005 DIE(aTHX_ PL_no_sock_func, "gethostent");
5008 #ifdef HOST_NOT_FOUND
5010 #ifdef USE_REENTRANT_API
5011 # ifdef USE_GETHOSTENT_ERRNO
5012 h_errno = PL_reentrant_buffer->_gethostent_errno;
5015 STATUS_UNIX_SET(h_errno);
5019 if (GIMME_V != G_ARRAY) {
5020 PUSHs(sv = sv_newmortal());
5022 if (which == OP_GHBYNAME) {
5024 sv_setpvn(sv, hent->h_addr, hent->h_length);
5027 sv_setpv(sv, (char*)hent->h_name);
5033 mPUSHs(newSVpv((char*)hent->h_name, 0));
5034 PUSHs(space_join_names_mortal(hent->h_aliases));
5035 mPUSHi(hent->h_addrtype);
5036 len = hent->h_length;
5039 for (elem = hent->h_addr_list; elem && *elem; elem++) {
5040 mXPUSHp(*elem, len);
5044 mPUSHp(hent->h_addr, len);
5046 PUSHs(sv_mortalcopy(&PL_sv_no));
5051 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5055 /* also used for: pp_gnbyaddr() pp_gnbyname() */
5059 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
5061 I32 which = PL_op->op_type;
5063 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
5064 struct netent *getnetbyaddr(Netdb_net_t, int);
5065 struct netent *getnetbyname(Netdb_name_t);
5066 struct netent *getnetent(void);
5068 struct netent *nent;
5070 if (which == OP_GNBYNAME){
5071 #ifdef HAS_GETNETBYNAME
5072 const char * const name = POPpbytex;
5073 nent = PerlSock_getnetbyname(name);
5075 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
5078 else if (which == OP_GNBYADDR) {
5079 #ifdef HAS_GETNETBYADDR
5080 const int addrtype = POPi;
5081 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
5082 nent = PerlSock_getnetbyaddr(addr, addrtype);
5084 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
5088 #ifdef HAS_GETNETENT
5089 nent = PerlSock_getnetent();
5091 DIE(aTHX_ PL_no_sock_func, "getnetent");
5094 #ifdef HOST_NOT_FOUND
5096 #ifdef USE_REENTRANT_API
5097 # ifdef USE_GETNETENT_ERRNO
5098 h_errno = PL_reentrant_buffer->_getnetent_errno;
5101 STATUS_UNIX_SET(h_errno);
5106 if (GIMME_V != G_ARRAY) {
5107 PUSHs(sv = sv_newmortal());
5109 if (which == OP_GNBYNAME)
5110 sv_setiv(sv, (IV)nent->n_net);
5112 sv_setpv(sv, nent->n_name);
5118 mPUSHs(newSVpv(nent->n_name, 0));
5119 PUSHs(space_join_names_mortal(nent->n_aliases));
5120 mPUSHi(nent->n_addrtype);
5121 mPUSHi(nent->n_net);
5126 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5131 /* also used for: pp_gpbyname() pp_gpbynumber() */
5135 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
5137 I32 which = PL_op->op_type;
5139 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
5140 struct protoent *getprotobyname(Netdb_name_t);
5141 struct protoent *getprotobynumber(int);
5142 struct protoent *getprotoent(void);
5144 struct protoent *pent;
5146 if (which == OP_GPBYNAME) {
5147 #ifdef HAS_GETPROTOBYNAME
5148 const char* const name = POPpbytex;
5149 pent = PerlSock_getprotobyname(name);
5151 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
5154 else if (which == OP_GPBYNUMBER) {
5155 #ifdef HAS_GETPROTOBYNUMBER
5156 const int number = POPi;
5157 pent = PerlSock_getprotobynumber(number);
5159 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
5163 #ifdef HAS_GETPROTOENT
5164 pent = PerlSock_getprotoent();
5166 DIE(aTHX_ PL_no_sock_func, "getprotoent");
5170 if (GIMME_V != G_ARRAY) {
5171 PUSHs(sv = sv_newmortal());
5173 if (which == OP_GPBYNAME)
5174 sv_setiv(sv, (IV)pent->p_proto);
5176 sv_setpv(sv, pent->p_name);
5182 mPUSHs(newSVpv(pent->p_name, 0));
5183 PUSHs(space_join_names_mortal(pent->p_aliases));
5184 mPUSHi(pent->p_proto);
5189 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5194 /* also used for: pp_gsbyname() pp_gsbyport() */
5198 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
5200 I32 which = PL_op->op_type;
5202 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
5203 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
5204 struct servent *getservbyport(int, Netdb_name_t);
5205 struct servent *getservent(void);
5207 struct servent *sent;
5209 if (which == OP_GSBYNAME) {
5210 #ifdef HAS_GETSERVBYNAME
5211 const char * const proto = POPpbytex;
5212 const char * const name = POPpbytex;
5213 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5215 DIE(aTHX_ PL_no_sock_func, "getservbyname");
5218 else if (which == OP_GSBYPORT) {
5219 #ifdef HAS_GETSERVBYPORT
5220 const char * const proto = POPpbytex;
5221 unsigned short port = (unsigned short)POPu;
5222 port = PerlSock_htons(port);
5223 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5225 DIE(aTHX_ PL_no_sock_func, "getservbyport");
5229 #ifdef HAS_GETSERVENT
5230 sent = PerlSock_getservent();
5232 DIE(aTHX_ PL_no_sock_func, "getservent");
5236 if (GIMME_V != G_ARRAY) {
5237 PUSHs(sv = sv_newmortal());
5239 if (which == OP_GSBYNAME) {
5240 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5243 sv_setpv(sv, sent->s_name);
5249 mPUSHs(newSVpv(sent->s_name, 0));
5250 PUSHs(space_join_names_mortal(sent->s_aliases));
5251 mPUSHi(PerlSock_ntohs(sent->s_port));
5252 mPUSHs(newSVpv(sent->s_proto, 0));
5257 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5262 /* also used for: pp_snetent() pp_sprotoent() pp_sservent() */
5267 const int stayopen = TOPi;
5268 switch(PL_op->op_type) {
5270 #ifdef HAS_SETHOSTENT
5271 PerlSock_sethostent(stayopen);
5273 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5276 #ifdef HAS_SETNETENT
5278 PerlSock_setnetent(stayopen);
5280 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5284 #ifdef HAS_SETPROTOENT
5285 PerlSock_setprotoent(stayopen);
5287 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5291 #ifdef HAS_SETSERVENT
5292 PerlSock_setservent(stayopen);
5294 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5302 /* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent()
5303 * pp_eservent() pp_sgrent() pp_spwent() */
5308 switch(PL_op->op_type) {
5310 #ifdef HAS_ENDHOSTENT
5311 PerlSock_endhostent();
5313 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5317 #ifdef HAS_ENDNETENT
5318 PerlSock_endnetent();
5320 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5324 #ifdef HAS_ENDPROTOENT
5325 PerlSock_endprotoent();
5327 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5331 #ifdef HAS_ENDSERVENT
5332 PerlSock_endservent();
5334 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5338 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5341 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5345 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5348 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5352 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5355 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5359 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5362 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5371 /* also used for: pp_gpwnam() pp_gpwuid() */
5377 I32 which = PL_op->op_type;
5379 struct passwd *pwent = NULL;
5381 * We currently support only the SysV getsp* shadow password interface.
5382 * The interface is declared in <shadow.h> and often one needs to link
5383 * with -lsecurity or some such.
5384 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5387 * AIX getpwnam() is clever enough to return the encrypted password
5388 * only if the caller (euid?) is root.
5390 * There are at least three other shadow password APIs. Many platforms
5391 * seem to contain more than one interface for accessing the shadow
5392 * password databases, possibly for compatibility reasons.
5393 * The getsp*() is by far he simplest one, the other two interfaces
5394 * are much more complicated, but also very similar to each other.
5399 * struct pr_passwd *getprpw*();
5400 * The password is in
5401 * char getprpw*(...).ufld.fd_encrypt[]
5402 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5407 * struct es_passwd *getespw*();
5408 * The password is in
5409 * char *(getespw*(...).ufld.fd_encrypt)
5410 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5413 * struct userpw *getuserpw();
5414 * The password is in
5415 * char *(getuserpw(...)).spw_upw_passwd
5416 * (but the de facto standard getpwnam() should work okay)
5418 * Mention I_PROT here so that Configure probes for it.
5420 * In HP-UX for getprpw*() the manual page claims that one should include
5421 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5422 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5423 * and pp_sys.c already includes <shadow.h> if there is such.
5425 * Note that <sys/security.h> is already probed for, but currently
5426 * it is only included in special cases.
5428 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5429 * be preferred interface, even though also the getprpw*() interface
5430 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5431 * One also needs to call set_auth_parameters() in main() before
5432 * doing anything else, whether one is using getespw*() or getprpw*().
5434 * Note that accessing the shadow databases can be magnitudes
5435 * slower than accessing the standard databases.
5440 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5441 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5442 * the pw_comment is left uninitialized. */
5443 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5449 const char* const name = POPpbytex;
5450 pwent = getpwnam(name);
5456 pwent = getpwuid(uid);
5460 # ifdef HAS_GETPWENT
5462 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5463 if (pwent) pwent = getpwnam(pwent->pw_name);
5466 DIE(aTHX_ PL_no_func, "getpwent");
5472 if (GIMME_V != G_ARRAY) {
5473 PUSHs(sv = sv_newmortal());
5475 if (which == OP_GPWNAM)
5476 sv_setuid(sv, pwent->pw_uid);
5478 sv_setpv(sv, pwent->pw_name);
5484 mPUSHs(newSVpv(pwent->pw_name, 0));
5488 /* If we have getspnam(), we try to dig up the shadow
5489 * password. If we are underprivileged, the shadow
5490 * interface will set the errno to EACCES or similar,
5491 * and return a null pointer. If this happens, we will
5492 * use the dummy password (usually "*" or "x") from the
5493 * standard password database.
5495 * In theory we could skip the shadow call completely
5496 * if euid != 0 but in practice we cannot know which
5497 * security measures are guarding the shadow databases
5498 * on a random platform.
5500 * Resist the urge to use additional shadow interfaces.
5501 * Divert the urge to writing an extension instead.
5504 /* Some AIX setups falsely(?) detect some getspnam(), which
5505 * has a different API than the Solaris/IRIX one. */
5506 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5509 const struct spwd * const spwent = getspnam(pwent->pw_name);
5510 /* Save and restore errno so that
5511 * underprivileged attempts seem
5512 * to have never made the unsuccessful
5513 * attempt to retrieve the shadow password. */
5515 if (spwent && spwent->sp_pwdp)
5516 sv_setpv(sv, spwent->sp_pwdp);
5520 if (!SvPOK(sv)) /* Use the standard password, then. */
5521 sv_setpv(sv, pwent->pw_passwd);
5524 /* passwd is tainted because user himself can diddle with it.
5525 * admittedly not much and in a very limited way, but nevertheless. */
5528 sv_setuid(PUSHmortal, pwent->pw_uid);
5529 sv_setgid(PUSHmortal, pwent->pw_gid);
5531 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5532 * because of the poor interface of the Perl getpw*(),
5533 * not because there's some standard/convention saying so.
5534 * A better interface would have been to return a hash,
5535 * but we are accursed by our history, alas. --jhi. */
5537 mPUSHi(pwent->pw_change);
5540 mPUSHi(pwent->pw_quota);
5543 mPUSHs(newSVpv(pwent->pw_age, 0));
5545 /* I think that you can never get this compiled, but just in case. */
5546 PUSHs(sv_mortalcopy(&PL_sv_no));
5551 /* pw_class and pw_comment are mutually exclusive--.
5552 * see the above note for pw_change, pw_quota, and pw_age. */
5554 mPUSHs(newSVpv(pwent->pw_class, 0));
5557 mPUSHs(newSVpv(pwent->pw_comment, 0));
5559 /* I think that you can never get this compiled, but just in case. */
5560 PUSHs(sv_mortalcopy(&PL_sv_no));
5565 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5567 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5569 /* pw_gecos is tainted because user himself can diddle with it. */
5572 mPUSHs(newSVpv(pwent->pw_dir, 0));
5574 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5575 /* pw_shell is tainted because user himself can diddle with it. */
5579 mPUSHi(pwent->pw_expire);
5584 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5589 /* also used for: pp_ggrgid() pp_ggrnam() */
5595 const I32 which = PL_op->op_type;
5596 const struct group *grent;
5598 if (which == OP_GGRNAM) {
5599 const char* const name = POPpbytex;
5600 grent = (const struct group *)getgrnam(name);
5602 else if (which == OP_GGRGID) {
5604 const Gid_t gid = POPu;
5605 #elif Gid_t_sign == -1
5606 const Gid_t gid = POPi;
5608 # error "Unexpected Gid_t_sign"
5610 grent = (const struct group *)getgrgid(gid);
5614 grent = (struct group *)getgrent();
5616 DIE(aTHX_ PL_no_func, "getgrent");
5620 if (GIMME_V != G_ARRAY) {
5621 SV * const sv = sv_newmortal();
5625 if (which == OP_GGRNAM)
5626 sv_setgid(sv, grent->gr_gid);
5628 sv_setpv(sv, grent->gr_name);
5634 mPUSHs(newSVpv(grent->gr_name, 0));
5637 mPUSHs(newSVpv(grent->gr_passwd, 0));
5639 PUSHs(sv_mortalcopy(&PL_sv_no));
5642 sv_setgid(PUSHmortal, grent->gr_gid);
5644 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5645 /* In UNICOS/mk (_CRAYMPP) the multithreading
5646 * versions (getgrnam_r, getgrgid_r)
5647 * seem to return an illegal pointer
5648 * as the group members list, gr_mem.
5649 * getgrent() doesn't even have a _r version
5650 * but the gr_mem is poisonous anyway.
5651 * So yes, you cannot get the list of group
5652 * members if building multithreaded in UNICOS/mk. */
5653 PUSHs(space_join_names_mortal(grent->gr_mem));
5659 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5669 if (!(tmps = PerlProc_getlogin()))
5671 sv_setpv_mg(TARG, tmps);
5675 DIE(aTHX_ PL_no_func, "getlogin");
5679 /* Miscellaneous. */
5684 dSP; dMARK; dORIGMARK; dTARGET;
5685 I32 items = SP - MARK;
5686 unsigned long a[20];
5691 while (++MARK <= SP) {
5692 if (SvTAINTED(*MARK)) {
5698 TAINT_PROPER("syscall");
5701 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5702 * or where sizeof(long) != sizeof(char*). But such machines will
5703 * not likely have syscall implemented either, so who cares?
5705 while (++MARK <= SP) {
5706 if (SvNIOK(*MARK) || !i)
5707 a[i++] = SvIV(*MARK);
5708 else if (*MARK == &PL_sv_undef)
5711 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5717 DIE(aTHX_ "Too many args to syscall");
5719 DIE(aTHX_ "Too few args to syscall");
5721 retval = syscall(a[0]);
5724 retval = syscall(a[0],a[1]);
5727 retval = syscall(a[0],a[1],a[2]);
5730 retval = syscall(a[0],a[1],a[2],a[3]);
5733 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5736 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5739 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5742 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5749 DIE(aTHX_ PL_no_func, "syscall");
5753 #ifdef FCNTL_EMULATE_FLOCK
5755 /* XXX Emulate flock() with fcntl().
5756 What's really needed is a good file locking module.
5760 fcntl_emulate_flock(int fd, int operation)
5765 switch (operation & ~LOCK_NB) {
5767 flock.l_type = F_RDLCK;
5770 flock.l_type = F_WRLCK;
5773 flock.l_type = F_UNLCK;
5779 flock.l_whence = SEEK_SET;
5780 flock.l_start = flock.l_len = (Off_t)0;
5782 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5783 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5784 errno = EWOULDBLOCK;
5788 #endif /* FCNTL_EMULATE_FLOCK */
5790 #ifdef LOCKF_EMULATE_FLOCK
5792 /* XXX Emulate flock() with lockf(). This is just to increase
5793 portability of scripts. The calls are not completely
5794 interchangeable. What's really needed is a good file
5798 /* The lockf() constants might have been defined in <unistd.h>.
5799 Unfortunately, <unistd.h> causes troubles on some mixed
5800 (BSD/POSIX) systems, such as SunOS 4.1.3.
5802 Further, the lockf() constants aren't POSIX, so they might not be
5803 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5804 just stick in the SVID values and be done with it. Sigh.
5808 # define F_ULOCK 0 /* Unlock a previously locked region */
5811 # define F_LOCK 1 /* Lock a region for exclusive use */
5814 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5817 # define F_TEST 3 /* Test a region for other processes locks */
5821 lockf_emulate_flock(int fd, int operation)
5827 /* flock locks entire file so for lockf we need to do the same */
5828 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5829 if (pos > 0) /* is seekable and needs to be repositioned */
5830 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5831 pos = -1; /* seek failed, so don't seek back afterwards */
5834 switch (operation) {
5836 /* LOCK_SH - get a shared lock */
5838 /* LOCK_EX - get an exclusive lock */
5840 i = lockf (fd, F_LOCK, 0);
5843 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5844 case LOCK_SH|LOCK_NB:
5845 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5846 case LOCK_EX|LOCK_NB:
5847 i = lockf (fd, F_TLOCK, 0);
5849 if ((errno == EAGAIN) || (errno == EACCES))
5850 errno = EWOULDBLOCK;
5853 /* LOCK_UN - unlock (non-blocking is a no-op) */
5855 case LOCK_UN|LOCK_NB:
5856 i = lockf (fd, F_ULOCK, 0);
5859 /* Default - can't decipher operation */
5866 if (pos > 0) /* need to restore position of the handle */
5867 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5872 #endif /* LOCKF_EMULATE_FLOCK */
5875 * ex: set ts=8 sts=4 sw=4 et: