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
36 /* Shadow password support for solaris - pdo@cs.umd.edu
37 * Not just Solaris: at least HP-UX, IRIX, Linux.
38 * The API is from SysV.
40 * There are at least two more shadow interfaces,
41 * see the comments in pp_gpwent().
45 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
46 * and another MAXINT from "perl.h" <- <sys/param.h>. */
53 # include <sys/resource.h>
62 # include <sys/select.h>
66 /* XXX Configure test needed.
67 h_errno might not be a simple 'int', especially for multi-threaded
68 applications, see "extern int errno in perl.h". Creating such
69 a test requires taking into account the differences between
70 compiling multithreaded and singlethreaded ($ccflags et al).
71 HOST_NOT_FOUND is typically defined in <netdb.h>.
73 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
82 struct passwd *getpwnam (char *);
83 struct passwd *getpwuid (Uid_t);
88 struct passwd *getpwent (void);
89 #elif defined (VMS) && defined (my_getpwent)
90 struct passwd *Perl_my_getpwent (pTHX);
99 struct group *getgrnam (char *);
100 struct group *getgrgid (Gid_t);
104 struct group *getgrent (void);
110 # if defined(_MSC_VER) || defined(__MINGW32__)
111 # include <sys/utime.h>
118 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
121 # define my_chsize PerlLIO_chsize
124 # define my_chsize PerlLIO_chsize
126 I32 my_chsize(int fd, Off_t length);
132 #else /* no flock() */
134 /* fcntl.h might not have been included, even if it exists, because
135 the current Configure only sets I_FCNTL if it's needed to pick up
136 the *_OK constants. Make sure it has been included before testing
137 the fcntl() locking constants. */
138 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
142 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
143 # define FLOCK fcntl_emulate_flock
144 # define FCNTL_EMULATE_FLOCK
145 # else /* no flock() or fcntl(F_SETLK,...) */
147 # define FLOCK lockf_emulate_flock
148 # define LOCKF_EMULATE_FLOCK
150 # endif /* no flock() or fcntl(F_SETLK,...) */
153 static int FLOCK (int, int);
156 * These are the flock() constants. Since this sytems doesn't have
157 * flock(), the values of the constants are probably not available.
171 # endif /* emulating flock() */
173 #endif /* no flock() */
176 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
178 #if defined(I_SYS_ACCESS) && !defined(R_OK)
179 # include <sys/access.h>
182 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
183 # define FD_CLOEXEC 1 /* NeXT needs this */
189 /* Missing protos on LynxOS */
190 void sethostent(int);
191 void endhostent(void);
193 void endnetent(void);
194 void setprotoent(int);
195 void endprotoent(void);
196 void setservent(int);
197 void endservent(void);
200 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
202 /* F_OK unused: if stat() cannot find it... */
204 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
205 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
206 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
209 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
210 # ifdef I_SYS_SECURITY
211 # include <sys/security.h>
215 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
218 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
222 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
224 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
228 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
229 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
230 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
233 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
235 const Uid_t ruid = getuid();
236 const Uid_t euid = geteuid();
237 const Gid_t rgid = getgid();
238 const Gid_t egid = getegid();
241 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
242 Perl_croak(aTHX_ "switching effective uid is not implemented");
245 if (setreuid(euid, ruid))
248 if (setresuid(euid, ruid, (Uid_t)-1))
251 /* diag_listed_as: entering effective %s failed */
252 Perl_croak(aTHX_ "entering effective uid failed");
255 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
256 Perl_croak(aTHX_ "switching effective gid is not implemented");
259 if (setregid(egid, rgid))
262 if (setresgid(egid, rgid, (Gid_t)-1))
265 /* diag_listed_as: entering effective %s failed */
266 Perl_croak(aTHX_ "entering effective gid failed");
269 res = access(path, mode);
272 if (setreuid(ruid, euid))
275 if (setresuid(ruid, euid, (Uid_t)-1))
278 /* diag_listed_as: leaving effective %s failed */
279 Perl_croak(aTHX_ "leaving effective uid failed");
282 if (setregid(rgid, egid))
285 if (setresgid(rgid, egid, (Gid_t)-1))
288 /* diag_listed_as: leaving effective %s failed */
289 Perl_croak(aTHX_ "leaving effective gid failed");
293 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
300 const char * const tmps = POPpconstx;
301 const I32 gimme = GIMME_V;
302 const char *mode = "r";
305 if (PL_op->op_private & OPpOPEN_IN_RAW)
307 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
309 fp = PerlProc_popen(tmps, mode);
311 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
313 PerlIO_apply_layers(aTHX_ fp,mode,type);
315 if (gimme == G_VOID) {
317 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
320 else if (gimme == G_SCALAR) {
321 ENTER_with_name("backtick");
323 PL_rs = &PL_sv_undef;
324 sv_setpvs(TARG, ""); /* note that this preserves previous buffer */
325 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
327 LEAVE_with_name("backtick");
333 SV * const sv = newSV(79);
334 if (sv_gets(sv, fp, 0) == NULL) {
339 if (SvLEN(sv) - SvCUR(sv) > 20) {
340 SvPV_shrink_to_cur(sv);
345 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
346 TAINT; /* "I believe that this is not gratuitous!" */
349 STATUS_NATIVE_CHILD_SET(-1);
350 if (gimme == G_SCALAR)
362 GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs;
366 /* make a copy of the pattern if it is gmagical, to ensure that magic
367 * is called once and only once */
368 if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs));
370 tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL));
372 if (PL_op->op_flags & OPf_SPECIAL) {
373 /* call Perl-level glob function instead. Stack args are:
375 * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
384 /* Note that we only ever get here if File::Glob fails to load
385 * without at the same time croaking, for some reason, or if
386 * perl was built with PERL_EXTERNAL_GLOB */
388 ENTER_with_name("glob");
393 * The external globbing program may use things we can't control,
394 * so for security reasons we must assume the worst.
397 taint_proper(PL_no_security, "glob");
401 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
404 SAVESPTR(PL_rs); /* This is not permanent, either. */
405 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
408 *SvPVX(PL_rs) = '\n';
412 result = do_readline();
413 LEAVE_with_name("glob");
420 PL_last_in_gv = cGVOP_gv;
421 return do_readline();
431 do_join(TARG, &PL_sv_no, MARK, SP);
435 else if (SP == MARK) {
442 if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
445 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
446 /* well-formed exception supplied */
449 SV * const errsv = ERRSV;
452 if (SvGMAGICAL(errsv)) {
453 exsv = sv_newmortal();
454 sv_setsv_nomg(exsv, errsv);
458 else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) {
459 exsv = sv_newmortal();
460 sv_setsv_nomg(exsv, errsv);
461 sv_catpvs(exsv, "\t...caught");
464 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
467 if (SvROK(exsv) && !PL_warnhook)
468 Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
480 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
482 if (SP - MARK != 1) {
484 do_join(TARG, &PL_sv_no, MARK, SP);
492 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
493 /* well-formed exception supplied */
496 SV * const errsv = ERRSV;
500 if (sv_isobject(exsv)) {
501 HV * const stash = SvSTASH(SvRV(exsv));
502 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
504 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
505 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
512 call_sv(MUTABLE_SV(GvCV(gv)),
513 G_SCALAR|G_EVAL|G_KEEPERR);
514 exsv = sv_mortalcopy(*PL_stack_sp--);
518 else if (SvPOK(errsv) && SvCUR(errsv)) {
519 exsv = sv_mortalcopy(errsv);
520 sv_catpvs(exsv, "\t...propagated");
523 exsv = newSVpvs_flags("Died", SVs_TEMP);
532 Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv,
533 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 assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
542 assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
543 assert((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(SP, argc+1); /* object + args */
549 PUSHs(SvTIED_obj(sv, mg));
550 if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
551 Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
555 const U32 mortalize_not_needed
556 = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
558 va_start(args, argc);
560 SV *const arg = va_arg(args, SV *);
561 if(mortalize_not_needed)
570 ENTER_with_name("call_tied_method");
571 if (flags & TIED_METHOD_SAY) {
572 /* local $\ = "\n" */
573 SAVEGENERICSV(PL_ors_sv);
574 PL_ors_sv = newSVpvs("\n");
576 ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED);
581 if (ret_args) { /* copy results back to original stack */
582 EXTEND(sp, ret_args);
583 Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
587 LEAVE_with_name("call_tied_method");
591 #define tied_method0(a,b,c,d) \
592 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
593 #define tied_method1(a,b,c,d,e) \
594 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
595 #define tied_method2(a,b,c,d,e,f) \
596 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
609 GV * const gv = MUTABLE_GV(*++MARK);
611 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
612 DIE(aTHX_ PL_no_usym, "filehandle");
614 if ((io = GvIOp(gv))) {
616 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
619 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
620 "Opening dirhandle %"HEKf" also as a file",
621 HEKfARG(GvENAME_HEK(gv)));
623 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
625 /* Method's args are same as ours ... */
626 /* ... except handle is replaced by the object */
627 return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg,
628 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
640 tmps = SvPV_const(sv, len);
641 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
644 PUSHi( (I32)PL_forkprocess );
645 else if (PL_forkprocess == 0) /* we are a new child */
656 MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
662 IO * const io = GvIO(gv);
664 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
666 return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg);
670 PUSHs(boolSV(do_close(gv, TRUE)));
683 GV * const wgv = MUTABLE_GV(POPs);
684 GV * const rgv = MUTABLE_GV(POPs);
686 assert (isGV_with_GP(rgv));
687 assert (isGV_with_GP(wgv));
690 do_close(rgv, FALSE);
694 do_close(wgv, FALSE);
696 if (PerlProc_pipe(fd) < 0)
699 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
700 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
701 IoOFP(rstio) = IoIFP(rstio);
702 IoIFP(wstio) = IoOFP(wstio);
703 IoTYPE(rstio) = IoTYPE_RDONLY;
704 IoTYPE(wstio) = IoTYPE_WRONLY;
706 if (!IoIFP(rstio) || !IoOFP(wstio)) {
708 PerlIO_close(IoIFP(rstio));
710 PerlLIO_close(fd[0]);
712 PerlIO_close(IoOFP(wstio));
714 PerlLIO_close(fd[1]);
717 #if defined(HAS_FCNTL) && defined(F_SETFD)
718 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
719 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
726 DIE(aTHX_ PL_no_func, "pipe");
740 gv = MUTABLE_GV(POPs);
744 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
746 return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg);
749 if (!io || !(fp = IoIFP(io))) {
750 /* Can't do this because people seem to do things like
751 defined(fileno($foo)) to check whether $foo is a valid fh.
758 PUSHi(PerlIO_fileno(fp));
770 if (MAXARG < 1 || (!TOPs && !POPs)) {
771 anum = PerlLIO_umask(022);
772 /* setting it to 022 between the two calls to umask avoids
773 * to have a window where the umask is set to 0 -- meaning
774 * that another thread could create world-writeable files. */
776 (void)PerlLIO_umask(anum);
779 anum = PerlLIO_umask(POPi);
780 TAINT_PROPER("umask");
783 /* Only DIE if trying to restrict permissions on "user" (self).
784 * Otherwise it's harmless and more useful to just return undef
785 * since 'group' and 'other' concepts probably don't exist here. */
786 if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
787 DIE(aTHX_ "umask not implemented");
788 XPUSHs(&PL_sv_undef);
807 gv = MUTABLE_GV(POPs);
811 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
813 /* This takes advantage of the implementation of the varargs
814 function, which I don't think that the optimiser will be able to
815 figure out. Although, as it's a static function, in theory it
817 return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg,
818 G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
819 discp ? 1 : 0, discp);
823 if (!io || !(fp = IoIFP(io))) {
825 SETERRNO(EBADF,RMS_IFI);
832 const char *d = NULL;
835 d = SvPV_const(discp, len);
836 mode = mode_from_discipline(d, len);
837 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
838 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
839 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
860 const I32 markoff = MARK - PL_stack_base;
861 const char *methname;
862 int how = PERL_MAGIC_tied;
866 switch(SvTYPE(varsv)) {
870 methname = "TIEHASH";
871 if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
872 HvLAZYDEL_off(varsv);
873 hv_free_ent((HV *)varsv, entry);
875 HvEITER_set(MUTABLE_HV(varsv), 0);
879 methname = "TIEARRAY";
880 if (!AvREAL(varsv)) {
882 Perl_croak(aTHX_ "Cannot tie unreifiable array");
883 av_clear((AV *)varsv);
890 if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
891 methname = "TIEHANDLE";
892 how = PERL_MAGIC_tiedscalar;
893 /* For tied filehandles, we apply tiedscalar magic to the IO
894 slot of the GP rather than the GV itself. AMS 20010812 */
896 GvIOp(varsv) = newIO();
897 varsv = MUTABLE_SV(GvIOp(varsv));
900 if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
901 vivify_defelem(varsv);
902 varsv = LvTARG(varsv);
906 methname = "TIESCALAR";
907 how = PERL_MAGIC_tiedscalar;
911 if (sv_isobject(*MARK)) { /* Calls GET magic. */
912 ENTER_with_name("call_TIE");
913 PUSHSTACKi(PERLSI_MAGIC);
915 EXTEND(SP,(I32)items);
919 call_method(methname, G_SCALAR);
922 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
923 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
924 * wrong error message, and worse case, supreme action at a distance.
925 * (Sorry obfuscation writers. You're not going to be given this one.)
927 stash = gv_stashsv(*MARK, 0);
928 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
929 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
930 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
932 ENTER_with_name("call_TIE");
933 PUSHSTACKi(PERLSI_MAGIC);
935 EXTEND(SP,(I32)items);
939 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
945 if (sv_isobject(sv)) {
946 sv_unmagic(varsv, how);
947 /* Croak if a self-tie on an aggregate is attempted. */
948 if (varsv == SvRV(sv) &&
949 (SvTYPE(varsv) == SVt_PVAV ||
950 SvTYPE(varsv) == SVt_PVHV))
952 "Self-ties of arrays and hashes are not supported");
953 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
955 LEAVE_with_name("call_TIE");
956 SP = PL_stack_base + markoff;
966 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
967 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
969 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
972 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
973 !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
975 if ((mg = SvTIED_mg(sv, how))) {
976 SV * const obj = SvRV(SvTIED_obj(sv, mg));
978 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
980 if (gv && isGV(gv) && (cv = GvCV(gv))) {
982 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
983 mXPUSHi(SvREFCNT(obj) - 1);
985 ENTER_with_name("call_UNTIE");
986 call_sv(MUTABLE_SV(cv), G_VOID);
987 LEAVE_with_name("call_UNTIE");
990 else if (mg && SvREFCNT(obj) > 1) {
991 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
992 "untie attempted while %"UVuf" inner references still exist",
993 (UV)SvREFCNT(obj) - 1 ) ;
997 sv_unmagic(sv, how) ;
1007 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1008 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1010 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1013 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1014 !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
1016 if ((mg = SvTIED_mg(sv, how))) {
1017 PUSHs(SvTIED_obj(sv, mg));
1030 HV * const hv = MUTABLE_HV(POPs);
1031 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1032 stash = gv_stashsv(sv, 0);
1033 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1035 require_pv("AnyDBM_File.pm");
1037 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1038 DIE(aTHX_ "No dbm on this machine");
1048 mPUSHu(O_RDWR|O_CREAT);
1052 if (!SvOK(right)) right = &PL_sv_no;
1056 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1059 if (!sv_isobject(TOPs)) {
1067 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1071 if (sv_isobject(TOPs)) {
1072 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1073 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1090 struct timeval timebuf;
1091 struct timeval *tbuf = &timebuf;
1094 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1099 # if BYTEORDER & 0xf0000
1100 # define ORDERBYTE (0x88888888 - BYTEORDER)
1102 # define ORDERBYTE (0x4444 - BYTEORDER)
1108 for (i = 1; i <= 3; i++) {
1109 SV * const sv = SP[i];
1113 if (SvREADONLY(sv)) {
1114 if (!(SvPOK(sv) && SvCUR(sv) == 0))
1115 Perl_croak_no_modify();
1117 else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
1120 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1121 "Non-string passed as bitmask");
1122 SvPV_force_nomg_nolen(sv); /* force string conversion */
1129 /* little endians can use vecs directly */
1130 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1137 masksize = NFDBITS / NBBY;
1139 masksize = sizeof(long); /* documented int, everyone seems to use long */
1141 Zero(&fd_sets[0], 4, char*);
1144 # if SELECT_MIN_BITS == 1
1145 growsize = sizeof(fd_set);
1147 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1148 # undef SELECT_MIN_BITS
1149 # define SELECT_MIN_BITS __FD_SETSIZE
1151 /* If SELECT_MIN_BITS is greater than one we most probably will want
1152 * to align the sizes with SELECT_MIN_BITS/8 because for example
1153 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1154 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1155 * on (sets/tests/clears bits) is 32 bits. */
1156 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1162 value = SvNV_nomg(sv);
1165 timebuf.tv_sec = (long)value;
1166 value -= (NV)timebuf.tv_sec;
1167 timebuf.tv_usec = (long)(value * 1000000.0);
1172 for (i = 1; i <= 3; i++) {
1174 if (!SvOK(sv) || SvCUR(sv) == 0) {
1181 Sv_Grow(sv, growsize);
1185 while (++j <= growsize) {
1189 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1191 Newx(fd_sets[i], growsize, char);
1192 for (offset = 0; offset < growsize; offset += masksize) {
1193 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1194 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1197 fd_sets[i] = SvPVX(sv);
1201 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1202 /* Can't make just the (void*) conditional because that would be
1203 * cpp #if within cpp macro, and not all compilers like that. */
1204 nfound = PerlSock_select(
1206 (Select_fd_set_t) fd_sets[1],
1207 (Select_fd_set_t) fd_sets[2],
1208 (Select_fd_set_t) fd_sets[3],
1209 (void*) tbuf); /* Workaround for compiler bug. */
1211 nfound = PerlSock_select(
1213 (Select_fd_set_t) fd_sets[1],
1214 (Select_fd_set_t) fd_sets[2],
1215 (Select_fd_set_t) fd_sets[3],
1218 for (i = 1; i <= 3; i++) {
1221 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1223 for (offset = 0; offset < growsize; offset += masksize) {
1224 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1225 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1227 Safefree(fd_sets[i]);
1234 if (GIMME == G_ARRAY && tbuf) {
1235 value = (NV)(timebuf.tv_sec) +
1236 (NV)(timebuf.tv_usec) / 1000000.0;
1241 DIE(aTHX_ "select not implemented");
1246 =for apidoc setdefout
1248 Sets PL_defoutgv, the default file handle for output, to the passed in
1249 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1250 count of the passed in typeglob is increased by one, and the reference count
1251 of the typeglob that PL_defoutgv points to is decreased by one.
1257 Perl_setdefout(pTHX_ GV *gv)
1260 PERL_ARGS_ASSERT_SETDEFOUT;
1261 SvREFCNT_inc_simple_void_NN(gv);
1262 SvREFCNT_dec(PL_defoutgv);
1270 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1271 GV * egv = GvEGVx(PL_defoutgv);
1276 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1277 gvp = hv && HvENAME(hv)
1278 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1280 if (gvp && *gvp == egv) {
1281 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1285 mXPUSHs(newRV(MUTABLE_SV(egv)));
1289 if (!GvIO(newdefout))
1290 gv_IOadd(newdefout);
1291 setdefout(newdefout);
1301 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1302 IO *const io = GvIO(gv);
1308 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1310 const U32 gimme = GIMME_V;
1311 Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1312 if (gimme == G_SCALAR) {
1314 SvSetMagicSV_nosteal(TARG, TOPs);
1319 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1320 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1322 SETERRNO(EBADF,RMS_IFI);
1326 sv_setpvs(TARG, " ");
1327 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1328 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1329 /* Find out how many bytes the char needs */
1330 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1333 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1334 SvCUR_set(TARG,1+len);
1338 else SvUTF8_off(TARG);
1344 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1348 const I32 gimme = GIMME_V;
1350 PERL_ARGS_ASSERT_DOFORM;
1353 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1358 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1359 PUSHFORMAT(cx, retop);
1360 if (CvDEPTH(cv) >= 2) {
1361 PERL_STACK_OVERFLOW_CHECK();
1362 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1365 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1367 setdefout(gv); /* locally select filehandle so $% et al work */
1386 gv = MUTABLE_GV(POPs);
1403 tmpsv = sv_newmortal();
1404 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1405 DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
1407 IoFLAGS(io) &= ~IOf_DIDTOP;
1408 RETURNOP(doform(cv,gv,PL_op->op_next));
1414 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1415 IO * const io = GvIOp(gv);
1423 if (!io || !(ofp = IoOFP(io)))
1426 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1427 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1429 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1430 PL_formtarget != PL_toptarget)
1434 if (!IoTOP_GV(io)) {
1437 if (!IoTOP_NAME(io)) {
1439 if (!IoFMT_NAME(io))
1440 IoFMT_NAME(io) = savepv(GvNAME(gv));
1441 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1442 HEKfARG(GvNAME_HEK(gv))));
1443 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1444 if ((topgv && GvFORM(topgv)) ||
1445 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1446 IoTOP_NAME(io) = savesvpv(topname);
1448 IoTOP_NAME(io) = savepvs("top");
1450 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1451 if (!topgv || !GvFORM(topgv)) {
1452 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1455 IoTOP_GV(io) = topgv;
1457 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1458 I32 lines = IoLINES_LEFT(io);
1459 const char *s = SvPVX_const(PL_formtarget);
1460 if (lines <= 0) /* Yow, header didn't even fit!!! */
1462 while (lines-- > 0) {
1463 s = strchr(s, '\n');
1469 const STRLEN save = SvCUR(PL_formtarget);
1470 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1471 do_print(PL_formtarget, ofp);
1472 SvCUR_set(PL_formtarget, save);
1473 sv_chop(PL_formtarget, s);
1474 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1477 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1478 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1479 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1481 PL_formtarget = PL_toptarget;
1482 IoFLAGS(io) |= IOf_DIDTOP;
1484 assert(fgv); /* IoTOP_GV(io) should have been set above */
1487 SV * const sv = sv_newmortal();
1488 gv_efullname4(sv, fgv, NULL, FALSE);
1489 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1491 return doform(cv, gv, PL_op);
1495 POPBLOCK(cx,PL_curpm);
1496 retop = cx->blk_sub.retop;
1498 SP = newsp; /* ignore retval of formline */
1501 if (!io || !(fp = IoOFP(io))) {
1502 if (io && IoIFP(io))
1503 report_wrongway_fh(gv, '<');
1509 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1510 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1512 if (!do_print(PL_formtarget, fp))
1515 FmLINES(PL_formtarget) = 0;
1516 SvCUR_set(PL_formtarget, 0);
1517 *SvEND(PL_formtarget) = '\0';
1518 if (IoFLAGS(io) & IOf_FLUSH)
1519 (void)PerlIO_flush(fp);
1523 PL_formtarget = PL_bodytarget;
1524 PERL_UNUSED_VAR(gimme);
1530 dVAR; dSP; dMARK; dORIGMARK;
1534 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1535 IO *const io = GvIO(gv);
1537 /* Treat empty list as "" */
1538 if (MARK == SP) XPUSHs(&PL_sv_no);
1541 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1543 if (MARK == ORIGMARK) {
1546 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1549 return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1551 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1558 SETERRNO(EBADF,RMS_IFI);
1561 else if (!(fp = IoOFP(io))) {
1563 report_wrongway_fh(gv, '<');
1564 else if (ckWARN(WARN_CLOSED))
1566 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1570 SV *sv = sv_newmortal();
1571 do_sprintf(sv, SP - MARK, MARK + 1);
1572 if (!do_print(sv, fp))
1575 if (IoFLAGS(io) & IOf_FLUSH)
1576 if (PerlIO_flush(fp) == EOF)
1585 PUSHs(&PL_sv_undef);
1593 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1594 const int mode = POPi;
1595 SV * const sv = POPs;
1596 GV * const gv = MUTABLE_GV(POPs);
1599 /* Need TIEHANDLE method ? */
1600 const char * const tmps = SvPV_const(sv, len);
1601 /* FIXME? do_open should do const */
1602 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1603 IoLINES(GvIOp(gv)) = 0;
1607 PUSHs(&PL_sv_undef);
1614 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1628 bool charstart = FALSE;
1629 STRLEN charskip = 0;
1632 GV * const gv = MUTABLE_GV(*++MARK);
1633 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1634 && gv && (io = GvIO(gv)) )
1636 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1638 return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1639 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1648 sv_setpvs(bufsv, "");
1649 length = SvIVx(*++MARK);
1651 DIE(aTHX_ "Negative length");
1654 offset = SvIVx(*++MARK);
1658 if (!io || !IoIFP(io)) {
1660 SETERRNO(EBADF,RMS_IFI);
1663 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1664 buffer = SvPVutf8_force(bufsv, blen);
1665 /* UTF-8 may not have been set if they are all low bytes */
1670 buffer = SvPV_force(bufsv, blen);
1671 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1673 if (DO_UTF8(bufsv)) {
1674 blen = sv_len_utf8_nomg(bufsv);
1683 if (PL_op->op_type == OP_RECV) {
1684 Sock_size_t bufsize;
1685 char namebuf[MAXPATHLEN];
1686 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1687 bufsize = sizeof (struct sockaddr_in);
1689 bufsize = sizeof namebuf;
1691 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1695 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1696 /* 'offset' means 'flags' here */
1697 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1698 (struct sockaddr *)namebuf, &bufsize);
1701 /* MSG_TRUNC can give oversized count; quietly lose it */
1704 SvCUR_set(bufsv, count);
1705 *SvEND(bufsv) = '\0';
1706 (void)SvPOK_only(bufsv);
1710 /* This should not be marked tainted if the fp is marked clean */
1711 if (!(IoFLAGS(io) & IOf_UNTAINT))
1712 SvTAINTED_on(bufsv);
1714 #if defined(__CYGWIN__)
1715 /* recvfrom() on cygwin doesn't set bufsize at all for
1716 connected sockets, leaving us with trash in the returned
1717 name, so use the same test as the Win32 code to check if it
1718 wasn't set, and set it [perl #118843] */
1719 if (bufsize == sizeof namebuf)
1722 sv_setpvn(TARG, namebuf, bufsize);
1728 if (-offset > (SSize_t)blen)
1729 DIE(aTHX_ "Offset outside string");
1732 if (DO_UTF8(bufsv)) {
1733 /* convert offset-as-chars to offset-as-bytes */
1734 if (offset >= (SSize_t)blen)
1735 offset += SvCUR(bufsv) - blen;
1737 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1740 orig_size = SvCUR(bufsv);
1741 /* Allocating length + offset + 1 isn't perfect in the case of reading
1742 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1744 (should be 2 * length + offset + 1, or possibly something longer if
1745 PL_encoding is true) */
1746 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1747 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1748 Zero(buffer+orig_size, offset-orig_size, char);
1750 buffer = buffer + offset;
1752 read_target = bufsv;
1754 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1755 concatenate it to the current buffer. */
1757 /* Truncate the existing buffer to the start of where we will be
1759 SvCUR_set(bufsv, offset);
1761 read_target = sv_newmortal();
1762 SvUPGRADE(read_target, SVt_PV);
1763 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1766 if (PL_op->op_type == OP_SYSREAD) {
1767 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1768 if (IoTYPE(io) == IoTYPE_SOCKET) {
1769 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1775 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1781 count = PerlIO_read(IoIFP(io), buffer, length);
1782 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1783 if (count == 0 && PerlIO_error(IoIFP(io)))
1787 if (IoTYPE(io) == IoTYPE_WRONLY)
1788 report_wrongway_fh(gv, '>');
1791 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1792 *SvEND(read_target) = '\0';
1793 (void)SvPOK_only(read_target);
1794 if (fp_utf8 && !IN_BYTES) {
1795 /* Look at utf8 we got back and count the characters */
1796 const char *bend = buffer + count;
1797 while (buffer < bend) {
1799 skip = UTF8SKIP(buffer);
1802 if (buffer - charskip + skip > bend) {
1803 /* partial character - try for rest of it */
1804 length = skip - (bend-buffer);
1805 offset = bend - SvPVX_const(bufsv);
1817 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1818 provided amount read (count) was what was requested (length)
1820 if (got < wanted && count == length) {
1821 length = wanted - got;
1822 offset = bend - SvPVX_const(bufsv);
1825 /* return value is character count */
1829 else if (buffer_utf8) {
1830 /* Let svcatsv upgrade the bytes we read in to utf8.
1831 The buffer is a mortal so will be freed soon. */
1832 sv_catsv_nomg(bufsv, read_target);
1835 /* This should not be marked tainted if the fp is marked clean */
1836 if (!(IoFLAGS(io) & IOf_UNTAINT))
1837 SvTAINTED_on(bufsv);
1849 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1854 STRLEN orig_blen_bytes;
1855 const int op_type = PL_op->op_type;
1858 GV *const gv = MUTABLE_GV(*++MARK);
1859 IO *const io = GvIO(gv);
1861 if (op_type == OP_SYSWRITE && io) {
1862 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1864 if (MARK == SP - 1) {
1866 mXPUSHi(sv_len(sv));
1870 return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1871 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1881 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1883 if (io && IoIFP(io))
1884 report_wrongway_fh(gv, '<');
1887 SETERRNO(EBADF,RMS_IFI);
1891 /* Do this first to trigger any overloading. */
1892 buffer = SvPV_const(bufsv, blen);
1893 orig_blen_bytes = blen;
1894 doing_utf8 = DO_UTF8(bufsv);
1896 if (PerlIO_isutf8(IoIFP(io))) {
1897 if (!SvUTF8(bufsv)) {
1898 /* We don't modify the original scalar. */
1899 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1900 buffer = (char *) tmpbuf;
1904 else if (doing_utf8) {
1905 STRLEN tmplen = blen;
1906 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1909 buffer = (char *) tmpbuf;
1913 assert((char *)result == buffer);
1914 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1919 if (op_type == OP_SEND) {
1920 const int flags = SvIVx(*++MARK);
1923 char * const sockbuf = SvPVx(*++MARK, mlen);
1924 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1925 flags, (struct sockaddr *)sockbuf, mlen);
1929 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1935 Size_t length = 0; /* This length is in characters. */
1941 /* The SV is bytes, and we've had to upgrade it. */
1942 blen_chars = orig_blen_bytes;
1944 /* The SV really is UTF-8. */
1945 /* Don't call sv_len_utf8 on a magical or overloaded
1946 scalar, as we might get back a different result. */
1947 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
1954 length = blen_chars;
1956 #if Size_t_size > IVSIZE
1957 length = (Size_t)SvNVx(*++MARK);
1959 length = (Size_t)SvIVx(*++MARK);
1961 if ((SSize_t)length < 0) {
1963 DIE(aTHX_ "Negative length");
1968 offset = SvIVx(*++MARK);
1970 if (-offset > (IV)blen_chars) {
1972 DIE(aTHX_ "Offset outside string");
1974 offset += blen_chars;
1975 } else if (offset > (IV)blen_chars) {
1977 DIE(aTHX_ "Offset outside string");
1981 if (length > blen_chars - offset)
1982 length = blen_chars - offset;
1984 /* Here we convert length from characters to bytes. */
1985 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1986 /* Either we had to convert the SV, or the SV is magical, or
1987 the SV has overloading, in which case we can't or mustn't
1988 or mustn't call it again. */
1990 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1991 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1993 /* It's a real UTF-8 SV, and it's not going to change under
1994 us. Take advantage of any cache. */
1996 I32 len_I32 = length;
1998 /* Convert the start and end character positions to bytes.
1999 Remember that the second argument to sv_pos_u2b is relative
2001 sv_pos_u2b(bufsv, &start, &len_I32);
2008 buffer = buffer+offset;
2010 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2011 if (IoTYPE(io) == IoTYPE_SOCKET) {
2012 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
2018 /* See the note at doio.c:do_print about filesize limits. --jhi */
2019 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2028 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2031 #if Size_t_size > IVSIZE
2051 * in Perl 5.12 and later, the additional parameter is a bitmask:
2054 * 2 = eof() <- ARGV magic
2056 * I'll rely on the compiler's trace flow analysis to decide whether to
2057 * actually assign this out here, or punt it into the only block where it is
2058 * used. Doing it out here is DRY on the condition logic.
2063 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2069 if (PL_op->op_flags & OPf_SPECIAL) {
2070 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2074 gv = PL_last_in_gv; /* eof */
2082 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2083 return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2086 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2087 if (io && !IoIFP(io)) {
2088 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2090 IoFLAGS(io) &= ~IOf_START;
2091 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2093 sv_setpvs(GvSV(gv), "-");
2095 GvSV(gv) = newSVpvs("-");
2096 SvSETMAGIC(GvSV(gv));
2098 else if (!nextargv(gv))
2103 PUSHs(boolSV(do_eof(gv)));
2113 if (MAXARG != 0 && (TOPs || POPs))
2114 PL_last_in_gv = MUTABLE_GV(POPs);
2121 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2123 return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2128 SETERRNO(EBADF,RMS_IFI);
2133 #if LSEEKSIZE > IVSIZE
2134 PUSHn( do_tell(gv) );
2136 PUSHi( do_tell(gv) );
2144 const int whence = POPi;
2145 #if LSEEKSIZE > IVSIZE
2146 const Off_t offset = (Off_t)SvNVx(POPs);
2148 const Off_t offset = (Off_t)SvIVx(POPs);
2151 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2152 IO *const io = GvIO(gv);
2155 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2157 #if LSEEKSIZE > IVSIZE
2158 SV *const offset_sv = newSVnv((NV) offset);
2160 SV *const offset_sv = newSViv(offset);
2163 return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2168 if (PL_op->op_type == OP_SEEK)
2169 PUSHs(boolSV(do_seek(gv, offset, whence)));
2171 const Off_t sought = do_sysseek(gv, offset, whence);
2173 PUSHs(&PL_sv_undef);
2175 SV* const sv = sought ?
2176 #if LSEEKSIZE > IVSIZE
2181 : newSVpvn(zero_but_true, ZBTLEN);
2192 /* There seems to be no consensus on the length type of truncate()
2193 * and ftruncate(), both off_t and size_t have supporters. In
2194 * general one would think that when using large files, off_t is
2195 * at least as wide as size_t, so using an off_t should be okay. */
2196 /* XXX Configure probe for the length type of *truncate() needed XXX */
2199 #if Off_t_size > IVSIZE
2204 /* Checking for length < 0 is problematic as the type might or
2205 * might not be signed: if it is not, clever compilers will moan. */
2206 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2209 SV * const sv = POPs;
2214 if (PL_op->op_flags & OPf_SPECIAL
2215 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2216 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2223 TAINT_PROPER("truncate");
2224 if (!(fp = IoIFP(io))) {
2230 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2232 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2238 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2239 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2240 goto do_ftruncate_io;
2243 const char * const name = SvPV_nomg_const_nolen(sv);
2244 TAINT_PROPER("truncate");
2246 if (truncate(name, len) < 0)
2250 const int tmpfd = PerlLIO_open(name, O_RDWR);
2255 if (my_chsize(tmpfd, len) < 0)
2257 PerlLIO_close(tmpfd);
2266 SETERRNO(EBADF,RMS_IFI);
2274 SV * const argsv = POPs;
2275 const unsigned int func = POPu;
2277 GV * const gv = MUTABLE_GV(POPs);
2278 IO * const io = GvIOn(gv);
2284 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2288 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2291 s = SvPV_force(argsv, len);
2292 need = IOCPARM_LEN(func);
2294 s = Sv_Grow(argsv, need + 1);
2295 SvCUR_set(argsv, need);
2298 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2301 retval = SvIV(argsv);
2302 s = INT2PTR(char*,retval); /* ouch */
2305 optype = PL_op->op_type;
2306 TAINT_PROPER(PL_op_desc[optype]);
2308 if (optype == OP_IOCTL)
2310 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2312 DIE(aTHX_ "ioctl is not implemented");
2316 DIE(aTHX_ "fcntl is not implemented");
2318 #if defined(OS2) && defined(__EMX__)
2319 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2321 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2325 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2327 if (s[SvCUR(argsv)] != 17)
2328 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2330 s[SvCUR(argsv)] = 0; /* put our null back */
2331 SvSETMAGIC(argsv); /* Assume it has changed */
2340 PUSHp(zero_but_true, ZBTLEN);
2351 const int argtype = POPi;
2352 GV * const gv = MUTABLE_GV(POPs);
2353 IO *const io = GvIO(gv);
2354 PerlIO *const fp = io ? IoIFP(io) : NULL;
2356 /* XXX Looks to me like io is always NULL at this point */
2358 (void)PerlIO_flush(fp);
2359 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2364 SETERRNO(EBADF,RMS_IFI);
2369 DIE(aTHX_ PL_no_func, "flock()");
2380 const int protocol = POPi;
2381 const int type = POPi;
2382 const int domain = POPi;
2383 GV * const gv = MUTABLE_GV(POPs);
2384 IO * const io = GvIOn(gv);
2388 do_close(gv, FALSE);
2390 TAINT_PROPER("socket");
2391 fd = PerlSock_socket(domain, type, protocol);
2394 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2395 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2396 IoTYPE(io) = IoTYPE_SOCKET;
2397 if (!IoIFP(io) || !IoOFP(io)) {
2398 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2399 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2400 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2403 #if defined(HAS_FCNTL) && defined(F_SETFD)
2404 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2413 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2416 const int protocol = POPi;
2417 const int type = POPi;
2418 const int domain = POPi;
2420 GV * const gv2 = MUTABLE_GV(POPs);
2421 IO * const io2 = GvIOn(gv2);
2422 GV * const gv1 = MUTABLE_GV(POPs);
2423 IO * const io1 = GvIOn(gv1);
2426 do_close(gv1, FALSE);
2428 do_close(gv2, FALSE);
2430 TAINT_PROPER("socketpair");
2431 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2433 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2434 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2435 IoTYPE(io1) = IoTYPE_SOCKET;
2436 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2437 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2438 IoTYPE(io2) = IoTYPE_SOCKET;
2439 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2440 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2441 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2442 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2443 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2444 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2445 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2448 #if defined(HAS_FCNTL) && defined(F_SETFD)
2449 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2450 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2455 DIE(aTHX_ PL_no_sock_func, "socketpair");
2464 SV * const addrsv = POPs;
2465 /* OK, so on what platform does bind modify addr? */
2467 GV * const gv = MUTABLE_GV(POPs);
2468 IO * const io = GvIOn(gv);
2475 addr = SvPV_const(addrsv, len);
2476 op_type = PL_op->op_type;
2477 TAINT_PROPER(PL_op_desc[op_type]);
2478 if ((op_type == OP_BIND
2479 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2480 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2488 SETERRNO(EBADF,SS_IVCHAN);
2495 const int backlog = POPi;
2496 GV * const gv = MUTABLE_GV(POPs);
2497 IO * const io = GvIOn(gv);
2502 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2509 SETERRNO(EBADF,SS_IVCHAN);
2517 char namebuf[MAXPATHLEN];
2518 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2519 Sock_size_t len = sizeof (struct sockaddr_in);
2521 Sock_size_t len = sizeof namebuf;
2523 GV * const ggv = MUTABLE_GV(POPs);
2524 GV * const ngv = MUTABLE_GV(POPs);
2527 IO * const gstio = GvIO(ggv);
2528 if (!gstio || !IoIFP(gstio))
2532 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2535 /* Some platforms indicate zero length when an AF_UNIX client is
2536 * not bound. Simulate a non-zero-length sockaddr structure in
2538 namebuf[0] = 0; /* sun_len */
2539 namebuf[1] = AF_UNIX; /* sun_family */
2547 do_close(ngv, FALSE);
2548 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2549 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2550 IoTYPE(nstio) = IoTYPE_SOCKET;
2551 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2552 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2553 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2554 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2557 #if defined(HAS_FCNTL) && defined(F_SETFD)
2558 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2561 #ifdef __SCO_VERSION__
2562 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2565 PUSHp(namebuf, len);
2569 report_evil_fh(ggv);
2570 SETERRNO(EBADF,SS_IVCHAN);
2580 const int how = POPi;
2581 GV * const gv = MUTABLE_GV(POPs);
2582 IO * const io = GvIOn(gv);
2587 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2592 SETERRNO(EBADF,SS_IVCHAN);
2599 const int optype = PL_op->op_type;
2600 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2601 const unsigned int optname = (unsigned int) POPi;
2602 const unsigned int lvl = (unsigned int) POPi;
2603 GV * const gv = MUTABLE_GV(POPs);
2604 IO * const io = GvIOn(gv);
2611 fd = PerlIO_fileno(IoIFP(io));
2615 (void)SvPOK_only(sv);
2619 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2626 #if defined(__SYMBIAN32__)
2627 # define SETSOCKOPT_OPTION_VALUE_T void *
2629 # define SETSOCKOPT_OPTION_VALUE_T const char *
2631 /* XXX TODO: We need to have a proper type (a Configure probe,
2632 * etc.) for what the C headers think of the third argument of
2633 * setsockopt(), the option_value read-only buffer: is it
2634 * a "char *", or a "void *", const or not. Some compilers
2635 * don't take kindly to e.g. assuming that "char *" implicitly
2636 * promotes to a "void *", or to explicitly promoting/demoting
2637 * consts to non/vice versa. The "const void *" is the SUS
2638 * definition, but that does not fly everywhere for the above
2640 SETSOCKOPT_OPTION_VALUE_T buf;
2644 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2648 aint = (int)SvIV(sv);
2649 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2652 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2662 SETERRNO(EBADF,SS_IVCHAN);
2671 const int optype = PL_op->op_type;
2672 GV * const gv = MUTABLE_GV(POPs);
2673 IO * const io = GvIOn(gv);
2681 sv = sv_2mortal(newSV(257));
2682 (void)SvPOK_only(sv);
2686 fd = PerlIO_fileno(IoIFP(io));
2688 case OP_GETSOCKNAME:
2689 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2692 case OP_GETPEERNAME:
2693 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2695 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2697 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";
2698 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2699 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2700 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2701 sizeof(u_short) + sizeof(struct in_addr))) {
2708 #ifdef BOGUS_GETNAME_RETURN
2709 /* Interactive Unix, getpeername() and getsockname()
2710 does not return valid namelen */
2711 if (len == BOGUS_GETNAME_RETURN)
2712 len = sizeof(struct sockaddr);
2721 SETERRNO(EBADF,SS_IVCHAN);
2740 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2741 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2742 if (PL_op->op_type == OP_LSTAT) {
2743 if (gv != PL_defgv) {
2744 do_fstat_warning_check:
2745 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2746 "lstat() on filehandle%s%"SVf,
2749 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2751 } else if (PL_laststype != OP_LSTAT)
2752 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2753 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2756 if (gv != PL_defgv) {
2760 PL_laststype = OP_STAT;
2761 PL_statgv = gv ? gv : (GV *)io;
2762 sv_setpvs(PL_statname, "");
2769 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2771 } else if (IoDIRP(io)) {
2773 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2776 PL_laststatval = -1;
2779 else PL_laststatval = -1;
2780 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2783 if (PL_laststatval < 0) {
2788 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2789 io = MUTABLE_IO(SvRV(sv));
2790 if (PL_op->op_type == OP_LSTAT)
2791 goto do_fstat_warning_check;
2792 goto do_fstat_have_io;
2795 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2796 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2798 PL_laststype = PL_op->op_type;
2799 if (PL_op->op_type == OP_LSTAT)
2800 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2802 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2803 if (PL_laststatval < 0) {
2804 if (ckWARN(WARN_NEWLINE) &&
2805 strchr(SvPV_nolen_const(PL_statname), '\n'))
2807 /* PL_warn_nl is constant */
2808 GCC_DIAG_IGNORE(-Wformat-nonliteral);
2809 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2817 if (gimme != G_ARRAY) {
2818 if (gimme != G_VOID)
2819 XPUSHs(boolSV(max));
2825 mPUSHi(PL_statcache.st_dev);
2826 #if ST_INO_SIZE > IVSIZE
2827 mPUSHn(PL_statcache.st_ino);
2829 # if ST_INO_SIGN <= 0
2830 mPUSHi(PL_statcache.st_ino);
2832 mPUSHu(PL_statcache.st_ino);
2835 mPUSHu(PL_statcache.st_mode);
2836 mPUSHu(PL_statcache.st_nlink);
2838 sv_setuid(PUSHmortal, PL_statcache.st_uid);
2839 sv_setgid(PUSHmortal, PL_statcache.st_gid);
2841 #ifdef USE_STAT_RDEV
2842 mPUSHi(PL_statcache.st_rdev);
2844 PUSHs(newSVpvs_flags("", SVs_TEMP));
2846 #if Off_t_size > IVSIZE
2847 mPUSHn(PL_statcache.st_size);
2849 mPUSHi(PL_statcache.st_size);
2852 mPUSHn(PL_statcache.st_atime);
2853 mPUSHn(PL_statcache.st_mtime);
2854 mPUSHn(PL_statcache.st_ctime);
2856 mPUSHi(PL_statcache.st_atime);
2857 mPUSHi(PL_statcache.st_mtime);
2858 mPUSHi(PL_statcache.st_ctime);
2860 #ifdef USE_STAT_BLOCKS
2861 mPUSHu(PL_statcache.st_blksize);
2862 mPUSHu(PL_statcache.st_blocks);
2864 PUSHs(newSVpvs_flags("", SVs_TEMP));
2865 PUSHs(newSVpvs_flags("", SVs_TEMP));
2871 /* All filetest ops avoid manipulating the perl stack pointer in their main
2872 bodies (since commit d2c4d2d1e22d3125), and return using either
2873 S_ft_return_false() or S_ft_return_true(). These two helper functions are
2874 the only two which manipulate the perl stack. To ensure that no stack
2875 manipulation macros are used, the filetest ops avoid defining a local copy
2876 of the stack pointer with dSP. */
2878 /* If the next filetest is stacked up with this one
2879 (PL_op->op_private & OPpFT_STACKING), we leave
2880 the original argument on the stack for success,
2881 and skip the stacked operators on failure.
2882 The next few macros/functions take care of this.
2886 S_ft_return_false(pTHX_ SV *ret) {
2890 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
2894 if (PL_op->op_private & OPpFT_STACKING) {
2895 while (OP_IS_FILETEST(next->op_type)
2896 && next->op_private & OPpFT_STACKED)
2897 next = next->op_next;
2902 PERL_STATIC_INLINE OP *
2903 S_ft_return_true(pTHX_ SV *ret) {
2905 if (PL_op->op_flags & OPf_REF)
2906 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
2907 else if (!(PL_op->op_private & OPpFT_STACKING))
2913 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
2914 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
2915 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
2917 #define tryAMAGICftest_MG(chr) STMT_START { \
2918 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
2919 && PL_op->op_flags & OPf_KIDS) { \
2920 OP *next = S_try_amagic_ftest(aTHX_ chr); \
2921 if (next) return next; \
2926 S_try_amagic_ftest(pTHX_ char chr) {
2928 SV *const arg = *PL_stack_sp;
2931 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
2935 const char tmpchr = chr;
2936 SV * const tmpsv = amagic_call(arg,
2937 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2938 ftest_amg, AMGf_unary);
2943 return SvTRUE(tmpsv)
2944 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
2954 /* Not const, because things tweak this below. Not bool, because there's
2955 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2956 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2957 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2958 /* Giving some sort of initial value silences compilers. */
2960 int access_mode = R_OK;
2962 int access_mode = 0;
2965 /* access_mode is never used, but leaving use_access in makes the
2966 conditional compiling below much clearer. */
2969 Mode_t stat_mode = S_IRUSR;
2971 bool effective = FALSE;
2974 switch (PL_op->op_type) {
2975 case OP_FTRREAD: opchar = 'R'; break;
2976 case OP_FTRWRITE: opchar = 'W'; break;
2977 case OP_FTREXEC: opchar = 'X'; break;
2978 case OP_FTEREAD: opchar = 'r'; break;
2979 case OP_FTEWRITE: opchar = 'w'; break;
2980 case OP_FTEEXEC: opchar = 'x'; break;
2982 tryAMAGICftest_MG(opchar);
2984 switch (PL_op->op_type) {
2986 #if !(defined(HAS_ACCESS) && defined(R_OK))
2992 #if defined(HAS_ACCESS) && defined(W_OK)
2997 stat_mode = S_IWUSR;
3001 #if defined(HAS_ACCESS) && defined(X_OK)
3006 stat_mode = S_IXUSR;
3010 #ifdef PERL_EFF_ACCESS
3013 stat_mode = S_IWUSR;
3017 #ifndef PERL_EFF_ACCESS
3024 #ifdef PERL_EFF_ACCESS
3029 stat_mode = S_IXUSR;
3035 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3036 const char *name = SvPV_nolen(*PL_stack_sp);
3038 # ifdef PERL_EFF_ACCESS
3039 result = PERL_EFF_ACCESS(name, access_mode);
3041 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3047 result = access(name, access_mode);
3049 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3060 result = my_stat_flags(0);
3063 if (cando(stat_mode, effective, &PL_statcache))
3072 const int op_type = PL_op->op_type;
3076 case OP_FTIS: opchar = 'e'; break;
3077 case OP_FTSIZE: opchar = 's'; break;
3078 case OP_FTMTIME: opchar = 'M'; break;
3079 case OP_FTCTIME: opchar = 'C'; break;
3080 case OP_FTATIME: opchar = 'A'; break;
3082 tryAMAGICftest_MG(opchar);
3084 result = my_stat_flags(0);
3087 if (op_type == OP_FTIS)
3090 /* You can't dTARGET inside OP_FTIS, because you'll get
3091 "panic: pad_sv po" - the op is not flagged to have a target. */
3095 #if Off_t_size > IVSIZE
3096 sv_setnv(TARG, (NV)PL_statcache.st_size);
3098 sv_setiv(TARG, (IV)PL_statcache.st_size);
3103 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3107 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3111 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3115 return SvTRUE_nomg(TARG)
3116 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3126 switch (PL_op->op_type) {
3127 case OP_FTROWNED: opchar = 'O'; break;
3128 case OP_FTEOWNED: opchar = 'o'; break;
3129 case OP_FTZERO: opchar = 'z'; break;
3130 case OP_FTSOCK: opchar = 'S'; break;
3131 case OP_FTCHR: opchar = 'c'; break;
3132 case OP_FTBLK: opchar = 'b'; break;
3133 case OP_FTFILE: opchar = 'f'; break;
3134 case OP_FTDIR: opchar = 'd'; break;
3135 case OP_FTPIPE: opchar = 'p'; break;
3136 case OP_FTSUID: opchar = 'u'; break;
3137 case OP_FTSGID: opchar = 'g'; break;
3138 case OP_FTSVTX: opchar = 'k'; break;
3140 tryAMAGICftest_MG(opchar);
3142 /* I believe that all these three are likely to be defined on most every
3143 system these days. */
3145 if(PL_op->op_type == OP_FTSUID) {
3150 if(PL_op->op_type == OP_FTSGID) {
3155 if(PL_op->op_type == OP_FTSVTX) {
3160 result = my_stat_flags(0);
3163 switch (PL_op->op_type) {
3165 if (PL_statcache.st_uid == PerlProc_getuid())
3169 if (PL_statcache.st_uid == PerlProc_geteuid())
3173 if (PL_statcache.st_size == 0)
3177 if (S_ISSOCK(PL_statcache.st_mode))
3181 if (S_ISCHR(PL_statcache.st_mode))
3185 if (S_ISBLK(PL_statcache.st_mode))
3189 if (S_ISREG(PL_statcache.st_mode))
3193 if (S_ISDIR(PL_statcache.st_mode))
3197 if (S_ISFIFO(PL_statcache.st_mode))
3202 if (PL_statcache.st_mode & S_ISUID)
3208 if (PL_statcache.st_mode & S_ISGID)
3214 if (PL_statcache.st_mode & S_ISVTX)
3227 tryAMAGICftest_MG('l');
3228 result = my_lstat_flags(0);
3232 if (S_ISLNK(PL_statcache.st_mode))
3245 tryAMAGICftest_MG('t');
3247 if (PL_op->op_flags & OPf_REF)
3250 SV *tmpsv = *PL_stack_sp;
3251 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3252 name = SvPV_nomg(tmpsv, namelen);
3253 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3257 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3258 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3259 else if (name && isDIGIT(*name))
3263 if (PerlLIO_isatty(fd))
3281 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3283 if (PL_op->op_flags & OPf_REF)
3285 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3290 gv = MAYBE_DEREF_GV_nomg(sv);
3294 if (gv == PL_defgv) {
3296 io = SvTYPE(PL_statgv) == SVt_PVIO
3300 goto really_filename;
3305 sv_setpvs(PL_statname, "");
3306 io = GvIO(PL_statgv);
3308 PL_laststatval = -1;
3309 PL_laststype = OP_STAT;
3310 if (io && IoIFP(io)) {
3311 if (! PerlIO_has_base(IoIFP(io)))
3312 DIE(aTHX_ "-T and -B not implemented on filehandles");
3313 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3314 if (PL_laststatval < 0)
3316 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3317 if (PL_op->op_type == OP_FTTEXT)
3322 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3323 i = PerlIO_getc(IoIFP(io));
3325 (void)PerlIO_ungetc(IoIFP(io),i);
3327 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3329 len = PerlIO_get_bufsiz(IoIFP(io));
3330 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3331 /* sfio can have large buffers - limit to 512 */
3336 SETERRNO(EBADF,RMS_IFI);
3338 SETERRNO(EBADF,RMS_IFI);
3343 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3346 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3348 PL_laststatval = -1;
3349 PL_laststype = OP_STAT;
3351 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3354 /* PL_warn_nl is constant */
3355 GCC_DIAG_IGNORE(-Wformat-nonliteral);
3356 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3361 PL_laststype = OP_STAT;
3362 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3363 if (PL_laststatval < 0) {
3364 (void)PerlIO_close(fp);
3367 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3368 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3369 (void)PerlIO_close(fp);
3371 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3372 FT_RETURNNO; /* special case NFS directories */
3373 FT_RETURNYES; /* null file is anything */
3378 /* now scan s to look for textiness */
3379 /* XXX ASCII dependent code */
3381 #if defined(DOSISH) || defined(USEMYBINMODE)
3382 /* ignore trailing ^Z on short files */
3383 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3387 for (i = 0; i < len; i++, s++) {
3388 if (!*s) { /* null never allowed in text */
3393 else if (!(isPRINT(*s) || isSPACE(*s)))
3396 else if (*s & 128) {
3398 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3401 /* utf8 characters don't count as odd */
3402 if (UTF8_IS_START(*s)) {
3403 int ulen = UTF8SKIP(s);
3404 if (ulen < len - i) {
3406 for (j = 1; j < ulen; j++) {
3407 if (!UTF8_IS_CONTINUATION(s[j]))
3410 --ulen; /* loop does extra increment */
3420 *s != '\n' && *s != '\r' && *s != '\b' &&
3421 *s != '\t' && *s != '\f' && *s != 27)
3426 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3437 const char *tmps = NULL;
3441 SV * const sv = POPs;
3442 if (PL_op->op_flags & OPf_SPECIAL) {
3443 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3445 else if (!(gv = MAYBE_DEREF_GV(sv)))
3446 tmps = SvPV_nomg_const_nolen(sv);
3449 if( !gv && (!tmps || !*tmps) ) {
3450 HV * const table = GvHVn(PL_envgv);
3453 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3454 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3456 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3461 deprecate("chdir('') or chdir(undef) as chdir()");
3462 tmps = SvPV_nolen_const(*svp);
3466 TAINT_PROPER("chdir");
3471 TAINT_PROPER("chdir");
3474 IO* const io = GvIO(gv);
3477 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3478 } else if (IoIFP(io)) {
3479 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3483 SETERRNO(EBADF, RMS_IFI);
3489 SETERRNO(EBADF,RMS_IFI);
3493 DIE(aTHX_ PL_no_func, "fchdir");
3497 PUSHi( PerlDir_chdir(tmps) >= 0 );
3499 /* Clear the DEFAULT element of ENV so we'll get the new value
3501 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3508 dVAR; dSP; dMARK; dTARGET;
3509 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3520 char * const tmps = POPpx;
3521 TAINT_PROPER("chroot");
3522 PUSHi( chroot(tmps) >= 0 );
3525 DIE(aTHX_ PL_no_func, "chroot");
3533 const char * const tmps2 = POPpconstx;
3534 const char * const tmps = SvPV_nolen_const(TOPs);
3535 TAINT_PROPER("rename");
3537 anum = PerlLIO_rename(tmps, tmps2);
3539 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3540 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3543 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3544 (void)UNLINK(tmps2);
3545 if (!(anum = link(tmps, tmps2)))
3546 anum = UNLINK(tmps);
3554 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3558 const int op_type = PL_op->op_type;
3562 if (op_type == OP_LINK)
3563 DIE(aTHX_ PL_no_func, "link");
3565 # ifndef HAS_SYMLINK
3566 if (op_type == OP_SYMLINK)
3567 DIE(aTHX_ PL_no_func, "symlink");
3571 const char * const tmps2 = POPpconstx;
3572 const char * const tmps = SvPV_nolen_const(TOPs);
3573 TAINT_PROPER(PL_op_desc[op_type]);
3575 # if defined(HAS_LINK)
3576 # if defined(HAS_SYMLINK)
3577 /* Both present - need to choose which. */
3578 (op_type == OP_LINK) ?
3579 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3581 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3582 PerlLIO_link(tmps, tmps2);
3585 # if defined(HAS_SYMLINK)
3586 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3587 symlink(tmps, tmps2);
3592 SETi( result >= 0 );
3599 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3610 char buf[MAXPATHLEN];
3615 len = readlink(tmps, buf, sizeof(buf) - 1);
3622 RETSETUNDEF; /* just pretend it's a normal file */
3626 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3628 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3630 char * const save_filename = filename;
3635 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3637 PERL_ARGS_ASSERT_DOONELINER;
3639 Newx(cmdline, size, char);
3640 my_strlcpy(cmdline, cmd, size);
3641 my_strlcat(cmdline, " ", size);
3642 for (s = cmdline + strlen(cmdline); *filename; ) {
3646 if (s - cmdline < size)
3647 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3648 myfp = PerlProc_popen(cmdline, "r");
3652 SV * const tmpsv = sv_newmortal();
3653 /* Need to save/restore 'PL_rs' ?? */
3654 s = sv_gets(tmpsv, myfp, 0);
3655 (void)PerlProc_pclose(myfp);
3659 #ifdef HAS_SYS_ERRLIST
3664 /* you don't see this */
3665 const char * const errmsg = Strerror(e) ;
3668 if (instr(s, errmsg)) {
3675 #define EACCES EPERM
3677 if (instr(s, "cannot make"))
3678 SETERRNO(EEXIST,RMS_FEX);
3679 else if (instr(s, "existing file"))
3680 SETERRNO(EEXIST,RMS_FEX);
3681 else if (instr(s, "ile exists"))
3682 SETERRNO(EEXIST,RMS_FEX);
3683 else if (instr(s, "non-exist"))
3684 SETERRNO(ENOENT,RMS_FNF);
3685 else if (instr(s, "does not exist"))
3686 SETERRNO(ENOENT,RMS_FNF);
3687 else if (instr(s, "not empty"))
3688 SETERRNO(EBUSY,SS_DEVOFFLINE);
3689 else if (instr(s, "cannot access"))
3690 SETERRNO(EACCES,RMS_PRV);
3692 SETERRNO(EPERM,RMS_PRV);
3695 else { /* some mkdirs return no failure indication */
3696 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3697 if (PL_op->op_type == OP_RMDIR)
3702 SETERRNO(EACCES,RMS_PRV); /* a guess */
3711 /* This macro removes trailing slashes from a directory name.
3712 * Different operating and file systems take differently to
3713 * trailing slashes. According to POSIX 1003.1 1996 Edition
3714 * any number of trailing slashes should be allowed.
3715 * Thusly we snip them away so that even non-conforming
3716 * systems are happy.
3717 * We should probably do this "filtering" for all
3718 * the functions that expect (potentially) directory names:
3719 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3720 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3722 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3723 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3726 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3727 (tmps) = savepvn((tmps), (len)); \
3737 const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3739 TRIMSLASHES(tmps,len,copy);
3741 TAINT_PROPER("mkdir");
3743 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3747 SETi( dooneliner("mkdir", tmps) );
3748 oldumask = PerlLIO_umask(0);
3749 PerlLIO_umask(oldumask);
3750 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3765 TRIMSLASHES(tmps,len,copy);
3766 TAINT_PROPER("rmdir");
3768 SETi( PerlDir_rmdir(tmps) >= 0 );
3770 SETi( dooneliner("rmdir", tmps) );
3777 /* Directory calls. */
3781 #if defined(Direntry_t) && defined(HAS_READDIR)
3783 const char * const dirname = POPpconstx;
3784 GV * const gv = MUTABLE_GV(POPs);
3785 IO * const io = GvIOn(gv);
3787 if ((IoIFP(io) || IoOFP(io)))
3788 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3789 "Opening filehandle %"HEKf" also as a directory",
3790 HEKfARG(GvENAME_HEK(gv)) );
3792 PerlDir_close(IoDIRP(io));
3793 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3799 SETERRNO(EBADF,RMS_DIR);
3802 DIE(aTHX_ PL_no_dir_func, "opendir");
3808 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3809 DIE(aTHX_ PL_no_dir_func, "readdir");
3811 #if !defined(I_DIRENT) && !defined(VMS)
3812 Direntry_t *readdir (DIR *);
3818 const I32 gimme = GIMME;
3819 GV * const gv = MUTABLE_GV(POPs);
3820 const Direntry_t *dp;
3821 IO * const io = GvIOn(gv);
3824 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3825 "readdir() attempted on invalid dirhandle %"HEKf,
3826 HEKfARG(GvENAME_HEK(gv)));
3831 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3835 sv = newSVpvn(dp->d_name, dp->d_namlen);
3837 sv = newSVpv(dp->d_name, 0);
3839 if (!(IoFLAGS(io) & IOf_UNTAINT))
3842 } while (gimme == G_ARRAY);
3844 if (!dp && gimme != G_ARRAY)
3851 SETERRNO(EBADF,RMS_ISI);
3852 if (GIMME == G_ARRAY)
3861 #if defined(HAS_TELLDIR) || defined(telldir)
3863 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3864 /* XXX netbsd still seemed to.
3865 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3866 --JHI 1999-Feb-02 */
3867 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3868 long telldir (DIR *);
3870 GV * const gv = MUTABLE_GV(POPs);
3871 IO * const io = GvIOn(gv);
3874 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3875 "telldir() attempted on invalid dirhandle %"HEKf,
3876 HEKfARG(GvENAME_HEK(gv)));
3880 PUSHi( PerlDir_tell(IoDIRP(io)) );
3884 SETERRNO(EBADF,RMS_ISI);
3887 DIE(aTHX_ PL_no_dir_func, "telldir");
3893 #if defined(HAS_SEEKDIR) || defined(seekdir)
3895 const long along = POPl;
3896 GV * const gv = MUTABLE_GV(POPs);
3897 IO * const io = GvIOn(gv);
3900 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3901 "seekdir() attempted on invalid dirhandle %"HEKf,
3902 HEKfARG(GvENAME_HEK(gv)));
3905 (void)PerlDir_seek(IoDIRP(io), along);
3910 SETERRNO(EBADF,RMS_ISI);
3913 DIE(aTHX_ PL_no_dir_func, "seekdir");
3919 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3921 GV * const gv = MUTABLE_GV(POPs);
3922 IO * const io = GvIOn(gv);
3925 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3926 "rewinddir() attempted on invalid dirhandle %"HEKf,
3927 HEKfARG(GvENAME_HEK(gv)));
3930 (void)PerlDir_rewind(IoDIRP(io));
3934 SETERRNO(EBADF,RMS_ISI);
3937 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3943 #if defined(Direntry_t) && defined(HAS_READDIR)
3945 GV * const gv = MUTABLE_GV(POPs);
3946 IO * const io = GvIOn(gv);
3949 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3950 "closedir() attempted on invalid dirhandle %"HEKf,
3951 HEKfARG(GvENAME_HEK(gv)));
3954 #ifdef VOID_CLOSEDIR
3955 PerlDir_close(IoDIRP(io));
3957 if (PerlDir_close(IoDIRP(io)) < 0) {
3958 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3967 SETERRNO(EBADF,RMS_IFI);
3970 DIE(aTHX_ PL_no_dir_func, "closedir");
3974 /* Process control. */
3981 #ifdef HAS_SIGPROCMASK
3982 sigset_t oldmask, newmask;
3986 PERL_FLUSHALL_FOR_CHILD;
3987 #ifdef HAS_SIGPROCMASK
3988 sigfillset(&newmask);
3989 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
3991 childpid = PerlProc_fork();
3992 if (childpid == 0) {
3996 for (sig = 1; sig < SIG_SIZE; sig++)
3997 PL_psig_pend[sig] = 0;
3999 #ifdef HAS_SIGPROCMASK
4002 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4009 #ifdef PERL_USES_PL_PIDSTATUS
4010 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4016 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4021 PERL_FLUSHALL_FOR_CHILD;
4022 childpid = PerlProc_fork();
4028 DIE(aTHX_ PL_no_func, "fork");
4035 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4040 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4041 childpid = wait4pid(-1, &argflags, 0);
4043 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4048 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4049 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4050 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4052 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4057 DIE(aTHX_ PL_no_func, "wait");
4063 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4065 const int optype = POPi;
4066 const Pid_t pid = TOPi;
4070 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4071 result = wait4pid(pid, &argflags, optype);
4073 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4078 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4079 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4080 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4082 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4087 DIE(aTHX_ PL_no_func, "waitpid");
4093 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4094 #if defined(__LIBCATAMOUNT__)
4095 PL_statusvalue = -1;
4104 while (++MARK <= SP) {
4105 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4110 TAINT_PROPER("system");
4112 PERL_FLUSHALL_FOR_CHILD;
4113 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4118 #ifdef HAS_SIGPROCMASK
4119 sigset_t newset, oldset;
4122 if (PerlProc_pipe(pp) >= 0)
4124 #ifdef HAS_SIGPROCMASK
4125 sigemptyset(&newset);
4126 sigaddset(&newset, SIGCHLD);
4127 sigprocmask(SIG_BLOCK, &newset, &oldset);
4129 while ((childpid = PerlProc_fork()) == -1) {
4130 if (errno != EAGAIN) {
4135 PerlLIO_close(pp[0]);
4136 PerlLIO_close(pp[1]);
4138 #ifdef HAS_SIGPROCMASK
4139 sigprocmask(SIG_SETMASK, &oldset, NULL);
4146 Sigsave_t ihand,qhand; /* place to save signals during system() */
4150 PerlLIO_close(pp[1]);
4152 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4153 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4156 result = wait4pid(childpid, &status, 0);
4157 } while (result == -1 && errno == EINTR);
4159 #ifdef HAS_SIGPROCMASK
4160 sigprocmask(SIG_SETMASK, &oldset, NULL);
4162 (void)rsignal_restore(SIGINT, &ihand);
4163 (void)rsignal_restore(SIGQUIT, &qhand);
4165 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4166 do_execfree(); /* free any memory child malloced on fork */
4173 while (n < sizeof(int)) {
4174 n1 = PerlLIO_read(pp[0],
4175 (void*)(((char*)&errkid)+n),
4181 PerlLIO_close(pp[0]);
4182 if (n) { /* Error */
4183 if (n != sizeof(int))
4184 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4185 errno = errkid; /* Propagate errno from kid */
4186 STATUS_NATIVE_CHILD_SET(-1);
4189 XPUSHi(STATUS_CURRENT);
4192 #ifdef HAS_SIGPROCMASK
4193 sigprocmask(SIG_SETMASK, &oldset, NULL);
4196 PerlLIO_close(pp[0]);
4197 #if defined(HAS_FCNTL) && defined(F_SETFD)
4198 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4201 if (PL_op->op_flags & OPf_STACKED) {
4202 SV * const really = *++MARK;
4203 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4205 else if (SP - MARK != 1)
4206 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4208 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4212 #else /* ! FORK or VMS or OS/2 */
4215 if (PL_op->op_flags & OPf_STACKED) {
4216 SV * const really = *++MARK;
4217 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4218 value = (I32)do_aspawn(really, MARK, SP);
4220 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4223 else if (SP - MARK != 1) {
4224 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4225 value = (I32)do_aspawn(NULL, MARK, SP);
4227 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4231 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4233 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4235 STATUS_NATIVE_CHILD_SET(value);
4238 XPUSHi(result ? value : STATUS_CURRENT);
4239 #endif /* !FORK or VMS or OS/2 */
4246 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4251 while (++MARK <= SP) {
4252 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4257 TAINT_PROPER("exec");
4259 PERL_FLUSHALL_FOR_CHILD;
4260 if (PL_op->op_flags & OPf_STACKED) {
4261 SV * const really = *++MARK;
4262 value = (I32)do_aexec(really, MARK, SP);
4264 else if (SP - MARK != 1)
4266 value = (I32)vms_do_aexec(NULL, MARK, SP);
4268 value = (I32)do_aexec(NULL, MARK, SP);
4272 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4274 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4287 XPUSHi( getppid() );
4290 DIE(aTHX_ PL_no_func, "getppid");
4300 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4303 pgrp = (I32)BSD_GETPGRP(pid);
4305 if (pid != 0 && pid != PerlProc_getpid())
4306 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4312 DIE(aTHX_ PL_no_func, "getpgrp()");
4322 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4323 if (MAXARG > 0) pid = TOPs && TOPi;
4329 TAINT_PROPER("setpgrp");
4331 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4333 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4334 || (pid != 0 && pid != PerlProc_getpid()))
4336 DIE(aTHX_ "setpgrp can't take arguments");
4338 SETi( setpgrp() >= 0 );
4339 #endif /* USE_BSDPGRP */
4342 DIE(aTHX_ PL_no_func, "setpgrp()");
4346 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4347 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4349 # define PRIORITY_WHICH_T(which) which
4354 #ifdef HAS_GETPRIORITY
4356 const int who = POPi;
4357 const int which = TOPi;
4358 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4361 DIE(aTHX_ PL_no_func, "getpriority()");
4367 #ifdef HAS_SETPRIORITY
4369 const int niceval = POPi;
4370 const int who = POPi;
4371 const int which = TOPi;
4372 TAINT_PROPER("setpriority");
4373 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4376 DIE(aTHX_ PL_no_func, "setpriority()");
4380 #undef PRIORITY_WHICH_T
4388 XPUSHn( time(NULL) );
4390 XPUSHi( time(NULL) );
4402 (void)PerlProc_times(&PL_timesbuf);
4404 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4405 /* struct tms, though same data */
4409 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4410 if (GIMME == G_ARRAY) {
4411 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4412 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4413 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4421 if (GIMME == G_ARRAY) {
4428 DIE(aTHX_ "times not implemented");
4430 #endif /* HAS_TIMES */
4433 /* The 32 bit int year limits the times we can represent to these
4434 boundaries with a few days wiggle room to account for time zone
4437 /* Sat Jan 3 00:00:00 -2147481748 */
4438 #define TIME_LOWER_BOUND -67768100567755200.0
4439 /* Sun Dec 29 12:00:00 2147483647 */
4440 #define TIME_UPPER_BOUND 67767976233316800.0
4449 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4450 static const char * const dayname[] =
4451 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4452 static const char * const monname[] =
4453 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4454 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4456 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4459 when = (Time64_T)now;
4462 NV input = Perl_floor(POPn);
4463 when = (Time64_T)input;
4464 if (when != input) {
4465 /* diag_listed_as: gmtime(%f) too large */
4466 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4467 "%s(%.0" NVff ") too large", opname, input);
4471 if ( TIME_LOWER_BOUND > when ) {
4472 /* diag_listed_as: gmtime(%f) too small */
4473 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4474 "%s(%.0" NVff ") too small", opname, when);
4477 else if( when > TIME_UPPER_BOUND ) {
4478 /* diag_listed_as: gmtime(%f) too small */
4479 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4480 "%s(%.0" NVff ") too large", opname, when);
4484 if (PL_op->op_type == OP_LOCALTIME)
4485 err = S_localtime64_r(&when, &tmbuf);
4487 err = S_gmtime64_r(&when, &tmbuf);
4491 /* XXX %lld broken for quads */
4492 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4493 "%s(%.0" NVff ") failed", opname, when);
4496 if (GIMME != G_ARRAY) { /* scalar context */
4498 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4499 double year = (double)tmbuf.tm_year + 1900;
4506 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4507 dayname[tmbuf.tm_wday],
4508 monname[tmbuf.tm_mon],
4516 else { /* list context */
4522 mPUSHi(tmbuf.tm_sec);
4523 mPUSHi(tmbuf.tm_min);
4524 mPUSHi(tmbuf.tm_hour);
4525 mPUSHi(tmbuf.tm_mday);
4526 mPUSHi(tmbuf.tm_mon);
4527 mPUSHn(tmbuf.tm_year);
4528 mPUSHi(tmbuf.tm_wday);
4529 mPUSHi(tmbuf.tm_yday);
4530 mPUSHi(tmbuf.tm_isdst);
4541 anum = alarm((unsigned int)anum);
4547 DIE(aTHX_ PL_no_func, "alarm");
4558 (void)time(&lasttime);
4559 if (MAXARG < 1 || (!TOPs && !POPs))
4563 PerlProc_sleep((unsigned int)duration);
4566 XPUSHi(when - lasttime);
4570 /* Shared memory. */
4571 /* Merged with some message passing. */
4575 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4576 dVAR; dSP; dMARK; dTARGET;
4577 const int op_type = PL_op->op_type;
4582 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4585 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4588 value = (I32)(do_semop(MARK, SP) >= 0);
4591 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4599 return Perl_pp_semget(aTHX);
4607 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4608 dVAR; dSP; dMARK; dTARGET;
4609 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4616 DIE(aTHX_ "System V IPC is not implemented on this machine");
4622 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4623 dVAR; dSP; dMARK; dTARGET;
4624 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4632 PUSHp(zero_but_true, ZBTLEN);
4636 return Perl_pp_semget(aTHX);
4640 /* I can't const this further without getting warnings about the types of
4641 various arrays passed in from structures. */
4643 S_space_join_names_mortal(pTHX_ char *const *array)
4647 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4649 if (array && *array) {
4650 target = newSVpvs_flags("", SVs_TEMP);
4652 sv_catpv(target, *array);
4655 sv_catpvs(target, " ");
4658 target = sv_mortalcopy(&PL_sv_no);
4663 /* Get system info. */
4667 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4669 I32 which = PL_op->op_type;
4672 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4673 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4674 struct hostent *gethostbyname(Netdb_name_t);
4675 struct hostent *gethostent(void);
4677 struct hostent *hent = NULL;
4681 if (which == OP_GHBYNAME) {
4682 #ifdef HAS_GETHOSTBYNAME
4683 const char* const name = POPpbytex;
4684 hent = PerlSock_gethostbyname(name);
4686 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4689 else if (which == OP_GHBYADDR) {
4690 #ifdef HAS_GETHOSTBYADDR
4691 const int addrtype = POPi;
4692 SV * const addrsv = POPs;
4694 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4696 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4698 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4702 #ifdef HAS_GETHOSTENT
4703 hent = PerlSock_gethostent();
4705 DIE(aTHX_ PL_no_sock_func, "gethostent");
4708 #ifdef HOST_NOT_FOUND
4710 #ifdef USE_REENTRANT_API
4711 # ifdef USE_GETHOSTENT_ERRNO
4712 h_errno = PL_reentrant_buffer->_gethostent_errno;
4715 STATUS_UNIX_SET(h_errno);
4719 if (GIMME != G_ARRAY) {
4720 PUSHs(sv = sv_newmortal());
4722 if (which == OP_GHBYNAME) {
4724 sv_setpvn(sv, hent->h_addr, hent->h_length);
4727 sv_setpv(sv, (char*)hent->h_name);
4733 mPUSHs(newSVpv((char*)hent->h_name, 0));
4734 PUSHs(space_join_names_mortal(hent->h_aliases));
4735 mPUSHi(hent->h_addrtype);
4736 len = hent->h_length;
4739 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4740 mXPUSHp(*elem, len);
4744 mPUSHp(hent->h_addr, len);
4746 PUSHs(sv_mortalcopy(&PL_sv_no));
4751 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4757 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4759 I32 which = PL_op->op_type;
4761 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4762 struct netent *getnetbyaddr(Netdb_net_t, int);
4763 struct netent *getnetbyname(Netdb_name_t);
4764 struct netent *getnetent(void);
4766 struct netent *nent;
4768 if (which == OP_GNBYNAME){
4769 #ifdef HAS_GETNETBYNAME
4770 const char * const name = POPpbytex;
4771 nent = PerlSock_getnetbyname(name);
4773 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4776 else if (which == OP_GNBYADDR) {
4777 #ifdef HAS_GETNETBYADDR
4778 const int addrtype = POPi;
4779 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4780 nent = PerlSock_getnetbyaddr(addr, addrtype);
4782 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4786 #ifdef HAS_GETNETENT
4787 nent = PerlSock_getnetent();
4789 DIE(aTHX_ PL_no_sock_func, "getnetent");
4792 #ifdef HOST_NOT_FOUND
4794 #ifdef USE_REENTRANT_API
4795 # ifdef USE_GETNETENT_ERRNO
4796 h_errno = PL_reentrant_buffer->_getnetent_errno;
4799 STATUS_UNIX_SET(h_errno);
4804 if (GIMME != G_ARRAY) {
4805 PUSHs(sv = sv_newmortal());
4807 if (which == OP_GNBYNAME)
4808 sv_setiv(sv, (IV)nent->n_net);
4810 sv_setpv(sv, nent->n_name);
4816 mPUSHs(newSVpv(nent->n_name, 0));
4817 PUSHs(space_join_names_mortal(nent->n_aliases));
4818 mPUSHi(nent->n_addrtype);
4819 mPUSHi(nent->n_net);
4824 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4830 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4832 I32 which = PL_op->op_type;
4834 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4835 struct protoent *getprotobyname(Netdb_name_t);
4836 struct protoent *getprotobynumber(int);
4837 struct protoent *getprotoent(void);
4839 struct protoent *pent;
4841 if (which == OP_GPBYNAME) {
4842 #ifdef HAS_GETPROTOBYNAME
4843 const char* const name = POPpbytex;
4844 pent = PerlSock_getprotobyname(name);
4846 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4849 else if (which == OP_GPBYNUMBER) {
4850 #ifdef HAS_GETPROTOBYNUMBER
4851 const int number = POPi;
4852 pent = PerlSock_getprotobynumber(number);
4854 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4858 #ifdef HAS_GETPROTOENT
4859 pent = PerlSock_getprotoent();
4861 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4865 if (GIMME != G_ARRAY) {
4866 PUSHs(sv = sv_newmortal());
4868 if (which == OP_GPBYNAME)
4869 sv_setiv(sv, (IV)pent->p_proto);
4871 sv_setpv(sv, pent->p_name);
4877 mPUSHs(newSVpv(pent->p_name, 0));
4878 PUSHs(space_join_names_mortal(pent->p_aliases));
4879 mPUSHi(pent->p_proto);
4884 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4890 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4892 I32 which = PL_op->op_type;
4894 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4895 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4896 struct servent *getservbyport(int, Netdb_name_t);
4897 struct servent *getservent(void);
4899 struct servent *sent;
4901 if (which == OP_GSBYNAME) {
4902 #ifdef HAS_GETSERVBYNAME
4903 const char * const proto = POPpbytex;
4904 const char * const name = POPpbytex;
4905 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4907 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4910 else if (which == OP_GSBYPORT) {
4911 #ifdef HAS_GETSERVBYPORT
4912 const char * const proto = POPpbytex;
4913 unsigned short port = (unsigned short)POPu;
4914 port = PerlSock_htons(port);
4915 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4917 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4921 #ifdef HAS_GETSERVENT
4922 sent = PerlSock_getservent();
4924 DIE(aTHX_ PL_no_sock_func, "getservent");
4928 if (GIMME != G_ARRAY) {
4929 PUSHs(sv = sv_newmortal());
4931 if (which == OP_GSBYNAME) {
4932 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4935 sv_setpv(sv, sent->s_name);
4941 mPUSHs(newSVpv(sent->s_name, 0));
4942 PUSHs(space_join_names_mortal(sent->s_aliases));
4943 mPUSHi(PerlSock_ntohs(sent->s_port));
4944 mPUSHs(newSVpv(sent->s_proto, 0));
4949 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4956 const int stayopen = TOPi;
4957 switch(PL_op->op_type) {
4959 #ifdef HAS_SETHOSTENT
4960 PerlSock_sethostent(stayopen);
4962 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4965 #ifdef HAS_SETNETENT
4967 PerlSock_setnetent(stayopen);
4969 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4973 #ifdef HAS_SETPROTOENT
4974 PerlSock_setprotoent(stayopen);
4976 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4980 #ifdef HAS_SETSERVENT
4981 PerlSock_setservent(stayopen);
4983 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4993 switch(PL_op->op_type) {
4995 #ifdef HAS_ENDHOSTENT
4996 PerlSock_endhostent();
4998 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5002 #ifdef HAS_ENDNETENT
5003 PerlSock_endnetent();
5005 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5009 #ifdef HAS_ENDPROTOENT
5010 PerlSock_endprotoent();
5012 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5016 #ifdef HAS_ENDSERVENT
5017 PerlSock_endservent();
5019 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5023 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5026 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5030 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5033 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5037 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5040 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5044 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5047 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5059 I32 which = PL_op->op_type;
5061 struct passwd *pwent = NULL;
5063 * We currently support only the SysV getsp* shadow password interface.
5064 * The interface is declared in <shadow.h> and often one needs to link
5065 * with -lsecurity or some such.
5066 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5069 * AIX getpwnam() is clever enough to return the encrypted password
5070 * only if the caller (euid?) is root.
5072 * There are at least three other shadow password APIs. Many platforms
5073 * seem to contain more than one interface for accessing the shadow
5074 * password databases, possibly for compatibility reasons.
5075 * The getsp*() is by far he simplest one, the other two interfaces
5076 * are much more complicated, but also very similar to each other.
5081 * struct pr_passwd *getprpw*();
5082 * The password is in
5083 * char getprpw*(...).ufld.fd_encrypt[]
5084 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5089 * struct es_passwd *getespw*();
5090 * The password is in
5091 * char *(getespw*(...).ufld.fd_encrypt)
5092 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5095 * struct userpw *getuserpw();
5096 * The password is in
5097 * char *(getuserpw(...)).spw_upw_passwd
5098 * (but the de facto standard getpwnam() should work okay)
5100 * Mention I_PROT here so that Configure probes for it.
5102 * In HP-UX for getprpw*() the manual page claims that one should include
5103 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5104 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5105 * and pp_sys.c already includes <shadow.h> if there is such.
5107 * Note that <sys/security.h> is already probed for, but currently
5108 * it is only included in special cases.
5110 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5111 * be preferred interface, even though also the getprpw*() interface
5112 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5113 * One also needs to call set_auth_parameters() in main() before
5114 * doing anything else, whether one is using getespw*() or getprpw*().
5116 * Note that accessing the shadow databases can be magnitudes
5117 * slower than accessing the standard databases.
5122 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5123 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5124 * the pw_comment is left uninitialized. */
5125 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5131 const char* const name = POPpbytex;
5132 pwent = getpwnam(name);
5138 pwent = getpwuid(uid);
5142 # ifdef HAS_GETPWENT
5144 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5145 if (pwent) pwent = getpwnam(pwent->pw_name);
5148 DIE(aTHX_ PL_no_func, "getpwent");
5154 if (GIMME != G_ARRAY) {
5155 PUSHs(sv = sv_newmortal());
5157 if (which == OP_GPWNAM)
5158 sv_setuid(sv, pwent->pw_uid);
5160 sv_setpv(sv, pwent->pw_name);
5166 mPUSHs(newSVpv(pwent->pw_name, 0));
5170 /* If we have getspnam(), we try to dig up the shadow
5171 * password. If we are underprivileged, the shadow
5172 * interface will set the errno to EACCES or similar,
5173 * and return a null pointer. If this happens, we will
5174 * use the dummy password (usually "*" or "x") from the
5175 * standard password database.
5177 * In theory we could skip the shadow call completely
5178 * if euid != 0 but in practice we cannot know which
5179 * security measures are guarding the shadow databases
5180 * on a random platform.
5182 * Resist the urge to use additional shadow interfaces.
5183 * Divert the urge to writing an extension instead.
5186 /* Some AIX setups falsely(?) detect some getspnam(), which
5187 * has a different API than the Solaris/IRIX one. */
5188 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5191 const struct spwd * const spwent = getspnam(pwent->pw_name);
5192 /* Save and restore errno so that
5193 * underprivileged attempts seem
5194 * to have never made the unsuccessful
5195 * attempt to retrieve the shadow password. */
5197 if (spwent && spwent->sp_pwdp)
5198 sv_setpv(sv, spwent->sp_pwdp);
5202 if (!SvPOK(sv)) /* Use the standard password, then. */
5203 sv_setpv(sv, pwent->pw_passwd);
5206 /* passwd is tainted because user himself can diddle with it.
5207 * admittedly not much and in a very limited way, but nevertheless. */
5210 sv_setuid(PUSHmortal, pwent->pw_uid);
5211 sv_setgid(PUSHmortal, pwent->pw_gid);
5213 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5214 * because of the poor interface of the Perl getpw*(),
5215 * not because there's some standard/convention saying so.
5216 * A better interface would have been to return a hash,
5217 * but we are accursed by our history, alas. --jhi. */
5219 mPUSHi(pwent->pw_change);
5222 mPUSHi(pwent->pw_quota);
5225 mPUSHs(newSVpv(pwent->pw_age, 0));
5227 /* I think that you can never get this compiled, but just in case. */
5228 PUSHs(sv_mortalcopy(&PL_sv_no));
5233 /* pw_class and pw_comment are mutually exclusive--.
5234 * see the above note for pw_change, pw_quota, and pw_age. */
5236 mPUSHs(newSVpv(pwent->pw_class, 0));
5239 mPUSHs(newSVpv(pwent->pw_comment, 0));
5241 /* I think that you can never get this compiled, but just in case. */
5242 PUSHs(sv_mortalcopy(&PL_sv_no));
5247 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5249 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5251 /* pw_gecos is tainted because user himself can diddle with it. */
5254 mPUSHs(newSVpv(pwent->pw_dir, 0));
5256 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5257 /* pw_shell is tainted because user himself can diddle with it. */
5261 mPUSHi(pwent->pw_expire);
5266 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5274 const I32 which = PL_op->op_type;
5275 const struct group *grent;
5277 if (which == OP_GGRNAM) {
5278 const char* const name = POPpbytex;
5279 grent = (const struct group *)getgrnam(name);
5281 else if (which == OP_GGRGID) {
5282 const Gid_t gid = POPi;
5283 grent = (const struct group *)getgrgid(gid);
5287 grent = (struct group *)getgrent();
5289 DIE(aTHX_ PL_no_func, "getgrent");
5293 if (GIMME != G_ARRAY) {
5294 SV * const sv = sv_newmortal();
5298 if (which == OP_GGRNAM)
5299 sv_setgid(sv, grent->gr_gid);
5301 sv_setpv(sv, grent->gr_name);
5307 mPUSHs(newSVpv(grent->gr_name, 0));
5310 mPUSHs(newSVpv(grent->gr_passwd, 0));
5312 PUSHs(sv_mortalcopy(&PL_sv_no));
5315 sv_setgid(PUSHmortal, grent->gr_gid);
5317 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5318 /* In UNICOS/mk (_CRAYMPP) the multithreading
5319 * versions (getgrnam_r, getgrgid_r)
5320 * seem to return an illegal pointer
5321 * as the group members list, gr_mem.
5322 * getgrent() doesn't even have a _r version
5323 * but the gr_mem is poisonous anyway.
5324 * So yes, you cannot get the list of group
5325 * members if building multithreaded in UNICOS/mk. */
5326 PUSHs(space_join_names_mortal(grent->gr_mem));
5332 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5342 if (!(tmps = PerlProc_getlogin()))
5344 sv_setpv_mg(TARG, tmps);
5348 DIE(aTHX_ PL_no_func, "getlogin");
5352 /* Miscellaneous. */
5357 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5358 I32 items = SP - MARK;
5359 unsigned long a[20];
5364 while (++MARK <= SP) {
5365 if (SvTAINTED(*MARK)) {
5371 TAINT_PROPER("syscall");
5374 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5375 * or where sizeof(long) != sizeof(char*). But such machines will
5376 * not likely have syscall implemented either, so who cares?
5378 while (++MARK <= SP) {
5379 if (SvNIOK(*MARK) || !i)
5380 a[i++] = SvIV(*MARK);
5381 else if (*MARK == &PL_sv_undef)
5384 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5390 DIE(aTHX_ "Too many args to syscall");
5392 DIE(aTHX_ "Too few args to syscall");
5394 retval = syscall(a[0]);
5397 retval = syscall(a[0],a[1]);
5400 retval = syscall(a[0],a[1],a[2]);
5403 retval = syscall(a[0],a[1],a[2],a[3]);
5406 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5409 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5412 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5415 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5422 DIE(aTHX_ PL_no_func, "syscall");
5426 #ifdef FCNTL_EMULATE_FLOCK
5428 /* XXX Emulate flock() with fcntl().
5429 What's really needed is a good file locking module.
5433 fcntl_emulate_flock(int fd, int operation)
5438 switch (operation & ~LOCK_NB) {
5440 flock.l_type = F_RDLCK;
5443 flock.l_type = F_WRLCK;
5446 flock.l_type = F_UNLCK;
5452 flock.l_whence = SEEK_SET;
5453 flock.l_start = flock.l_len = (Off_t)0;
5455 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5456 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5457 errno = EWOULDBLOCK;
5461 #endif /* FCNTL_EMULATE_FLOCK */
5463 #ifdef LOCKF_EMULATE_FLOCK
5465 /* XXX Emulate flock() with lockf(). This is just to increase
5466 portability of scripts. The calls are not completely
5467 interchangeable. What's really needed is a good file
5471 /* The lockf() constants might have been defined in <unistd.h>.
5472 Unfortunately, <unistd.h> causes troubles on some mixed
5473 (BSD/POSIX) systems, such as SunOS 4.1.3.
5475 Further, the lockf() constants aren't POSIX, so they might not be
5476 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5477 just stick in the SVID values and be done with it. Sigh.
5481 # define F_ULOCK 0 /* Unlock a previously locked region */
5484 # define F_LOCK 1 /* Lock a region for exclusive use */
5487 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5490 # define F_TEST 3 /* Test a region for other processes locks */
5494 lockf_emulate_flock(int fd, int operation)
5500 /* flock locks entire file so for lockf we need to do the same */
5501 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5502 if (pos > 0) /* is seekable and needs to be repositioned */
5503 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5504 pos = -1; /* seek failed, so don't seek back afterwards */
5507 switch (operation) {
5509 /* LOCK_SH - get a shared lock */
5511 /* LOCK_EX - get an exclusive lock */
5513 i = lockf (fd, F_LOCK, 0);
5516 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5517 case LOCK_SH|LOCK_NB:
5518 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5519 case LOCK_EX|LOCK_NB:
5520 i = lockf (fd, F_TLOCK, 0);
5522 if ((errno == EAGAIN) || (errno == EACCES))
5523 errno = EWOULDBLOCK;
5526 /* LOCK_UN - unlock (non-blocking is a no-op) */
5528 case LOCK_UN|LOCK_NB:
5529 i = lockf (fd, F_ULOCK, 0);
5532 /* Default - can't decipher operation */
5539 if (pos > 0) /* need to restore position of the handle */
5540 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5545 #endif /* LOCKF_EMULATE_FLOCK */
5549 * c-indentation-style: bsd
5551 * indent-tabs-mode: nil
5554 * ex: set ts=8 sts=4 sw=4 et: