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));
692 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);
1343 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1347 const I32 gimme = GIMME_V;
1349 PERL_ARGS_ASSERT_DOFORM;
1351 if (cv && CvCLONE(cv))
1352 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1357 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1358 PUSHFORMAT(cx, retop);
1359 if (CvDEPTH(cv) >= 2) {
1360 PERL_STACK_OVERFLOW_CHECK();
1361 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1364 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1366 setdefout(gv); /* locally select filehandle so $% et al work */
1385 gv = MUTABLE_GV(POPs);
1402 tmpsv = sv_newmortal();
1403 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1404 DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
1406 IoFLAGS(io) &= ~IOf_DIDTOP;
1407 RETURNOP(doform(cv,gv,PL_op->op_next));
1413 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1414 IO * const io = GvIOp(gv);
1422 if (!io || !(ofp = IoOFP(io)))
1425 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1426 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1428 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1429 PL_formtarget != PL_toptarget)
1433 if (!IoTOP_GV(io)) {
1436 if (!IoTOP_NAME(io)) {
1438 if (!IoFMT_NAME(io))
1439 IoFMT_NAME(io) = savepv(GvNAME(gv));
1440 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1441 HEKfARG(GvNAME_HEK(gv))));
1442 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1443 if ((topgv && GvFORM(topgv)) ||
1444 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1445 IoTOP_NAME(io) = savesvpv(topname);
1447 IoTOP_NAME(io) = savepvs("top");
1449 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1450 if (!topgv || !GvFORM(topgv)) {
1451 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1454 IoTOP_GV(io) = topgv;
1456 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1457 I32 lines = IoLINES_LEFT(io);
1458 const char *s = SvPVX_const(PL_formtarget);
1459 if (lines <= 0) /* Yow, header didn't even fit!!! */
1461 while (lines-- > 0) {
1462 s = strchr(s, '\n');
1468 const STRLEN save = SvCUR(PL_formtarget);
1469 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1470 do_print(PL_formtarget, ofp);
1471 SvCUR_set(PL_formtarget, save);
1472 sv_chop(PL_formtarget, s);
1473 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1476 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1477 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1478 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1480 PL_formtarget = PL_toptarget;
1481 IoFLAGS(io) |= IOf_DIDTOP;
1483 assert(fgv); /* IoTOP_GV(io) should have been set above */
1486 SV * const sv = sv_newmortal();
1487 gv_efullname4(sv, fgv, NULL, FALSE);
1488 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1490 return doform(cv, gv, PL_op);
1494 POPBLOCK(cx,PL_curpm);
1495 retop = cx->blk_sub.retop;
1497 SP = newsp; /* ignore retval of formline */
1500 if (!io || !(fp = IoOFP(io))) {
1501 if (io && IoIFP(io))
1502 report_wrongway_fh(gv, '<');
1508 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1509 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1511 if (!do_print(PL_formtarget, fp))
1514 FmLINES(PL_formtarget) = 0;
1515 SvCUR_set(PL_formtarget, 0);
1516 *SvEND(PL_formtarget) = '\0';
1517 if (IoFLAGS(io) & IOf_FLUSH)
1518 (void)PerlIO_flush(fp);
1522 PL_formtarget = PL_bodytarget;
1523 PERL_UNUSED_VAR(gimme);
1529 dVAR; dSP; dMARK; dORIGMARK;
1533 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1534 IO *const io = GvIO(gv);
1536 /* Treat empty list as "" */
1537 if (MARK == SP) XPUSHs(&PL_sv_no);
1540 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1542 if (MARK == ORIGMARK) {
1545 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1548 return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1550 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1557 SETERRNO(EBADF,RMS_IFI);
1560 else if (!(fp = IoOFP(io))) {
1562 report_wrongway_fh(gv, '<');
1563 else if (ckWARN(WARN_CLOSED))
1565 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1569 SV *sv = sv_newmortal();
1570 do_sprintf(sv, SP - MARK, MARK + 1);
1571 if (!do_print(sv, fp))
1574 if (IoFLAGS(io) & IOf_FLUSH)
1575 if (PerlIO_flush(fp) == EOF)
1584 PUSHs(&PL_sv_undef);
1592 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1593 const int mode = POPi;
1594 SV * const sv = POPs;
1595 GV * const gv = MUTABLE_GV(POPs);
1598 /* Need TIEHANDLE method ? */
1599 const char * const tmps = SvPV_const(sv, len);
1600 /* FIXME? do_open should do const */
1601 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1602 IoLINES(GvIOp(gv)) = 0;
1606 PUSHs(&PL_sv_undef);
1613 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1627 bool charstart = FALSE;
1628 STRLEN charskip = 0;
1631 GV * const gv = MUTABLE_GV(*++MARK);
1632 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1633 && gv && (io = GvIO(gv)) )
1635 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1637 return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1638 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1647 sv_setpvs(bufsv, "");
1648 length = SvIVx(*++MARK);
1650 DIE(aTHX_ "Negative length");
1653 offset = SvIVx(*++MARK);
1657 if (!io || !IoIFP(io)) {
1659 SETERRNO(EBADF,RMS_IFI);
1662 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1663 buffer = SvPVutf8_force(bufsv, blen);
1664 /* UTF-8 may not have been set if they are all low bytes */
1669 buffer = SvPV_force(bufsv, blen);
1670 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1672 if (DO_UTF8(bufsv)) {
1673 blen = sv_len_utf8_nomg(bufsv);
1682 if (PL_op->op_type == OP_RECV) {
1683 Sock_size_t bufsize;
1684 char namebuf[MAXPATHLEN];
1685 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1686 bufsize = sizeof (struct sockaddr_in);
1688 bufsize = sizeof namebuf;
1690 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1694 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1695 /* 'offset' means 'flags' here */
1696 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1697 (struct sockaddr *)namebuf, &bufsize);
1700 /* MSG_TRUNC can give oversized count; quietly lose it */
1703 SvCUR_set(bufsv, count);
1704 *SvEND(bufsv) = '\0';
1705 (void)SvPOK_only(bufsv);
1709 /* This should not be marked tainted if the fp is marked clean */
1710 if (!(IoFLAGS(io) & IOf_UNTAINT))
1711 SvTAINTED_on(bufsv);
1713 sv_setpvn(TARG, namebuf, bufsize);
1719 if (-offset > (SSize_t)blen)
1720 DIE(aTHX_ "Offset outside string");
1723 if (DO_UTF8(bufsv)) {
1724 /* convert offset-as-chars to offset-as-bytes */
1725 if (offset >= (SSize_t)blen)
1726 offset += SvCUR(bufsv) - blen;
1728 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1731 orig_size = SvCUR(bufsv);
1732 /* Allocating length + offset + 1 isn't perfect in the case of reading
1733 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1735 (should be 2 * length + offset + 1, or possibly something longer if
1736 PL_encoding is true) */
1737 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1738 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1739 Zero(buffer+orig_size, offset-orig_size, char);
1741 buffer = buffer + offset;
1743 read_target = bufsv;
1745 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1746 concatenate it to the current buffer. */
1748 /* Truncate the existing buffer to the start of where we will be
1750 SvCUR_set(bufsv, offset);
1752 read_target = sv_newmortal();
1753 SvUPGRADE(read_target, SVt_PV);
1754 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1757 if (PL_op->op_type == OP_SYSREAD) {
1758 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1759 if (IoTYPE(io) == IoTYPE_SOCKET) {
1760 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1766 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1772 count = PerlIO_read(IoIFP(io), buffer, length);
1773 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1774 if (count == 0 && PerlIO_error(IoIFP(io)))
1778 if (IoTYPE(io) == IoTYPE_WRONLY)
1779 report_wrongway_fh(gv, '>');
1782 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1783 *SvEND(read_target) = '\0';
1784 (void)SvPOK_only(read_target);
1785 if (fp_utf8 && !IN_BYTES) {
1786 /* Look at utf8 we got back and count the characters */
1787 const char *bend = buffer + count;
1788 while (buffer < bend) {
1790 skip = UTF8SKIP(buffer);
1793 if (buffer - charskip + skip > bend) {
1794 /* partial character - try for rest of it */
1795 length = skip - (bend-buffer);
1796 offset = bend - SvPVX_const(bufsv);
1808 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1809 provided amount read (count) was what was requested (length)
1811 if (got < wanted && count == length) {
1812 length = wanted - got;
1813 offset = bend - SvPVX_const(bufsv);
1816 /* return value is character count */
1820 else if (buffer_utf8) {
1821 /* Let svcatsv upgrade the bytes we read in to utf8.
1822 The buffer is a mortal so will be freed soon. */
1823 sv_catsv_nomg(bufsv, read_target);
1826 /* This should not be marked tainted if the fp is marked clean */
1827 if (!(IoFLAGS(io) & IOf_UNTAINT))
1828 SvTAINTED_on(bufsv);
1840 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1845 STRLEN orig_blen_bytes;
1846 const int op_type = PL_op->op_type;
1849 GV *const gv = MUTABLE_GV(*++MARK);
1850 IO *const io = GvIO(gv);
1852 if (op_type == OP_SYSWRITE && io) {
1853 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1855 if (MARK == SP - 1) {
1857 mXPUSHi(sv_len(sv));
1861 return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1862 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1872 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1874 if (io && IoIFP(io))
1875 report_wrongway_fh(gv, '<');
1878 SETERRNO(EBADF,RMS_IFI);
1882 /* Do this first to trigger any overloading. */
1883 buffer = SvPV_const(bufsv, blen);
1884 orig_blen_bytes = blen;
1885 doing_utf8 = DO_UTF8(bufsv);
1887 if (PerlIO_isutf8(IoIFP(io))) {
1888 if (!SvUTF8(bufsv)) {
1889 /* We don't modify the original scalar. */
1890 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1891 buffer = (char *) tmpbuf;
1895 else if (doing_utf8) {
1896 STRLEN tmplen = blen;
1897 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1900 buffer = (char *) tmpbuf;
1904 assert((char *)result == buffer);
1905 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1910 if (op_type == OP_SEND) {
1911 const int flags = SvIVx(*++MARK);
1914 char * const sockbuf = SvPVx(*++MARK, mlen);
1915 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1916 flags, (struct sockaddr *)sockbuf, mlen);
1920 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1926 Size_t length = 0; /* This length is in characters. */
1932 /* The SV is bytes, and we've had to upgrade it. */
1933 blen_chars = orig_blen_bytes;
1935 /* The SV really is UTF-8. */
1936 /* Don't call sv_len_utf8 on a magical or overloaded
1937 scalar, as we might get back a different result. */
1938 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
1945 length = blen_chars;
1947 #if Size_t_size > IVSIZE
1948 length = (Size_t)SvNVx(*++MARK);
1950 length = (Size_t)SvIVx(*++MARK);
1952 if ((SSize_t)length < 0) {
1954 DIE(aTHX_ "Negative length");
1959 offset = SvIVx(*++MARK);
1961 if (-offset > (IV)blen_chars) {
1963 DIE(aTHX_ "Offset outside string");
1965 offset += blen_chars;
1966 } else if (offset > (IV)blen_chars) {
1968 DIE(aTHX_ "Offset outside string");
1972 if (length > blen_chars - offset)
1973 length = blen_chars - offset;
1975 /* Here we convert length from characters to bytes. */
1976 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1977 /* Either we had to convert the SV, or the SV is magical, or
1978 the SV has overloading, in which case we can't or mustn't
1979 or mustn't call it again. */
1981 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1982 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1984 /* It's a real UTF-8 SV, and it's not going to change under
1985 us. Take advantage of any cache. */
1987 I32 len_I32 = length;
1989 /* Convert the start and end character positions to bytes.
1990 Remember that the second argument to sv_pos_u2b is relative
1992 sv_pos_u2b(bufsv, &start, &len_I32);
1999 buffer = buffer+offset;
2001 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2002 if (IoTYPE(io) == IoTYPE_SOCKET) {
2003 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
2009 /* See the note at doio.c:do_print about filesize limits. --jhi */
2010 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2019 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2022 #if Size_t_size > IVSIZE
2042 * in Perl 5.12 and later, the additional parameter is a bitmask:
2045 * 2 = eof() <- ARGV magic
2047 * I'll rely on the compiler's trace flow analysis to decide whether to
2048 * actually assign this out here, or punt it into the only block where it is
2049 * used. Doing it out here is DRY on the condition logic.
2054 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2060 if (PL_op->op_flags & OPf_SPECIAL) {
2061 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2065 gv = PL_last_in_gv; /* eof */
2073 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2074 return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2077 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2078 if (io && !IoIFP(io)) {
2079 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2081 IoFLAGS(io) &= ~IOf_START;
2082 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2084 sv_setpvs(GvSV(gv), "-");
2086 GvSV(gv) = newSVpvs("-");
2087 SvSETMAGIC(GvSV(gv));
2089 else if (!nextargv(gv))
2094 PUSHs(boolSV(do_eof(gv)));
2104 if (MAXARG != 0 && (TOPs || POPs))
2105 PL_last_in_gv = MUTABLE_GV(POPs);
2112 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2114 return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2119 SETERRNO(EBADF,RMS_IFI);
2124 #if LSEEKSIZE > IVSIZE
2125 PUSHn( do_tell(gv) );
2127 PUSHi( do_tell(gv) );
2135 const int whence = POPi;
2136 #if LSEEKSIZE > IVSIZE
2137 const Off_t offset = (Off_t)SvNVx(POPs);
2139 const Off_t offset = (Off_t)SvIVx(POPs);
2142 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2143 IO *const io = GvIO(gv);
2146 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2148 #if LSEEKSIZE > IVSIZE
2149 SV *const offset_sv = newSVnv((NV) offset);
2151 SV *const offset_sv = newSViv(offset);
2154 return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2159 if (PL_op->op_type == OP_SEEK)
2160 PUSHs(boolSV(do_seek(gv, offset, whence)));
2162 const Off_t sought = do_sysseek(gv, offset, whence);
2164 PUSHs(&PL_sv_undef);
2166 SV* const sv = sought ?
2167 #if LSEEKSIZE > IVSIZE
2172 : newSVpvn(zero_but_true, ZBTLEN);
2183 /* There seems to be no consensus on the length type of truncate()
2184 * and ftruncate(), both off_t and size_t have supporters. In
2185 * general one would think that when using large files, off_t is
2186 * at least as wide as size_t, so using an off_t should be okay. */
2187 /* XXX Configure probe for the length type of *truncate() needed XXX */
2190 #if Off_t_size > IVSIZE
2195 /* Checking for length < 0 is problematic as the type might or
2196 * might not be signed: if it is not, clever compilers will moan. */
2197 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2200 SV * const sv = POPs;
2205 if (PL_op->op_flags & OPf_SPECIAL
2206 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2207 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2214 TAINT_PROPER("truncate");
2215 if (!(fp = IoIFP(io))) {
2221 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2223 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2229 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2230 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2231 goto do_ftruncate_io;
2234 const char * const name = SvPV_nomg_const_nolen(sv);
2235 TAINT_PROPER("truncate");
2237 if (truncate(name, len) < 0)
2241 const int tmpfd = PerlLIO_open(name, O_RDWR);
2246 if (my_chsize(tmpfd, len) < 0)
2248 PerlLIO_close(tmpfd);
2257 SETERRNO(EBADF,RMS_IFI);
2265 SV * const argsv = POPs;
2266 const unsigned int func = POPu;
2267 const int optype = PL_op->op_type;
2268 GV * const gv = MUTABLE_GV(POPs);
2269 IO * const io = GvIOn(gv);
2275 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2279 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2282 s = SvPV_force(argsv, len);
2283 need = IOCPARM_LEN(func);
2285 s = Sv_Grow(argsv, need + 1);
2286 SvCUR_set(argsv, need);
2289 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2292 retval = SvIV(argsv);
2293 s = INT2PTR(char*,retval); /* ouch */
2296 TAINT_PROPER(PL_op_desc[optype]);
2298 if (optype == OP_IOCTL)
2300 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2302 DIE(aTHX_ "ioctl is not implemented");
2306 DIE(aTHX_ "fcntl is not implemented");
2308 #if defined(OS2) && defined(__EMX__)
2309 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2311 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2315 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2317 if (s[SvCUR(argsv)] != 17)
2318 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2320 s[SvCUR(argsv)] = 0; /* put our null back */
2321 SvSETMAGIC(argsv); /* Assume it has changed */
2330 PUSHp(zero_but_true, ZBTLEN);
2341 const int argtype = POPi;
2342 GV * const gv = MUTABLE_GV(POPs);
2343 IO *const io = GvIO(gv);
2344 PerlIO *const fp = io ? IoIFP(io) : NULL;
2346 /* XXX Looks to me like io is always NULL at this point */
2348 (void)PerlIO_flush(fp);
2349 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2354 SETERRNO(EBADF,RMS_IFI);
2359 DIE(aTHX_ PL_no_func, "flock()");
2370 const int protocol = POPi;
2371 const int type = POPi;
2372 const int domain = POPi;
2373 GV * const gv = MUTABLE_GV(POPs);
2374 IO * const io = GvIOn(gv);
2378 do_close(gv, FALSE);
2380 TAINT_PROPER("socket");
2381 fd = PerlSock_socket(domain, type, protocol);
2384 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2385 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2386 IoTYPE(io) = IoTYPE_SOCKET;
2387 if (!IoIFP(io) || !IoOFP(io)) {
2388 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2389 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2390 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2393 #if defined(HAS_FCNTL) && defined(F_SETFD)
2394 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2403 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2406 const int protocol = POPi;
2407 const int type = POPi;
2408 const int domain = POPi;
2410 GV * const gv2 = MUTABLE_GV(POPs);
2411 IO * const io2 = GvIOn(gv2);
2412 GV * const gv1 = MUTABLE_GV(POPs);
2413 IO * const io1 = GvIOn(gv1);
2416 do_close(gv1, FALSE);
2418 do_close(gv2, FALSE);
2420 TAINT_PROPER("socketpair");
2421 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2423 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2424 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2425 IoTYPE(io1) = IoTYPE_SOCKET;
2426 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2427 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2428 IoTYPE(io2) = IoTYPE_SOCKET;
2429 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2430 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2431 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2432 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2433 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2434 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2435 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2438 #if defined(HAS_FCNTL) && defined(F_SETFD)
2439 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2440 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2445 DIE(aTHX_ PL_no_sock_func, "socketpair");
2454 SV * const addrsv = POPs;
2455 /* OK, so on what platform does bind modify addr? */
2457 GV * const gv = MUTABLE_GV(POPs);
2458 IO * const io = GvIOn(gv);
2465 addr = SvPV_const(addrsv, len);
2466 op_type = PL_op->op_type;
2467 TAINT_PROPER(PL_op_desc[op_type]);
2468 if ((op_type == OP_BIND
2469 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2470 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2478 SETERRNO(EBADF,SS_IVCHAN);
2485 const int backlog = POPi;
2486 GV * const gv = MUTABLE_GV(POPs);
2487 IO * const io = GvIOn(gv);
2492 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2499 SETERRNO(EBADF,SS_IVCHAN);
2507 char namebuf[MAXPATHLEN];
2508 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2509 Sock_size_t len = sizeof (struct sockaddr_in);
2511 Sock_size_t len = sizeof namebuf;
2513 GV * const ggv = MUTABLE_GV(POPs);
2514 GV * const ngv = MUTABLE_GV(POPs);
2517 IO * const gstio = GvIO(ggv);
2518 if (!gstio || !IoIFP(gstio))
2522 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2525 /* Some platforms indicate zero length when an AF_UNIX client is
2526 * not bound. Simulate a non-zero-length sockaddr structure in
2528 namebuf[0] = 0; /* sun_len */
2529 namebuf[1] = AF_UNIX; /* sun_family */
2537 do_close(ngv, FALSE);
2538 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2539 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2540 IoTYPE(nstio) = IoTYPE_SOCKET;
2541 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2542 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2543 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2544 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2547 #if defined(HAS_FCNTL) && defined(F_SETFD)
2548 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2551 #ifdef __SCO_VERSION__
2552 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2555 PUSHp(namebuf, len);
2559 report_evil_fh(ggv);
2560 SETERRNO(EBADF,SS_IVCHAN);
2570 const int how = POPi;
2571 GV * const gv = MUTABLE_GV(POPs);
2572 IO * const io = GvIOn(gv);
2577 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2582 SETERRNO(EBADF,SS_IVCHAN);
2589 const int optype = PL_op->op_type;
2590 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2591 const unsigned int optname = (unsigned int) POPi;
2592 const unsigned int lvl = (unsigned int) POPi;
2593 GV * const gv = MUTABLE_GV(POPs);
2594 IO * const io = GvIOn(gv);
2598 if (!io || !IoIFP(io))
2601 fd = PerlIO_fileno(IoIFP(io));
2605 (void)SvPOK_only(sv);
2609 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2616 #if defined(__SYMBIAN32__)
2617 # define SETSOCKOPT_OPTION_VALUE_T void *
2619 # define SETSOCKOPT_OPTION_VALUE_T const char *
2621 /* XXX TODO: We need to have a proper type (a Configure probe,
2622 * etc.) for what the C headers think of the third argument of
2623 * setsockopt(), the option_value read-only buffer: is it
2624 * a "char *", or a "void *", const or not. Some compilers
2625 * don't take kindly to e.g. assuming that "char *" implicitly
2626 * promotes to a "void *", or to explicitly promoting/demoting
2627 * consts to non/vice versa. The "const void *" is the SUS
2628 * definition, but that does not fly everywhere for the above
2630 SETSOCKOPT_OPTION_VALUE_T buf;
2634 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2638 aint = (int)SvIV(sv);
2639 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2642 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2652 SETERRNO(EBADF,SS_IVCHAN);
2661 const int optype = PL_op->op_type;
2662 GV * const gv = MUTABLE_GV(POPs);
2663 IO * const io = GvIOn(gv);
2668 if (!io || !IoIFP(io))
2671 sv = sv_2mortal(newSV(257));
2672 (void)SvPOK_only(sv);
2676 fd = PerlIO_fileno(IoIFP(io));
2678 case OP_GETSOCKNAME:
2679 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2682 case OP_GETPEERNAME:
2683 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2685 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2687 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";
2688 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2689 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2690 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2691 sizeof(u_short) + sizeof(struct in_addr))) {
2698 #ifdef BOGUS_GETNAME_RETURN
2699 /* Interactive Unix, getpeername() and getsockname()
2700 does not return valid namelen */
2701 if (len == BOGUS_GETNAME_RETURN)
2702 len = sizeof(struct sockaddr);
2711 SETERRNO(EBADF,SS_IVCHAN);
2730 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2731 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2732 if (PL_op->op_type == OP_LSTAT) {
2733 if (gv != PL_defgv) {
2734 do_fstat_warning_check:
2735 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2736 "lstat() on filehandle%s%"SVf,
2739 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2741 } else if (PL_laststype != OP_LSTAT)
2742 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2743 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2746 if (gv != PL_defgv) {
2750 PL_laststype = OP_STAT;
2751 PL_statgv = gv ? gv : (GV *)io;
2752 sv_setpvs(PL_statname, "");
2759 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2761 } else if (IoDIRP(io)) {
2763 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2766 PL_laststatval = -1;
2769 else PL_laststatval = -1;
2770 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2773 if (PL_laststatval < 0) {
2778 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2779 io = MUTABLE_IO(SvRV(sv));
2780 if (PL_op->op_type == OP_LSTAT)
2781 goto do_fstat_warning_check;
2782 goto do_fstat_have_io;
2785 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2786 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2788 PL_laststype = PL_op->op_type;
2789 if (PL_op->op_type == OP_LSTAT)
2790 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2792 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2793 if (PL_laststatval < 0) {
2794 if (ckWARN(WARN_NEWLINE) &&
2795 strchr(SvPV_nolen_const(PL_statname), '\n'))
2797 /* PL_warn_nl is constant */
2798 GCC_DIAG_IGNORE(-Wformat-nonliteral);
2799 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2807 if (gimme != G_ARRAY) {
2808 if (gimme != G_VOID)
2809 XPUSHs(boolSV(max));
2815 mPUSHi(PL_statcache.st_dev);
2816 #if ST_INO_SIZE > IVSIZE
2817 mPUSHn(PL_statcache.st_ino);
2819 # if ST_INO_SIGN <= 0
2820 mPUSHi(PL_statcache.st_ino);
2822 mPUSHu(PL_statcache.st_ino);
2825 mPUSHu(PL_statcache.st_mode);
2826 mPUSHu(PL_statcache.st_nlink);
2828 sv_setuid(PUSHmortal, PL_statcache.st_uid);
2829 sv_setgid(PUSHmortal, PL_statcache.st_gid);
2831 #ifdef USE_STAT_RDEV
2832 mPUSHi(PL_statcache.st_rdev);
2834 PUSHs(newSVpvs_flags("", SVs_TEMP));
2836 #if Off_t_size > IVSIZE
2837 mPUSHn(PL_statcache.st_size);
2839 mPUSHi(PL_statcache.st_size);
2842 mPUSHn(PL_statcache.st_atime);
2843 mPUSHn(PL_statcache.st_mtime);
2844 mPUSHn(PL_statcache.st_ctime);
2846 mPUSHi(PL_statcache.st_atime);
2847 mPUSHi(PL_statcache.st_mtime);
2848 mPUSHi(PL_statcache.st_ctime);
2850 #ifdef USE_STAT_BLOCKS
2851 mPUSHu(PL_statcache.st_blksize);
2852 mPUSHu(PL_statcache.st_blocks);
2854 PUSHs(newSVpvs_flags("", SVs_TEMP));
2855 PUSHs(newSVpvs_flags("", SVs_TEMP));
2861 /* All filetest ops avoid manipulating the perl stack pointer in their main
2862 bodies (since commit d2c4d2d1e22d3125), and return using either
2863 S_ft_return_false() or S_ft_return_true(). These two helper functions are
2864 the only two which manipulate the perl stack. To ensure that no stack
2865 manipulation macros are used, the filetest ops avoid defining a local copy
2866 of the stack pointer with dSP. */
2868 /* If the next filetest is stacked up with this one
2869 (PL_op->op_private & OPpFT_STACKING), we leave
2870 the original argument on the stack for success,
2871 and skip the stacked operators on failure.
2872 The next few macros/functions take care of this.
2876 S_ft_return_false(pTHX_ SV *ret) {
2880 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
2884 if (PL_op->op_private & OPpFT_STACKING) {
2885 while (OP_IS_FILETEST(next->op_type)
2886 && next->op_private & OPpFT_STACKED)
2887 next = next->op_next;
2892 PERL_STATIC_INLINE OP *
2893 S_ft_return_true(pTHX_ SV *ret) {
2895 if (PL_op->op_flags & OPf_REF)
2896 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
2897 else if (!(PL_op->op_private & OPpFT_STACKING))
2903 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
2904 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
2905 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
2907 #define tryAMAGICftest_MG(chr) STMT_START { \
2908 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
2909 && PL_op->op_flags & OPf_KIDS) { \
2910 OP *next = S_try_amagic_ftest(aTHX_ chr); \
2911 if (next) return next; \
2916 S_try_amagic_ftest(pTHX_ char chr) {
2918 SV *const arg = *PL_stack_sp;
2921 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
2925 const char tmpchr = chr;
2926 SV * const tmpsv = amagic_call(arg,
2927 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2928 ftest_amg, AMGf_unary);
2933 return SvTRUE(tmpsv)
2934 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
2944 /* Not const, because things tweak this below. Not bool, because there's
2945 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2946 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2947 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2948 /* Giving some sort of initial value silences compilers. */
2950 int access_mode = R_OK;
2952 int access_mode = 0;
2955 /* access_mode is never used, but leaving use_access in makes the
2956 conditional compiling below much clearer. */
2959 Mode_t stat_mode = S_IRUSR;
2961 bool effective = FALSE;
2964 switch (PL_op->op_type) {
2965 case OP_FTRREAD: opchar = 'R'; break;
2966 case OP_FTRWRITE: opchar = 'W'; break;
2967 case OP_FTREXEC: opchar = 'X'; break;
2968 case OP_FTEREAD: opchar = 'r'; break;
2969 case OP_FTEWRITE: opchar = 'w'; break;
2970 case OP_FTEEXEC: opchar = 'x'; break;
2972 tryAMAGICftest_MG(opchar);
2974 switch (PL_op->op_type) {
2976 #if !(defined(HAS_ACCESS) && defined(R_OK))
2982 #if defined(HAS_ACCESS) && defined(W_OK)
2987 stat_mode = S_IWUSR;
2991 #if defined(HAS_ACCESS) && defined(X_OK)
2996 stat_mode = S_IXUSR;
3000 #ifdef PERL_EFF_ACCESS
3003 stat_mode = S_IWUSR;
3007 #ifndef PERL_EFF_ACCESS
3014 #ifdef PERL_EFF_ACCESS
3019 stat_mode = S_IXUSR;
3025 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3026 const char *name = SvPV_nolen(*PL_stack_sp);
3028 # ifdef PERL_EFF_ACCESS
3029 result = PERL_EFF_ACCESS(name, access_mode);
3031 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3037 result = access(name, access_mode);
3039 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3050 result = my_stat_flags(0);
3053 if (cando(stat_mode, effective, &PL_statcache))
3062 const int op_type = PL_op->op_type;
3066 case OP_FTIS: opchar = 'e'; break;
3067 case OP_FTSIZE: opchar = 's'; break;
3068 case OP_FTMTIME: opchar = 'M'; break;
3069 case OP_FTCTIME: opchar = 'C'; break;
3070 case OP_FTATIME: opchar = 'A'; break;
3072 tryAMAGICftest_MG(opchar);
3074 result = my_stat_flags(0);
3077 if (op_type == OP_FTIS)
3080 /* You can't dTARGET inside OP_FTIS, because you'll get
3081 "panic: pad_sv po" - the op is not flagged to have a target. */
3085 #if Off_t_size > IVSIZE
3086 sv_setnv(TARG, (NV)PL_statcache.st_size);
3088 sv_setiv(TARG, (IV)PL_statcache.st_size);
3093 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3097 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3101 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3105 return SvTRUE_nomg(TARG)
3106 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3116 switch (PL_op->op_type) {
3117 case OP_FTROWNED: opchar = 'O'; break;
3118 case OP_FTEOWNED: opchar = 'o'; break;
3119 case OP_FTZERO: opchar = 'z'; break;
3120 case OP_FTSOCK: opchar = 'S'; break;
3121 case OP_FTCHR: opchar = 'c'; break;
3122 case OP_FTBLK: opchar = 'b'; break;
3123 case OP_FTFILE: opchar = 'f'; break;
3124 case OP_FTDIR: opchar = 'd'; break;
3125 case OP_FTPIPE: opchar = 'p'; break;
3126 case OP_FTSUID: opchar = 'u'; break;
3127 case OP_FTSGID: opchar = 'g'; break;
3128 case OP_FTSVTX: opchar = 'k'; break;
3130 tryAMAGICftest_MG(opchar);
3132 /* I believe that all these three are likely to be defined on most every
3133 system these days. */
3135 if(PL_op->op_type == OP_FTSUID) {
3140 if(PL_op->op_type == OP_FTSGID) {
3145 if(PL_op->op_type == OP_FTSVTX) {
3150 result = my_stat_flags(0);
3153 switch (PL_op->op_type) {
3155 if (PL_statcache.st_uid == PerlProc_getuid())
3159 if (PL_statcache.st_uid == PerlProc_geteuid())
3163 if (PL_statcache.st_size == 0)
3167 if (S_ISSOCK(PL_statcache.st_mode))
3171 if (S_ISCHR(PL_statcache.st_mode))
3175 if (S_ISBLK(PL_statcache.st_mode))
3179 if (S_ISREG(PL_statcache.st_mode))
3183 if (S_ISDIR(PL_statcache.st_mode))
3187 if (S_ISFIFO(PL_statcache.st_mode))
3192 if (PL_statcache.st_mode & S_ISUID)
3198 if (PL_statcache.st_mode & S_ISGID)
3204 if (PL_statcache.st_mode & S_ISVTX)
3217 tryAMAGICftest_MG('l');
3218 result = my_lstat_flags(0);
3222 if (S_ISLNK(PL_statcache.st_mode))
3235 tryAMAGICftest_MG('t');
3237 if (PL_op->op_flags & OPf_REF)
3240 SV *tmpsv = *PL_stack_sp;
3241 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3242 name = SvPV_nomg(tmpsv, namelen);
3243 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3247 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3248 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3249 else if (name && isDIGIT(*name))
3253 if (PerlLIO_isatty(fd))
3271 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3273 if (PL_op->op_flags & OPf_REF)
3275 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3280 gv = MAYBE_DEREF_GV_nomg(sv);
3284 if (gv == PL_defgv) {
3286 io = SvTYPE(PL_statgv) == SVt_PVIO
3290 goto really_filename;
3295 sv_setpvs(PL_statname, "");
3296 io = GvIO(PL_statgv);
3298 PL_laststatval = -1;
3299 PL_laststype = OP_STAT;
3300 if (io && IoIFP(io)) {
3301 if (! PerlIO_has_base(IoIFP(io)))
3302 DIE(aTHX_ "-T and -B not implemented on filehandles");
3303 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3304 if (PL_laststatval < 0)
3306 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3307 if (PL_op->op_type == OP_FTTEXT)
3312 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3313 i = PerlIO_getc(IoIFP(io));
3315 (void)PerlIO_ungetc(IoIFP(io),i);
3317 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3319 len = PerlIO_get_bufsiz(IoIFP(io));
3320 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3321 /* sfio can have large buffers - limit to 512 */
3326 SETERRNO(EBADF,RMS_IFI);
3328 SETERRNO(EBADF,RMS_IFI);
3333 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3336 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3338 PL_laststatval = -1;
3339 PL_laststype = OP_STAT;
3341 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3344 /* PL_warn_nl is constant */
3345 GCC_DIAG_IGNORE(-Wformat-nonliteral);
3346 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3351 PL_laststype = OP_STAT;
3352 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3353 if (PL_laststatval < 0) {
3354 (void)PerlIO_close(fp);
3357 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3358 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3359 (void)PerlIO_close(fp);
3361 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3362 FT_RETURNNO; /* special case NFS directories */
3363 FT_RETURNYES; /* null file is anything */
3368 /* now scan s to look for textiness */
3369 /* XXX ASCII dependent code */
3371 #if defined(DOSISH) || defined(USEMYBINMODE)
3372 /* ignore trailing ^Z on short files */
3373 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3377 for (i = 0; i < len; i++, s++) {
3378 if (!*s) { /* null never allowed in text */
3383 else if (!(isPRINT(*s) || isSPACE(*s)))
3386 else if (*s & 128) {
3388 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3391 /* utf8 characters don't count as odd */
3392 if (UTF8_IS_START(*s)) {
3393 int ulen = UTF8SKIP(s);
3394 if (ulen < len - i) {
3396 for (j = 1; j < ulen; j++) {
3397 if (!UTF8_IS_CONTINUATION(s[j]))
3400 --ulen; /* loop does extra increment */
3410 *s != '\n' && *s != '\r' && *s != '\b' &&
3411 *s != '\t' && *s != '\f' && *s != 27)
3416 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3427 const char *tmps = NULL;
3431 SV * const sv = POPs;
3432 if (PL_op->op_flags & OPf_SPECIAL) {
3433 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3435 else if (!(gv = MAYBE_DEREF_GV(sv)))
3436 tmps = SvPV_nomg_const_nolen(sv);
3439 if( !gv && (!tmps || !*tmps) ) {
3440 HV * const table = GvHVn(PL_envgv);
3443 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3444 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3446 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3451 deprecate("chdir('') or chdir(undef) as chdir()");
3452 tmps = SvPV_nolen_const(*svp);
3456 TAINT_PROPER("chdir");
3461 TAINT_PROPER("chdir");
3464 IO* const io = GvIO(gv);
3467 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3468 } else if (IoIFP(io)) {
3469 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3473 SETERRNO(EBADF, RMS_IFI);
3479 SETERRNO(EBADF,RMS_IFI);
3483 DIE(aTHX_ PL_no_func, "fchdir");
3487 PUSHi( PerlDir_chdir(tmps) >= 0 );
3489 /* Clear the DEFAULT element of ENV so we'll get the new value
3491 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3498 dVAR; dSP; dMARK; dTARGET;
3499 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3510 char * const tmps = POPpx;
3511 TAINT_PROPER("chroot");
3512 PUSHi( chroot(tmps) >= 0 );
3515 DIE(aTHX_ PL_no_func, "chroot");
3523 const char * const tmps2 = POPpconstx;
3524 const char * const tmps = SvPV_nolen_const(TOPs);
3525 TAINT_PROPER("rename");
3527 anum = PerlLIO_rename(tmps, tmps2);
3529 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3530 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3533 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3534 (void)UNLINK(tmps2);
3535 if (!(anum = link(tmps, tmps2)))
3536 anum = UNLINK(tmps);
3544 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3548 const int op_type = PL_op->op_type;
3552 if (op_type == OP_LINK)
3553 DIE(aTHX_ PL_no_func, "link");
3555 # ifndef HAS_SYMLINK
3556 if (op_type == OP_SYMLINK)
3557 DIE(aTHX_ PL_no_func, "symlink");
3561 const char * const tmps2 = POPpconstx;
3562 const char * const tmps = SvPV_nolen_const(TOPs);
3563 TAINT_PROPER(PL_op_desc[op_type]);
3565 # if defined(HAS_LINK)
3566 # if defined(HAS_SYMLINK)
3567 /* Both present - need to choose which. */
3568 (op_type == OP_LINK) ?
3569 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3571 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3572 PerlLIO_link(tmps, tmps2);
3575 # if defined(HAS_SYMLINK)
3576 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3577 symlink(tmps, tmps2);
3582 SETi( result >= 0 );
3589 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3600 char buf[MAXPATHLEN];
3605 len = readlink(tmps, buf, sizeof(buf) - 1);
3612 RETSETUNDEF; /* just pretend it's a normal file */
3616 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3618 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3620 char * const save_filename = filename;
3625 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3627 PERL_ARGS_ASSERT_DOONELINER;
3629 Newx(cmdline, size, char);
3630 my_strlcpy(cmdline, cmd, size);
3631 my_strlcat(cmdline, " ", size);
3632 for (s = cmdline + strlen(cmdline); *filename; ) {
3636 if (s - cmdline < size)
3637 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3638 myfp = PerlProc_popen(cmdline, "r");
3642 SV * const tmpsv = sv_newmortal();
3643 /* Need to save/restore 'PL_rs' ?? */
3644 s = sv_gets(tmpsv, myfp, 0);
3645 (void)PerlProc_pclose(myfp);
3649 #ifdef HAS_SYS_ERRLIST
3654 /* you don't see this */
3655 const char * const errmsg = Strerror(e) ;
3658 if (instr(s, errmsg)) {
3665 #define EACCES EPERM
3667 if (instr(s, "cannot make"))
3668 SETERRNO(EEXIST,RMS_FEX);
3669 else if (instr(s, "existing file"))
3670 SETERRNO(EEXIST,RMS_FEX);
3671 else if (instr(s, "ile exists"))
3672 SETERRNO(EEXIST,RMS_FEX);
3673 else if (instr(s, "non-exist"))
3674 SETERRNO(ENOENT,RMS_FNF);
3675 else if (instr(s, "does not exist"))
3676 SETERRNO(ENOENT,RMS_FNF);
3677 else if (instr(s, "not empty"))
3678 SETERRNO(EBUSY,SS_DEVOFFLINE);
3679 else if (instr(s, "cannot access"))
3680 SETERRNO(EACCES,RMS_PRV);
3682 SETERRNO(EPERM,RMS_PRV);
3685 else { /* some mkdirs return no failure indication */
3686 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3687 if (PL_op->op_type == OP_RMDIR)
3692 SETERRNO(EACCES,RMS_PRV); /* a guess */
3701 /* This macro removes trailing slashes from a directory name.
3702 * Different operating and file systems take differently to
3703 * trailing slashes. According to POSIX 1003.1 1996 Edition
3704 * any number of trailing slashes should be allowed.
3705 * Thusly we snip them away so that even non-conforming
3706 * systems are happy.
3707 * We should probably do this "filtering" for all
3708 * the functions that expect (potentially) directory names:
3709 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3710 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3712 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3713 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3716 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3717 (tmps) = savepvn((tmps), (len)); \
3727 const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3729 TRIMSLASHES(tmps,len,copy);
3731 TAINT_PROPER("mkdir");
3733 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3737 SETi( dooneliner("mkdir", tmps) );
3738 oldumask = PerlLIO_umask(0);
3739 PerlLIO_umask(oldumask);
3740 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3755 TRIMSLASHES(tmps,len,copy);
3756 TAINT_PROPER("rmdir");
3758 SETi( PerlDir_rmdir(tmps) >= 0 );
3760 SETi( dooneliner("rmdir", tmps) );
3767 /* Directory calls. */
3771 #if defined(Direntry_t) && defined(HAS_READDIR)
3773 const char * const dirname = POPpconstx;
3774 GV * const gv = MUTABLE_GV(POPs);
3775 IO * const io = GvIOn(gv);
3777 if ((IoIFP(io) || IoOFP(io)))
3778 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3779 "Opening filehandle %"HEKf" also as a directory",
3780 HEKfARG(GvENAME_HEK(gv)) );
3782 PerlDir_close(IoDIRP(io));
3783 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3789 SETERRNO(EBADF,RMS_DIR);
3792 DIE(aTHX_ PL_no_dir_func, "opendir");
3798 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3799 DIE(aTHX_ PL_no_dir_func, "readdir");
3801 #if !defined(I_DIRENT) && !defined(VMS)
3802 Direntry_t *readdir (DIR *);
3808 const I32 gimme = GIMME;
3809 GV * const gv = MUTABLE_GV(POPs);
3810 const Direntry_t *dp;
3811 IO * const io = GvIOn(gv);
3814 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3815 "readdir() attempted on invalid dirhandle %"HEKf,
3816 HEKfARG(GvENAME_HEK(gv)));
3821 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3825 sv = newSVpvn(dp->d_name, dp->d_namlen);
3827 sv = newSVpv(dp->d_name, 0);
3829 if (!(IoFLAGS(io) & IOf_UNTAINT))
3832 } while (gimme == G_ARRAY);
3834 if (!dp && gimme != G_ARRAY)
3841 SETERRNO(EBADF,RMS_ISI);
3842 if (GIMME == G_ARRAY)
3851 #if defined(HAS_TELLDIR) || defined(telldir)
3853 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3854 /* XXX netbsd still seemed to.
3855 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3856 --JHI 1999-Feb-02 */
3857 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3858 long telldir (DIR *);
3860 GV * const gv = MUTABLE_GV(POPs);
3861 IO * const io = GvIOn(gv);
3864 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3865 "telldir() attempted on invalid dirhandle %"HEKf,
3866 HEKfARG(GvENAME_HEK(gv)));
3870 PUSHi( PerlDir_tell(IoDIRP(io)) );
3874 SETERRNO(EBADF,RMS_ISI);
3877 DIE(aTHX_ PL_no_dir_func, "telldir");
3883 #if defined(HAS_SEEKDIR) || defined(seekdir)
3885 const long along = POPl;
3886 GV * const gv = MUTABLE_GV(POPs);
3887 IO * const io = GvIOn(gv);
3890 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3891 "seekdir() attempted on invalid dirhandle %"HEKf,
3892 HEKfARG(GvENAME_HEK(gv)));
3895 (void)PerlDir_seek(IoDIRP(io), along);
3900 SETERRNO(EBADF,RMS_ISI);
3903 DIE(aTHX_ PL_no_dir_func, "seekdir");
3909 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3911 GV * const gv = MUTABLE_GV(POPs);
3912 IO * const io = GvIOn(gv);
3915 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3916 "rewinddir() attempted on invalid dirhandle %"HEKf,
3917 HEKfARG(GvENAME_HEK(gv)));
3920 (void)PerlDir_rewind(IoDIRP(io));
3924 SETERRNO(EBADF,RMS_ISI);
3927 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3933 #if defined(Direntry_t) && defined(HAS_READDIR)
3935 GV * const gv = MUTABLE_GV(POPs);
3936 IO * const io = GvIOn(gv);
3939 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3940 "closedir() attempted on invalid dirhandle %"HEKf,
3941 HEKfARG(GvENAME_HEK(gv)));
3944 #ifdef VOID_CLOSEDIR
3945 PerlDir_close(IoDIRP(io));
3947 if (PerlDir_close(IoDIRP(io)) < 0) {
3948 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3957 SETERRNO(EBADF,RMS_IFI);
3960 DIE(aTHX_ PL_no_dir_func, "closedir");
3964 /* Process control. */
3971 #ifdef HAS_SIGPROCMASK
3972 sigset_t oldmask, newmask;
3976 PERL_FLUSHALL_FOR_CHILD;
3977 #ifdef HAS_SIGPROCMASK
3978 sigfillset(&newmask);
3979 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
3981 childpid = PerlProc_fork();
3982 if (childpid == 0) {
3986 for (sig = 1; sig < SIG_SIZE; sig++)
3987 PL_psig_pend[sig] = 0;
3989 #ifdef HAS_SIGPROCMASK
3992 sigprocmask(SIG_SETMASK, &oldmask, NULL);
3999 #ifdef PERL_USES_PL_PIDSTATUS
4000 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4006 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4011 PERL_FLUSHALL_FOR_CHILD;
4012 childpid = PerlProc_fork();
4018 DIE(aTHX_ PL_no_func, "fork");
4025 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4030 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4031 childpid = wait4pid(-1, &argflags, 0);
4033 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4038 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4039 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4040 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4042 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4047 DIE(aTHX_ PL_no_func, "wait");
4053 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4055 const int optype = POPi;
4056 const Pid_t pid = TOPi;
4060 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4061 result = wait4pid(pid, &argflags, optype);
4063 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4068 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4069 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4070 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4072 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4077 DIE(aTHX_ PL_no_func, "waitpid");
4083 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4084 #if defined(__LIBCATAMOUNT__)
4085 PL_statusvalue = -1;
4094 while (++MARK <= SP) {
4095 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4100 TAINT_PROPER("system");
4102 PERL_FLUSHALL_FOR_CHILD;
4103 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4108 #ifdef HAS_SIGPROCMASK
4109 sigset_t newset, oldset;
4112 if (PerlProc_pipe(pp) >= 0)
4114 #ifdef HAS_SIGPROCMASK
4115 sigemptyset(&newset);
4116 sigaddset(&newset, SIGCHLD);
4117 sigprocmask(SIG_BLOCK, &newset, &oldset);
4119 while ((childpid = PerlProc_fork()) == -1) {
4120 if (errno != EAGAIN) {
4125 PerlLIO_close(pp[0]);
4126 PerlLIO_close(pp[1]);
4128 #ifdef HAS_SIGPROCMASK
4129 sigprocmask(SIG_SETMASK, &oldset, NULL);
4136 Sigsave_t ihand,qhand; /* place to save signals during system() */
4140 PerlLIO_close(pp[1]);
4142 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4143 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4146 result = wait4pid(childpid, &status, 0);
4147 } while (result == -1 && errno == EINTR);
4149 #ifdef HAS_SIGPROCMASK
4150 sigprocmask(SIG_SETMASK, &oldset, NULL);
4152 (void)rsignal_restore(SIGINT, &ihand);
4153 (void)rsignal_restore(SIGQUIT, &qhand);
4155 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4156 do_execfree(); /* free any memory child malloced on fork */
4163 while (n < sizeof(int)) {
4164 n1 = PerlLIO_read(pp[0],
4165 (void*)(((char*)&errkid)+n),
4171 PerlLIO_close(pp[0]);
4172 if (n) { /* Error */
4173 if (n != sizeof(int))
4174 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4175 errno = errkid; /* Propagate errno from kid */
4176 STATUS_NATIVE_CHILD_SET(-1);
4179 XPUSHi(STATUS_CURRENT);
4182 #ifdef HAS_SIGPROCMASK
4183 sigprocmask(SIG_SETMASK, &oldset, NULL);
4186 PerlLIO_close(pp[0]);
4187 #if defined(HAS_FCNTL) && defined(F_SETFD)
4188 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4191 if (PL_op->op_flags & OPf_STACKED) {
4192 SV * const really = *++MARK;
4193 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4195 else if (SP - MARK != 1)
4196 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4198 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4202 #else /* ! FORK or VMS or OS/2 */
4205 if (PL_op->op_flags & OPf_STACKED) {
4206 SV * const really = *++MARK;
4207 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4208 value = (I32)do_aspawn(really, MARK, SP);
4210 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4213 else if (SP - MARK != 1) {
4214 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4215 value = (I32)do_aspawn(NULL, MARK, SP);
4217 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4221 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4223 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4225 STATUS_NATIVE_CHILD_SET(value);
4228 XPUSHi(result ? value : STATUS_CURRENT);
4229 #endif /* !FORK or VMS or OS/2 */
4236 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4241 while (++MARK <= SP) {
4242 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4247 TAINT_PROPER("exec");
4249 PERL_FLUSHALL_FOR_CHILD;
4250 if (PL_op->op_flags & OPf_STACKED) {
4251 SV * const really = *++MARK;
4252 value = (I32)do_aexec(really, MARK, SP);
4254 else if (SP - MARK != 1)
4256 value = (I32)vms_do_aexec(NULL, MARK, SP);
4258 value = (I32)do_aexec(NULL, MARK, SP);
4262 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4264 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4277 XPUSHi( getppid() );
4280 DIE(aTHX_ PL_no_func, "getppid");
4290 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4293 pgrp = (I32)BSD_GETPGRP(pid);
4295 if (pid != 0 && pid != PerlProc_getpid())
4296 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4302 DIE(aTHX_ PL_no_func, "getpgrp()");
4312 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4313 if (MAXARG > 0) pid = TOPs && TOPi;
4319 TAINT_PROPER("setpgrp");
4321 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4323 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4324 || (pid != 0 && pid != PerlProc_getpid()))
4326 DIE(aTHX_ "setpgrp can't take arguments");
4328 SETi( setpgrp() >= 0 );
4329 #endif /* USE_BSDPGRP */
4332 DIE(aTHX_ PL_no_func, "setpgrp()");
4336 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4337 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4339 # define PRIORITY_WHICH_T(which) which
4344 #ifdef HAS_GETPRIORITY
4346 const int who = POPi;
4347 const int which = TOPi;
4348 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4351 DIE(aTHX_ PL_no_func, "getpriority()");
4357 #ifdef HAS_SETPRIORITY
4359 const int niceval = POPi;
4360 const int who = POPi;
4361 const int which = TOPi;
4362 TAINT_PROPER("setpriority");
4363 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4366 DIE(aTHX_ PL_no_func, "setpriority()");
4370 #undef PRIORITY_WHICH_T
4378 XPUSHn( time(NULL) );
4380 XPUSHi( time(NULL) );
4392 (void)PerlProc_times(&PL_timesbuf);
4394 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4395 /* struct tms, though same data */
4399 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4400 if (GIMME == G_ARRAY) {
4401 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4402 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4403 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4411 if (GIMME == G_ARRAY) {
4418 DIE(aTHX_ "times not implemented");
4420 #endif /* HAS_TIMES */
4423 /* The 32 bit int year limits the times we can represent to these
4424 boundaries with a few days wiggle room to account for time zone
4427 /* Sat Jan 3 00:00:00 -2147481748 */
4428 #define TIME_LOWER_BOUND -67768100567755200.0
4429 /* Sun Dec 29 12:00:00 2147483647 */
4430 #define TIME_UPPER_BOUND 67767976233316800.0
4439 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4440 static const char * const dayname[] =
4441 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4442 static const char * const monname[] =
4443 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4444 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4446 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4449 when = (Time64_T)now;
4452 NV input = Perl_floor(POPn);
4453 when = (Time64_T)input;
4454 if (when != input) {
4455 /* diag_listed_as: gmtime(%f) too large */
4456 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4457 "%s(%.0" NVff ") too large", opname, input);
4461 if ( TIME_LOWER_BOUND > when ) {
4462 /* diag_listed_as: gmtime(%f) too small */
4463 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4464 "%s(%.0" NVff ") too small", opname, when);
4467 else if( when > TIME_UPPER_BOUND ) {
4468 /* diag_listed_as: gmtime(%f) too small */
4469 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4470 "%s(%.0" NVff ") too large", opname, when);
4474 if (PL_op->op_type == OP_LOCALTIME)
4475 err = S_localtime64_r(&when, &tmbuf);
4477 err = S_gmtime64_r(&when, &tmbuf);
4481 /* XXX %lld broken for quads */
4482 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4483 "%s(%.0" NVff ") failed", opname, when);
4486 if (GIMME != G_ARRAY) { /* scalar context */
4488 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4489 double year = (double)tmbuf.tm_year + 1900;
4496 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4497 dayname[tmbuf.tm_wday],
4498 monname[tmbuf.tm_mon],
4506 else { /* list context */
4512 mPUSHi(tmbuf.tm_sec);
4513 mPUSHi(tmbuf.tm_min);
4514 mPUSHi(tmbuf.tm_hour);
4515 mPUSHi(tmbuf.tm_mday);
4516 mPUSHi(tmbuf.tm_mon);
4517 mPUSHn(tmbuf.tm_year);
4518 mPUSHi(tmbuf.tm_wday);
4519 mPUSHi(tmbuf.tm_yday);
4520 mPUSHi(tmbuf.tm_isdst);
4531 anum = alarm((unsigned int)anum);
4537 DIE(aTHX_ PL_no_func, "alarm");
4548 (void)time(&lasttime);
4549 if (MAXARG < 1 || (!TOPs && !POPs))
4553 PerlProc_sleep((unsigned int)duration);
4556 XPUSHi(when - lasttime);
4560 /* Shared memory. */
4561 /* Merged with some message passing. */
4565 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4566 dVAR; dSP; dMARK; dTARGET;
4567 const int op_type = PL_op->op_type;
4572 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4575 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4578 value = (I32)(do_semop(MARK, SP) >= 0);
4581 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4589 return Perl_pp_semget(aTHX);
4597 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4598 dVAR; dSP; dMARK; dTARGET;
4599 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4606 DIE(aTHX_ "System V IPC is not implemented on this machine");
4612 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4613 dVAR; dSP; dMARK; dTARGET;
4614 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4622 PUSHp(zero_but_true, ZBTLEN);
4626 return Perl_pp_semget(aTHX);
4630 /* I can't const this further without getting warnings about the types of
4631 various arrays passed in from structures. */
4633 S_space_join_names_mortal(pTHX_ char *const *array)
4637 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4639 if (array && *array) {
4640 target = newSVpvs_flags("", SVs_TEMP);
4642 sv_catpv(target, *array);
4645 sv_catpvs(target, " ");
4648 target = sv_mortalcopy(&PL_sv_no);
4653 /* Get system info. */
4657 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4659 I32 which = PL_op->op_type;
4662 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4663 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4664 struct hostent *gethostbyname(Netdb_name_t);
4665 struct hostent *gethostent(void);
4667 struct hostent *hent = NULL;
4671 if (which == OP_GHBYNAME) {
4672 #ifdef HAS_GETHOSTBYNAME
4673 const char* const name = POPpbytex;
4674 hent = PerlSock_gethostbyname(name);
4676 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4679 else if (which == OP_GHBYADDR) {
4680 #ifdef HAS_GETHOSTBYADDR
4681 const int addrtype = POPi;
4682 SV * const addrsv = POPs;
4684 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4686 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4688 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4692 #ifdef HAS_GETHOSTENT
4693 hent = PerlSock_gethostent();
4695 DIE(aTHX_ PL_no_sock_func, "gethostent");
4698 #ifdef HOST_NOT_FOUND
4700 #ifdef USE_REENTRANT_API
4701 # ifdef USE_GETHOSTENT_ERRNO
4702 h_errno = PL_reentrant_buffer->_gethostent_errno;
4705 STATUS_UNIX_SET(h_errno);
4709 if (GIMME != G_ARRAY) {
4710 PUSHs(sv = sv_newmortal());
4712 if (which == OP_GHBYNAME) {
4714 sv_setpvn(sv, hent->h_addr, hent->h_length);
4717 sv_setpv(sv, (char*)hent->h_name);
4723 mPUSHs(newSVpv((char*)hent->h_name, 0));
4724 PUSHs(space_join_names_mortal(hent->h_aliases));
4725 mPUSHi(hent->h_addrtype);
4726 len = hent->h_length;
4729 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4730 mXPUSHp(*elem, len);
4734 mPUSHp(hent->h_addr, len);
4736 PUSHs(sv_mortalcopy(&PL_sv_no));
4741 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4747 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4749 I32 which = PL_op->op_type;
4751 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4752 struct netent *getnetbyaddr(Netdb_net_t, int);
4753 struct netent *getnetbyname(Netdb_name_t);
4754 struct netent *getnetent(void);
4756 struct netent *nent;
4758 if (which == OP_GNBYNAME){
4759 #ifdef HAS_GETNETBYNAME
4760 const char * const name = POPpbytex;
4761 nent = PerlSock_getnetbyname(name);
4763 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4766 else if (which == OP_GNBYADDR) {
4767 #ifdef HAS_GETNETBYADDR
4768 const int addrtype = POPi;
4769 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4770 nent = PerlSock_getnetbyaddr(addr, addrtype);
4772 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4776 #ifdef HAS_GETNETENT
4777 nent = PerlSock_getnetent();
4779 DIE(aTHX_ PL_no_sock_func, "getnetent");
4782 #ifdef HOST_NOT_FOUND
4784 #ifdef USE_REENTRANT_API
4785 # ifdef USE_GETNETENT_ERRNO
4786 h_errno = PL_reentrant_buffer->_getnetent_errno;
4789 STATUS_UNIX_SET(h_errno);
4794 if (GIMME != G_ARRAY) {
4795 PUSHs(sv = sv_newmortal());
4797 if (which == OP_GNBYNAME)
4798 sv_setiv(sv, (IV)nent->n_net);
4800 sv_setpv(sv, nent->n_name);
4806 mPUSHs(newSVpv(nent->n_name, 0));
4807 PUSHs(space_join_names_mortal(nent->n_aliases));
4808 mPUSHi(nent->n_addrtype);
4809 mPUSHi(nent->n_net);
4814 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4820 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4822 I32 which = PL_op->op_type;
4824 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4825 struct protoent *getprotobyname(Netdb_name_t);
4826 struct protoent *getprotobynumber(int);
4827 struct protoent *getprotoent(void);
4829 struct protoent *pent;
4831 if (which == OP_GPBYNAME) {
4832 #ifdef HAS_GETPROTOBYNAME
4833 const char* const name = POPpbytex;
4834 pent = PerlSock_getprotobyname(name);
4836 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4839 else if (which == OP_GPBYNUMBER) {
4840 #ifdef HAS_GETPROTOBYNUMBER
4841 const int number = POPi;
4842 pent = PerlSock_getprotobynumber(number);
4844 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4848 #ifdef HAS_GETPROTOENT
4849 pent = PerlSock_getprotoent();
4851 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4855 if (GIMME != G_ARRAY) {
4856 PUSHs(sv = sv_newmortal());
4858 if (which == OP_GPBYNAME)
4859 sv_setiv(sv, (IV)pent->p_proto);
4861 sv_setpv(sv, pent->p_name);
4867 mPUSHs(newSVpv(pent->p_name, 0));
4868 PUSHs(space_join_names_mortal(pent->p_aliases));
4869 mPUSHi(pent->p_proto);
4874 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4880 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4882 I32 which = PL_op->op_type;
4884 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4885 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4886 struct servent *getservbyport(int, Netdb_name_t);
4887 struct servent *getservent(void);
4889 struct servent *sent;
4891 if (which == OP_GSBYNAME) {
4892 #ifdef HAS_GETSERVBYNAME
4893 const char * const proto = POPpbytex;
4894 const char * const name = POPpbytex;
4895 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4897 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4900 else if (which == OP_GSBYPORT) {
4901 #ifdef HAS_GETSERVBYPORT
4902 const char * const proto = POPpbytex;
4903 unsigned short port = (unsigned short)POPu;
4904 port = PerlSock_htons(port);
4905 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4907 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4911 #ifdef HAS_GETSERVENT
4912 sent = PerlSock_getservent();
4914 DIE(aTHX_ PL_no_sock_func, "getservent");
4918 if (GIMME != G_ARRAY) {
4919 PUSHs(sv = sv_newmortal());
4921 if (which == OP_GSBYNAME) {
4922 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4925 sv_setpv(sv, sent->s_name);
4931 mPUSHs(newSVpv(sent->s_name, 0));
4932 PUSHs(space_join_names_mortal(sent->s_aliases));
4933 mPUSHi(PerlSock_ntohs(sent->s_port));
4934 mPUSHs(newSVpv(sent->s_proto, 0));
4939 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4946 const int stayopen = TOPi;
4947 switch(PL_op->op_type) {
4949 #ifdef HAS_SETHOSTENT
4950 PerlSock_sethostent(stayopen);
4952 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4955 #ifdef HAS_SETNETENT
4957 PerlSock_setnetent(stayopen);
4959 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4963 #ifdef HAS_SETPROTOENT
4964 PerlSock_setprotoent(stayopen);
4966 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4970 #ifdef HAS_SETSERVENT
4971 PerlSock_setservent(stayopen);
4973 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4983 switch(PL_op->op_type) {
4985 #ifdef HAS_ENDHOSTENT
4986 PerlSock_endhostent();
4988 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4992 #ifdef HAS_ENDNETENT
4993 PerlSock_endnetent();
4995 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4999 #ifdef HAS_ENDPROTOENT
5000 PerlSock_endprotoent();
5002 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5006 #ifdef HAS_ENDSERVENT
5007 PerlSock_endservent();
5009 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5013 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5016 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5020 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5023 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5027 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5030 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5034 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5037 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5049 I32 which = PL_op->op_type;
5051 struct passwd *pwent = NULL;
5053 * We currently support only the SysV getsp* shadow password interface.
5054 * The interface is declared in <shadow.h> and often one needs to link
5055 * with -lsecurity or some such.
5056 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5059 * AIX getpwnam() is clever enough to return the encrypted password
5060 * only if the caller (euid?) is root.
5062 * There are at least three other shadow password APIs. Many platforms
5063 * seem to contain more than one interface for accessing the shadow
5064 * password databases, possibly for compatibility reasons.
5065 * The getsp*() is by far he simplest one, the other two interfaces
5066 * are much more complicated, but also very similar to each other.
5071 * struct pr_passwd *getprpw*();
5072 * The password is in
5073 * char getprpw*(...).ufld.fd_encrypt[]
5074 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5079 * struct es_passwd *getespw*();
5080 * The password is in
5081 * char *(getespw*(...).ufld.fd_encrypt)
5082 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5085 * struct userpw *getuserpw();
5086 * The password is in
5087 * char *(getuserpw(...)).spw_upw_passwd
5088 * (but the de facto standard getpwnam() should work okay)
5090 * Mention I_PROT here so that Configure probes for it.
5092 * In HP-UX for getprpw*() the manual page claims that one should include
5093 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5094 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5095 * and pp_sys.c already includes <shadow.h> if there is such.
5097 * Note that <sys/security.h> is already probed for, but currently
5098 * it is only included in special cases.
5100 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5101 * be preferred interface, even though also the getprpw*() interface
5102 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5103 * One also needs to call set_auth_parameters() in main() before
5104 * doing anything else, whether one is using getespw*() or getprpw*().
5106 * Note that accessing the shadow databases can be magnitudes
5107 * slower than accessing the standard databases.
5112 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5113 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5114 * the pw_comment is left uninitialized. */
5115 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5121 const char* const name = POPpbytex;
5122 pwent = getpwnam(name);
5128 pwent = getpwuid(uid);
5132 # ifdef HAS_GETPWENT
5134 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5135 if (pwent) pwent = getpwnam(pwent->pw_name);
5138 DIE(aTHX_ PL_no_func, "getpwent");
5144 if (GIMME != G_ARRAY) {
5145 PUSHs(sv = sv_newmortal());
5147 if (which == OP_GPWNAM)
5148 sv_setuid(sv, pwent->pw_uid);
5150 sv_setpv(sv, pwent->pw_name);
5156 mPUSHs(newSVpv(pwent->pw_name, 0));
5160 /* If we have getspnam(), we try to dig up the shadow
5161 * password. If we are underprivileged, the shadow
5162 * interface will set the errno to EACCES or similar,
5163 * and return a null pointer. If this happens, we will
5164 * use the dummy password (usually "*" or "x") from the
5165 * standard password database.
5167 * In theory we could skip the shadow call completely
5168 * if euid != 0 but in practice we cannot know which
5169 * security measures are guarding the shadow databases
5170 * on a random platform.
5172 * Resist the urge to use additional shadow interfaces.
5173 * Divert the urge to writing an extension instead.
5176 /* Some AIX setups falsely(?) detect some getspnam(), which
5177 * has a different API than the Solaris/IRIX one. */
5178 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5181 const struct spwd * const spwent = getspnam(pwent->pw_name);
5182 /* Save and restore errno so that
5183 * underprivileged attempts seem
5184 * to have never made the unsuccessful
5185 * attempt to retrieve the shadow password. */
5187 if (spwent && spwent->sp_pwdp)
5188 sv_setpv(sv, spwent->sp_pwdp);
5192 if (!SvPOK(sv)) /* Use the standard password, then. */
5193 sv_setpv(sv, pwent->pw_passwd);
5196 /* passwd is tainted because user himself can diddle with it.
5197 * admittedly not much and in a very limited way, but nevertheless. */
5200 sv_setuid(PUSHmortal, pwent->pw_uid);
5201 sv_setgid(PUSHmortal, pwent->pw_gid);
5203 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5204 * because of the poor interface of the Perl getpw*(),
5205 * not because there's some standard/convention saying so.
5206 * A better interface would have been to return a hash,
5207 * but we are accursed by our history, alas. --jhi. */
5209 mPUSHi(pwent->pw_change);
5212 mPUSHi(pwent->pw_quota);
5215 mPUSHs(newSVpv(pwent->pw_age, 0));
5217 /* I think that you can never get this compiled, but just in case. */
5218 PUSHs(sv_mortalcopy(&PL_sv_no));
5223 /* pw_class and pw_comment are mutually exclusive--.
5224 * see the above note for pw_change, pw_quota, and pw_age. */
5226 mPUSHs(newSVpv(pwent->pw_class, 0));
5229 mPUSHs(newSVpv(pwent->pw_comment, 0));
5231 /* I think that you can never get this compiled, but just in case. */
5232 PUSHs(sv_mortalcopy(&PL_sv_no));
5237 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5239 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5241 /* pw_gecos is tainted because user himself can diddle with it. */
5244 mPUSHs(newSVpv(pwent->pw_dir, 0));
5246 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5247 /* pw_shell is tainted because user himself can diddle with it. */
5251 mPUSHi(pwent->pw_expire);
5256 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5264 const I32 which = PL_op->op_type;
5265 const struct group *grent;
5267 if (which == OP_GGRNAM) {
5268 const char* const name = POPpbytex;
5269 grent = (const struct group *)getgrnam(name);
5271 else if (which == OP_GGRGID) {
5272 const Gid_t gid = POPi;
5273 grent = (const struct group *)getgrgid(gid);
5277 grent = (struct group *)getgrent();
5279 DIE(aTHX_ PL_no_func, "getgrent");
5283 if (GIMME != G_ARRAY) {
5284 SV * const sv = sv_newmortal();
5288 if (which == OP_GGRNAM)
5289 sv_setgid(sv, grent->gr_gid);
5291 sv_setpv(sv, grent->gr_name);
5297 mPUSHs(newSVpv(grent->gr_name, 0));
5300 mPUSHs(newSVpv(grent->gr_passwd, 0));
5302 PUSHs(sv_mortalcopy(&PL_sv_no));
5305 sv_setgid(PUSHmortal, grent->gr_gid);
5307 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5308 /* In UNICOS/mk (_CRAYMPP) the multithreading
5309 * versions (getgrnam_r, getgrgid_r)
5310 * seem to return an illegal pointer
5311 * as the group members list, gr_mem.
5312 * getgrent() doesn't even have a _r version
5313 * but the gr_mem is poisonous anyway.
5314 * So yes, you cannot get the list of group
5315 * members if building multithreaded in UNICOS/mk. */
5316 PUSHs(space_join_names_mortal(grent->gr_mem));
5322 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5332 if (!(tmps = PerlProc_getlogin()))
5334 sv_setpv_mg(TARG, tmps);
5338 DIE(aTHX_ PL_no_func, "getlogin");
5342 /* Miscellaneous. */
5347 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5348 I32 items = SP - MARK;
5349 unsigned long a[20];
5354 while (++MARK <= SP) {
5355 if (SvTAINTED(*MARK)) {
5361 TAINT_PROPER("syscall");
5364 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5365 * or where sizeof(long) != sizeof(char*). But such machines will
5366 * not likely have syscall implemented either, so who cares?
5368 while (++MARK <= SP) {
5369 if (SvNIOK(*MARK) || !i)
5370 a[i++] = SvIV(*MARK);
5371 else if (*MARK == &PL_sv_undef)
5374 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5380 DIE(aTHX_ "Too many args to syscall");
5382 DIE(aTHX_ "Too few args to syscall");
5384 retval = syscall(a[0]);
5387 retval = syscall(a[0],a[1]);
5390 retval = syscall(a[0],a[1],a[2]);
5393 retval = syscall(a[0],a[1],a[2],a[3]);
5396 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5399 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5402 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5405 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5412 DIE(aTHX_ PL_no_func, "syscall");
5416 #ifdef FCNTL_EMULATE_FLOCK
5418 /* XXX Emulate flock() with fcntl().
5419 What's really needed is a good file locking module.
5423 fcntl_emulate_flock(int fd, int operation)
5428 switch (operation & ~LOCK_NB) {
5430 flock.l_type = F_RDLCK;
5433 flock.l_type = F_WRLCK;
5436 flock.l_type = F_UNLCK;
5442 flock.l_whence = SEEK_SET;
5443 flock.l_start = flock.l_len = (Off_t)0;
5445 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5446 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5447 errno = EWOULDBLOCK;
5451 #endif /* FCNTL_EMULATE_FLOCK */
5453 #ifdef LOCKF_EMULATE_FLOCK
5455 /* XXX Emulate flock() with lockf(). This is just to increase
5456 portability of scripts. The calls are not completely
5457 interchangeable. What's really needed is a good file
5461 /* The lockf() constants might have been defined in <unistd.h>.
5462 Unfortunately, <unistd.h> causes troubles on some mixed
5463 (BSD/POSIX) systems, such as SunOS 4.1.3.
5465 Further, the lockf() constants aren't POSIX, so they might not be
5466 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5467 just stick in the SVID values and be done with it. Sigh.
5471 # define F_ULOCK 0 /* Unlock a previously locked region */
5474 # define F_LOCK 1 /* Lock a region for exclusive use */
5477 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5480 # define F_TEST 3 /* Test a region for other processes locks */
5484 lockf_emulate_flock(int fd, int operation)
5490 /* flock locks entire file so for lockf we need to do the same */
5491 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5492 if (pos > 0) /* is seekable and needs to be repositioned */
5493 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5494 pos = -1; /* seek failed, so don't seek back afterwards */
5497 switch (operation) {
5499 /* LOCK_SH - get a shared lock */
5501 /* LOCK_EX - get an exclusive lock */
5503 i = lockf (fd, F_LOCK, 0);
5506 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5507 case LOCK_SH|LOCK_NB:
5508 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5509 case LOCK_EX|LOCK_NB:
5510 i = lockf (fd, F_TLOCK, 0);
5512 if ((errno == EAGAIN) || (errno == EACCES))
5513 errno = EWOULDBLOCK;
5516 /* LOCK_UN - unlock (non-blocking is a no-op) */
5518 case LOCK_UN|LOCK_NB:
5519 i = lockf (fd, F_ULOCK, 0);
5522 /* Default - can't decipher operation */
5529 if (pos > 0) /* need to restore position of the handle */
5530 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5535 #endif /* LOCKF_EMULATE_FLOCK */
5539 * c-indentation-style: bsd
5541 * indent-tabs-mode: nil
5544 * ex: set ts=8 sts=4 sw=4 et: