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_open6(gv, tmps, len, NULL, MARK+1, (SP-MARK));
644 PUSHi( (I32)PL_forkprocess );
645 else if (PL_forkprocess == 0) /* we are a new child */
656 MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
662 IO * const io = GvIO(gv);
664 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
666 return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg);
670 PUSHs(boolSV(do_close(gv, TRUE)));
683 GV * const wgv = MUTABLE_GV(POPs);
684 GV * const rgv = MUTABLE_GV(POPs);
686 assert (isGV_with_GP(rgv));
687 assert (isGV_with_GP(wgv));
690 do_close(rgv, FALSE);
694 do_close(wgv, FALSE);
696 if (PerlProc_pipe(fd) < 0)
699 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
700 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
701 IoOFP(rstio) = IoIFP(rstio);
702 IoIFP(wstio) = IoOFP(wstio);
703 IoTYPE(rstio) = IoTYPE_RDONLY;
704 IoTYPE(wstio) = IoTYPE_WRONLY;
706 if (!IoIFP(rstio) || !IoOFP(wstio)) {
708 PerlIO_close(IoIFP(rstio));
710 PerlLIO_close(fd[0]);
712 PerlIO_close(IoOFP(wstio));
714 PerlLIO_close(fd[1]);
717 #if defined(HAS_FCNTL) && defined(F_SETFD)
718 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
719 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
726 DIE(aTHX_ PL_no_func, "pipe");
740 gv = MUTABLE_GV(POPs);
744 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
746 return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg);
749 if (!io || !(fp = IoIFP(io))) {
750 /* Can't do this because people seem to do things like
751 defined(fileno($foo)) to check whether $foo is a valid fh.
758 PUSHi(PerlIO_fileno(fp));
770 if (MAXARG < 1 || (!TOPs && !POPs)) {
771 anum = PerlLIO_umask(022);
772 /* setting it to 022 between the two calls to umask avoids
773 * to have a window where the umask is set to 0 -- meaning
774 * that another thread could create world-writeable files. */
776 (void)PerlLIO_umask(anum);
779 anum = PerlLIO_umask(POPi);
780 TAINT_PROPER("umask");
783 /* Only DIE if trying to restrict permissions on "user" (self).
784 * Otherwise it's harmless and more useful to just return undef
785 * since 'group' and 'other' concepts probably don't exist here. */
786 if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
787 DIE(aTHX_ "umask not implemented");
788 XPUSHs(&PL_sv_undef);
807 gv = MUTABLE_GV(POPs);
811 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
813 /* This takes advantage of the implementation of the varargs
814 function, which I don't think that the optimiser will be able to
815 figure out. Although, as it's a static function, in theory it
817 return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg,
818 G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
819 discp ? 1 : 0, discp);
823 if (!io || !(fp = IoIFP(io))) {
825 SETERRNO(EBADF,RMS_IFI);
832 const char *d = NULL;
835 d = SvPV_const(discp, len);
836 mode = mode_from_discipline(d, len);
837 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
838 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
839 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
860 const I32 markoff = MARK - PL_stack_base;
861 const char *methname;
862 int how = PERL_MAGIC_tied;
866 switch(SvTYPE(varsv)) {
870 methname = "TIEHASH";
871 if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
872 HvLAZYDEL_off(varsv);
873 hv_free_ent((HV *)varsv, entry);
875 HvEITER_set(MUTABLE_HV(varsv), 0);
879 methname = "TIEARRAY";
880 if (!AvREAL(varsv)) {
882 Perl_croak(aTHX_ "Cannot tie unreifiable array");
883 av_clear((AV *)varsv);
890 if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
891 methname = "TIEHANDLE";
892 how = PERL_MAGIC_tiedscalar;
893 /* For tied filehandles, we apply tiedscalar magic to the IO
894 slot of the GP rather than the GV itself. AMS 20010812 */
896 GvIOp(varsv) = newIO();
897 varsv = MUTABLE_SV(GvIOp(varsv));
900 if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
901 vivify_defelem(varsv);
902 varsv = LvTARG(varsv);
906 methname = "TIESCALAR";
907 how = PERL_MAGIC_tiedscalar;
911 if (sv_isobject(*MARK)) { /* Calls GET magic. */
912 ENTER_with_name("call_TIE");
913 PUSHSTACKi(PERLSI_MAGIC);
915 EXTEND(SP,(I32)items);
919 call_method(methname, G_SCALAR);
922 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
923 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
924 * wrong error message, and worse case, supreme action at a distance.
925 * (Sorry obfuscation writers. You're not going to be given this one.)
927 stash = gv_stashsv(*MARK, 0);
928 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
929 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
930 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
932 ENTER_with_name("call_TIE");
933 PUSHSTACKi(PERLSI_MAGIC);
935 EXTEND(SP,(I32)items);
939 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
945 if (sv_isobject(sv)) {
946 sv_unmagic(varsv, how);
947 /* Croak if a self-tie on an aggregate is attempted. */
948 if (varsv == SvRV(sv) &&
949 (SvTYPE(varsv) == SVt_PVAV ||
950 SvTYPE(varsv) == SVt_PVHV))
952 "Self-ties of arrays and hashes are not supported");
953 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
955 LEAVE_with_name("call_TIE");
956 SP = PL_stack_base + markoff;
966 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
967 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
969 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
972 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
973 !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
975 if ((mg = SvTIED_mg(sv, how))) {
976 SV * const obj = SvRV(SvTIED_obj(sv, mg));
978 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
980 if (gv && isGV(gv) && (cv = GvCV(gv))) {
982 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
983 mXPUSHi(SvREFCNT(obj) - 1);
985 ENTER_with_name("call_UNTIE");
986 call_sv(MUTABLE_SV(cv), G_VOID);
987 LEAVE_with_name("call_UNTIE");
990 else if (mg && SvREFCNT(obj) > 1) {
991 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
992 "untie attempted while %"UVuf" inner references still exist",
993 (UV)SvREFCNT(obj) - 1 ) ;
997 sv_unmagic(sv, how) ;
1007 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1008 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1010 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1013 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1014 !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
1016 if ((mg = SvTIED_mg(sv, how))) {
1017 PUSHs(SvTIED_obj(sv, mg));
1030 HV * const hv = MUTABLE_HV(POPs);
1031 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1032 stash = gv_stashsv(sv, 0);
1033 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1035 require_pv("AnyDBM_File.pm");
1037 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1038 DIE(aTHX_ "No dbm on this machine");
1048 mPUSHu(O_RDWR|O_CREAT);
1052 if (!SvOK(right)) right = &PL_sv_no;
1056 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1059 if (!sv_isobject(TOPs)) {
1067 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1071 if (sv_isobject(TOPs)) {
1072 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1073 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1090 struct timeval timebuf;
1091 struct timeval *tbuf = &timebuf;
1094 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1099 # if BYTEORDER & 0xf0000
1100 # define ORDERBYTE (0x88888888 - BYTEORDER)
1102 # define ORDERBYTE (0x4444 - BYTEORDER)
1108 for (i = 1; i <= 3; i++) {
1109 SV * const sv = SP[i];
1113 if (SvREADONLY(sv)) {
1114 if (!(SvPOK(sv) && SvCUR(sv) == 0))
1115 Perl_croak_no_modify();
1117 else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
1120 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1121 "Non-string passed as bitmask");
1122 SvPV_force_nomg_nolen(sv); /* force string conversion */
1129 /* little endians can use vecs directly */
1130 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1137 masksize = NFDBITS / NBBY;
1139 masksize = sizeof(long); /* documented int, everyone seems to use long */
1141 Zero(&fd_sets[0], 4, char*);
1144 # if SELECT_MIN_BITS == 1
1145 growsize = sizeof(fd_set);
1147 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1148 # undef SELECT_MIN_BITS
1149 # define SELECT_MIN_BITS __FD_SETSIZE
1151 /* If SELECT_MIN_BITS is greater than one we most probably will want
1152 * to align the sizes with SELECT_MIN_BITS/8 because for example
1153 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1154 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1155 * on (sets/tests/clears bits) is 32 bits. */
1156 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1162 value = SvNV_nomg(sv);
1165 timebuf.tv_sec = (long)value;
1166 value -= (NV)timebuf.tv_sec;
1167 timebuf.tv_usec = (long)(value * 1000000.0);
1172 for (i = 1; i <= 3; i++) {
1174 if (!SvOK(sv) || SvCUR(sv) == 0) {
1181 Sv_Grow(sv, growsize);
1185 while (++j <= growsize) {
1189 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1191 Newx(fd_sets[i], growsize, char);
1192 for (offset = 0; offset < growsize; offset += masksize) {
1193 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1194 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1197 fd_sets[i] = SvPVX(sv);
1201 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1202 /* Can't make just the (void*) conditional because that would be
1203 * cpp #if within cpp macro, and not all compilers like that. */
1204 nfound = PerlSock_select(
1206 (Select_fd_set_t) fd_sets[1],
1207 (Select_fd_set_t) fd_sets[2],
1208 (Select_fd_set_t) fd_sets[3],
1209 (void*) tbuf); /* Workaround for compiler bug. */
1211 nfound = PerlSock_select(
1213 (Select_fd_set_t) fd_sets[1],
1214 (Select_fd_set_t) fd_sets[2],
1215 (Select_fd_set_t) fd_sets[3],
1218 for (i = 1; i <= 3; i++) {
1221 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1223 for (offset = 0; offset < growsize; offset += masksize) {
1224 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1225 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1227 Safefree(fd_sets[i]);
1234 if (GIMME == G_ARRAY && tbuf) {
1235 value = (NV)(timebuf.tv_sec) +
1236 (NV)(timebuf.tv_usec) / 1000000.0;
1241 DIE(aTHX_ "select not implemented");
1246 =for apidoc setdefout
1248 Sets PL_defoutgv, the default file handle for output, to the passed in
1249 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1250 count of the passed in typeglob is increased by one, and the reference count
1251 of the typeglob that PL_defoutgv points to is decreased by one.
1257 Perl_setdefout(pTHX_ GV *gv)
1260 PERL_ARGS_ASSERT_SETDEFOUT;
1261 SvREFCNT_inc_simple_void_NN(gv);
1262 SvREFCNT_dec(PL_defoutgv);
1270 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1271 GV * egv = GvEGVx(PL_defoutgv);
1276 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1277 gvp = hv && HvENAME(hv)
1278 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1280 if (gvp && *gvp == egv) {
1281 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1285 mXPUSHs(newRV(MUTABLE_SV(egv)));
1289 if (!GvIO(newdefout))
1290 gv_IOadd(newdefout);
1291 setdefout(newdefout);
1301 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1302 IO *const io = GvIO(gv);
1308 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1310 const U32 gimme = GIMME_V;
1311 Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1312 if (gimme == G_SCALAR) {
1314 SvSetMagicSV_nosteal(TARG, TOPs);
1319 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1320 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1322 SETERRNO(EBADF,RMS_IFI);
1326 sv_setpvs(TARG, " ");
1327 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1328 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1329 /* Find out how many bytes the char needs */
1330 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1333 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1334 SvCUR_set(TARG,1+len);
1338 else SvUTF8_off(TARG);
1344 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1348 const I32 gimme = GIMME_V;
1350 PERL_ARGS_ASSERT_DOFORM;
1353 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1358 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1359 PUSHFORMAT(cx, retop);
1360 if (CvDEPTH(cv) >= 2) {
1361 PERL_STACK_OVERFLOW_CHECK();
1362 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1365 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1367 setdefout(gv); /* locally select filehandle so $% et al work */
1386 gv = MUTABLE_GV(POPs);
1403 tmpsv = sv_newmortal();
1404 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1405 DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
1407 IoFLAGS(io) &= ~IOf_DIDTOP;
1408 RETURNOP(doform(cv,gv,PL_op->op_next));
1414 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1415 IO * const io = GvIOp(gv);
1423 if (!io || !(ofp = IoOFP(io)))
1426 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1427 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1429 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1430 PL_formtarget != PL_toptarget)
1434 if (!IoTOP_GV(io)) {
1437 if (!IoTOP_NAME(io)) {
1439 if (!IoFMT_NAME(io))
1440 IoFMT_NAME(io) = savepv(GvNAME(gv));
1441 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1442 HEKfARG(GvNAME_HEK(gv))));
1443 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1444 if ((topgv && GvFORM(topgv)) ||
1445 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1446 IoTOP_NAME(io) = savesvpv(topname);
1448 IoTOP_NAME(io) = savepvs("top");
1450 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1451 if (!topgv || !GvFORM(topgv)) {
1452 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1455 IoTOP_GV(io) = topgv;
1457 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1458 I32 lines = IoLINES_LEFT(io);
1459 const char *s = SvPVX_const(PL_formtarget);
1460 if (lines <= 0) /* Yow, header didn't even fit!!! */
1462 while (lines-- > 0) {
1463 s = strchr(s, '\n');
1469 const STRLEN save = SvCUR(PL_formtarget);
1470 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1471 do_print(PL_formtarget, ofp);
1472 SvCUR_set(PL_formtarget, save);
1473 sv_chop(PL_formtarget, s);
1474 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1477 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1478 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1479 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1481 PL_formtarget = PL_toptarget;
1482 IoFLAGS(io) |= IOf_DIDTOP;
1484 assert(fgv); /* IoTOP_GV(io) should have been set above */
1487 SV * const sv = sv_newmortal();
1488 gv_efullname4(sv, fgv, NULL, FALSE);
1489 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1491 return doform(cv, gv, PL_op);
1495 POPBLOCK(cx,PL_curpm);
1496 retop = cx->blk_sub.retop;
1498 SP = newsp; /* ignore retval of formline */
1501 if (!io || !(fp = IoOFP(io))) {
1502 if (io && IoIFP(io))
1503 report_wrongway_fh(gv, '<');
1509 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1510 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1512 if (!do_print(PL_formtarget, fp))
1515 FmLINES(PL_formtarget) = 0;
1516 SvCUR_set(PL_formtarget, 0);
1517 *SvEND(PL_formtarget) = '\0';
1518 if (IoFLAGS(io) & IOf_FLUSH)
1519 (void)PerlIO_flush(fp);
1523 PL_formtarget = PL_bodytarget;
1524 PERL_UNUSED_VAR(gimme);
1530 dVAR; dSP; dMARK; dORIGMARK;
1534 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1535 IO *const io = GvIO(gv);
1537 /* Treat empty list as "" */
1538 if (MARK == SP) XPUSHs(&PL_sv_no);
1541 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1543 if (MARK == ORIGMARK) {
1546 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1549 return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1551 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1558 SETERRNO(EBADF,RMS_IFI);
1561 else if (!(fp = IoOFP(io))) {
1563 report_wrongway_fh(gv, '<');
1564 else if (ckWARN(WARN_CLOSED))
1566 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1570 SV *sv = sv_newmortal();
1571 do_sprintf(sv, SP - MARK, MARK + 1);
1572 if (!do_print(sv, fp))
1575 if (IoFLAGS(io) & IOf_FLUSH)
1576 if (PerlIO_flush(fp) == EOF)
1585 PUSHs(&PL_sv_undef);
1593 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1594 const int mode = POPi;
1595 SV * const sv = POPs;
1596 GV * const gv = MUTABLE_GV(POPs);
1599 /* Need TIEHANDLE method ? */
1600 const char * const tmps = SvPV_const(sv, len);
1601 if (do_open_raw(gv, tmps, len, mode, perm)) {
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 #if defined(__CYGWIN__)
1714 /* recvfrom() on cygwin doesn't set bufsize at all for
1715 connected sockets, leaving us with trash in the returned
1716 name, so use the same test as the Win32 code to check if it
1717 wasn't set, and set it [perl #118843] */
1718 if (bufsize == sizeof namebuf)
1721 sv_setpvn(TARG, namebuf, bufsize);
1727 if (-offset > (SSize_t)blen)
1728 DIE(aTHX_ "Offset outside string");
1731 if (DO_UTF8(bufsv)) {
1732 /* convert offset-as-chars to offset-as-bytes */
1733 if (offset >= (SSize_t)blen)
1734 offset += SvCUR(bufsv) - blen;
1736 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1739 orig_size = SvCUR(bufsv);
1740 /* Allocating length + offset + 1 isn't perfect in the case of reading
1741 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1743 (should be 2 * length + offset + 1, or possibly something longer if
1744 PL_encoding is true) */
1745 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1746 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1747 Zero(buffer+orig_size, offset-orig_size, char);
1749 buffer = buffer + offset;
1751 read_target = bufsv;
1753 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1754 concatenate it to the current buffer. */
1756 /* Truncate the existing buffer to the start of where we will be
1758 SvCUR_set(bufsv, offset);
1760 read_target = sv_newmortal();
1761 SvUPGRADE(read_target, SVt_PV);
1762 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1765 if (PL_op->op_type == OP_SYSREAD) {
1766 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1767 if (IoTYPE(io) == IoTYPE_SOCKET) {
1768 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1774 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1780 count = PerlIO_read(IoIFP(io), buffer, length);
1781 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1782 if (count == 0 && PerlIO_error(IoIFP(io)))
1786 if (IoTYPE(io) == IoTYPE_WRONLY)
1787 report_wrongway_fh(gv, '>');
1790 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1791 *SvEND(read_target) = '\0';
1792 (void)SvPOK_only(read_target);
1793 if (fp_utf8 && !IN_BYTES) {
1794 /* Look at utf8 we got back and count the characters */
1795 const char *bend = buffer + count;
1796 while (buffer < bend) {
1798 skip = UTF8SKIP(buffer);
1801 if (buffer - charskip + skip > bend) {
1802 /* partial character - try for rest of it */
1803 length = skip - (bend-buffer);
1804 offset = bend - SvPVX_const(bufsv);
1816 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1817 provided amount read (count) was what was requested (length)
1819 if (got < wanted && count == length) {
1820 length = wanted - got;
1821 offset = bend - SvPVX_const(bufsv);
1824 /* return value is character count */
1828 else if (buffer_utf8) {
1829 /* Let svcatsv upgrade the bytes we read in to utf8.
1830 The buffer is a mortal so will be freed soon. */
1831 sv_catsv_nomg(bufsv, read_target);
1834 /* This should not be marked tainted if the fp is marked clean */
1835 if (!(IoFLAGS(io) & IOf_UNTAINT))
1836 SvTAINTED_on(bufsv);
1848 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1853 STRLEN orig_blen_bytes;
1854 const int op_type = PL_op->op_type;
1857 GV *const gv = MUTABLE_GV(*++MARK);
1858 IO *const io = GvIO(gv);
1860 if (op_type == OP_SYSWRITE && io) {
1861 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1863 if (MARK == SP - 1) {
1865 mXPUSHi(sv_len(sv));
1869 return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1870 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1880 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1882 if (io && IoIFP(io))
1883 report_wrongway_fh(gv, '<');
1886 SETERRNO(EBADF,RMS_IFI);
1890 /* Do this first to trigger any overloading. */
1891 buffer = SvPV_const(bufsv, blen);
1892 orig_blen_bytes = blen;
1893 doing_utf8 = DO_UTF8(bufsv);
1895 if (PerlIO_isutf8(IoIFP(io))) {
1896 if (!SvUTF8(bufsv)) {
1897 /* We don't modify the original scalar. */
1898 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1899 buffer = (char *) tmpbuf;
1903 else if (doing_utf8) {
1904 STRLEN tmplen = blen;
1905 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1908 buffer = (char *) tmpbuf;
1912 assert((char *)result == buffer);
1913 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1918 if (op_type == OP_SEND) {
1919 const int flags = SvIVx(*++MARK);
1922 char * const sockbuf = SvPVx(*++MARK, mlen);
1923 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1924 flags, (struct sockaddr *)sockbuf, mlen);
1928 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1934 Size_t length = 0; /* This length is in characters. */
1940 /* The SV is bytes, and we've had to upgrade it. */
1941 blen_chars = orig_blen_bytes;
1943 /* The SV really is UTF-8. */
1944 /* Don't call sv_len_utf8 on a magical or overloaded
1945 scalar, as we might get back a different result. */
1946 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
1953 length = blen_chars;
1955 #if Size_t_size > IVSIZE
1956 length = (Size_t)SvNVx(*++MARK);
1958 length = (Size_t)SvIVx(*++MARK);
1960 if ((SSize_t)length < 0) {
1962 DIE(aTHX_ "Negative length");
1967 offset = SvIVx(*++MARK);
1969 if (-offset > (IV)blen_chars) {
1971 DIE(aTHX_ "Offset outside string");
1973 offset += blen_chars;
1974 } else if (offset > (IV)blen_chars) {
1976 DIE(aTHX_ "Offset outside string");
1980 if (length > blen_chars - offset)
1981 length = blen_chars - offset;
1983 /* Here we convert length from characters to bytes. */
1984 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1985 /* Either we had to convert the SV, or the SV is magical, or
1986 the SV has overloading, in which case we can't or mustn't
1987 or mustn't call it again. */
1989 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1990 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1992 /* It's a real UTF-8 SV, and it's not going to change under
1993 us. Take advantage of any cache. */
1995 I32 len_I32 = length;
1997 /* Convert the start and end character positions to bytes.
1998 Remember that the second argument to sv_pos_u2b is relative
2000 sv_pos_u2b(bufsv, &start, &len_I32);
2007 buffer = buffer+offset;
2009 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2010 if (IoTYPE(io) == IoTYPE_SOCKET) {
2011 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
2017 /* See the note at doio.c:do_print about filesize limits. --jhi */
2018 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2027 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2030 #if Size_t_size > IVSIZE
2050 * in Perl 5.12 and later, the additional parameter is a bitmask:
2053 * 2 = eof() <- ARGV magic
2055 * I'll rely on the compiler's trace flow analysis to decide whether to
2056 * actually assign this out here, or punt it into the only block where it is
2057 * used. Doing it out here is DRY on the condition logic.
2062 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2068 if (PL_op->op_flags & OPf_SPECIAL) {
2069 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2073 gv = PL_last_in_gv; /* eof */
2081 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2082 return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2085 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2086 if (io && !IoIFP(io)) {
2087 if ((IoFLAGS(io) & IOf_START) && av_tindex(GvAVn(gv)) < 0) {
2089 IoFLAGS(io) &= ~IOf_START;
2090 do_open6(gv, "-", 1, NULL, NULL, 0);
2092 sv_setpvs(GvSV(gv), "-");
2094 GvSV(gv) = newSVpvs("-");
2095 SvSETMAGIC(GvSV(gv));
2097 else if (!nextargv(gv))
2102 PUSHs(boolSV(do_eof(gv)));
2112 if (MAXARG != 0 && (TOPs || POPs))
2113 PL_last_in_gv = MUTABLE_GV(POPs);
2120 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2122 return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2127 SETERRNO(EBADF,RMS_IFI);
2132 #if LSEEKSIZE > IVSIZE
2133 PUSHn( do_tell(gv) );
2135 PUSHi( do_tell(gv) );
2143 const int whence = POPi;
2144 #if LSEEKSIZE > IVSIZE
2145 const Off_t offset = (Off_t)SvNVx(POPs);
2147 const Off_t offset = (Off_t)SvIVx(POPs);
2150 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2151 IO *const io = GvIO(gv);
2154 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2156 #if LSEEKSIZE > IVSIZE
2157 SV *const offset_sv = newSVnv((NV) offset);
2159 SV *const offset_sv = newSViv(offset);
2162 return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2167 if (PL_op->op_type == OP_SEEK)
2168 PUSHs(boolSV(do_seek(gv, offset, whence)));
2170 const Off_t sought = do_sysseek(gv, offset, whence);
2172 PUSHs(&PL_sv_undef);
2174 SV* const sv = sought ?
2175 #if LSEEKSIZE > IVSIZE
2180 : newSVpvn(zero_but_true, ZBTLEN);
2191 /* There seems to be no consensus on the length type of truncate()
2192 * and ftruncate(), both off_t and size_t have supporters. In
2193 * general one would think that when using large files, off_t is
2194 * at least as wide as size_t, so using an off_t should be okay. */
2195 /* XXX Configure probe for the length type of *truncate() needed XXX */
2198 #if Off_t_size > IVSIZE
2203 /* Checking for length < 0 is problematic as the type might or
2204 * might not be signed: if it is not, clever compilers will moan. */
2205 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2208 SV * const sv = POPs;
2213 if (PL_op->op_flags & OPf_SPECIAL
2214 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2215 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2222 TAINT_PROPER("truncate");
2223 if (!(fp = IoIFP(io))) {
2229 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2231 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2237 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2238 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2239 goto do_ftruncate_io;
2242 const char * const name = SvPV_nomg_const_nolen(sv);
2243 TAINT_PROPER("truncate");
2245 if (truncate(name, len) < 0)
2249 const int tmpfd = PerlLIO_open(name, O_RDWR);
2254 if (my_chsize(tmpfd, len) < 0)
2256 PerlLIO_close(tmpfd);
2265 SETERRNO(EBADF,RMS_IFI);
2273 SV * const argsv = POPs;
2274 const unsigned int func = POPu;
2276 GV * const gv = MUTABLE_GV(POPs);
2277 IO * const io = GvIOn(gv);
2283 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2287 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2290 s = SvPV_force(argsv, len);
2291 need = IOCPARM_LEN(func);
2293 s = Sv_Grow(argsv, need + 1);
2294 SvCUR_set(argsv, need);
2297 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2300 retval = SvIV(argsv);
2301 s = INT2PTR(char*,retval); /* ouch */
2304 optype = PL_op->op_type;
2305 TAINT_PROPER(PL_op_desc[optype]);
2307 if (optype == OP_IOCTL)
2309 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2311 DIE(aTHX_ "ioctl is not implemented");
2315 DIE(aTHX_ "fcntl is not implemented");
2317 #if defined(OS2) && defined(__EMX__)
2318 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2320 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2324 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2326 if (s[SvCUR(argsv)] != 17)
2327 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2329 s[SvCUR(argsv)] = 0; /* put our null back */
2330 SvSETMAGIC(argsv); /* Assume it has changed */
2339 PUSHp(zero_but_true, ZBTLEN);
2350 const int argtype = POPi;
2351 GV * const gv = MUTABLE_GV(POPs);
2352 IO *const io = GvIO(gv);
2353 PerlIO *const fp = io ? IoIFP(io) : NULL;
2355 /* XXX Looks to me like io is always NULL at this point */
2357 (void)PerlIO_flush(fp);
2358 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2363 SETERRNO(EBADF,RMS_IFI);
2368 DIE(aTHX_ PL_no_func, "flock()");
2379 const int protocol = POPi;
2380 const int type = POPi;
2381 const int domain = POPi;
2382 GV * const gv = MUTABLE_GV(POPs);
2383 IO * const io = GvIOn(gv);
2387 do_close(gv, FALSE);
2389 TAINT_PROPER("socket");
2390 fd = PerlSock_socket(domain, type, protocol);
2393 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2394 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2395 IoTYPE(io) = IoTYPE_SOCKET;
2396 if (!IoIFP(io) || !IoOFP(io)) {
2397 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2398 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2399 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2402 #if defined(HAS_FCNTL) && defined(F_SETFD)
2403 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2412 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2415 const int protocol = POPi;
2416 const int type = POPi;
2417 const int domain = POPi;
2419 GV * const gv2 = MUTABLE_GV(POPs);
2420 IO * const io2 = GvIOn(gv2);
2421 GV * const gv1 = MUTABLE_GV(POPs);
2422 IO * const io1 = GvIOn(gv1);
2425 do_close(gv1, FALSE);
2427 do_close(gv2, FALSE);
2429 TAINT_PROPER("socketpair");
2430 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2432 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2433 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2434 IoTYPE(io1) = IoTYPE_SOCKET;
2435 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2436 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2437 IoTYPE(io2) = IoTYPE_SOCKET;
2438 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2439 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2440 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2441 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2442 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2443 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2444 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2447 #if defined(HAS_FCNTL) && defined(F_SETFD)
2448 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2449 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2454 DIE(aTHX_ PL_no_sock_func, "socketpair");
2463 SV * const addrsv = POPs;
2464 /* OK, so on what platform does bind modify addr? */
2466 GV * const gv = MUTABLE_GV(POPs);
2467 IO * const io = GvIOn(gv);
2474 addr = SvPV_const(addrsv, len);
2475 op_type = PL_op->op_type;
2476 TAINT_PROPER(PL_op_desc[op_type]);
2477 if ((op_type == OP_BIND
2478 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2479 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2487 SETERRNO(EBADF,SS_IVCHAN);
2494 const int backlog = POPi;
2495 GV * const gv = MUTABLE_GV(POPs);
2496 IO * const io = GvIOn(gv);
2501 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2508 SETERRNO(EBADF,SS_IVCHAN);
2516 char namebuf[MAXPATHLEN];
2517 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2518 Sock_size_t len = sizeof (struct sockaddr_in);
2520 Sock_size_t len = sizeof namebuf;
2522 GV * const ggv = MUTABLE_GV(POPs);
2523 GV * const ngv = MUTABLE_GV(POPs);
2526 IO * const gstio = GvIO(ggv);
2527 if (!gstio || !IoIFP(gstio))
2531 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2534 /* Some platforms indicate zero length when an AF_UNIX client is
2535 * not bound. Simulate a non-zero-length sockaddr structure in
2537 namebuf[0] = 0; /* sun_len */
2538 namebuf[1] = AF_UNIX; /* sun_family */
2546 do_close(ngv, FALSE);
2547 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2548 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2549 IoTYPE(nstio) = IoTYPE_SOCKET;
2550 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2551 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2552 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2553 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2556 #if defined(HAS_FCNTL) && defined(F_SETFD)
2557 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2560 #ifdef __SCO_VERSION__
2561 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2564 PUSHp(namebuf, len);
2568 report_evil_fh(ggv);
2569 SETERRNO(EBADF,SS_IVCHAN);
2579 const int how = POPi;
2580 GV * const gv = MUTABLE_GV(POPs);
2581 IO * const io = GvIOn(gv);
2586 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2591 SETERRNO(EBADF,SS_IVCHAN);
2598 const int optype = PL_op->op_type;
2599 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2600 const unsigned int optname = (unsigned int) POPi;
2601 const unsigned int lvl = (unsigned int) POPi;
2602 GV * const gv = MUTABLE_GV(POPs);
2603 IO * const io = GvIOn(gv);
2610 fd = PerlIO_fileno(IoIFP(io));
2614 (void)SvPOK_only(sv);
2618 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2625 #if defined(__SYMBIAN32__)
2626 # define SETSOCKOPT_OPTION_VALUE_T void *
2628 # define SETSOCKOPT_OPTION_VALUE_T const char *
2630 /* XXX TODO: We need to have a proper type (a Configure probe,
2631 * etc.) for what the C headers think of the third argument of
2632 * setsockopt(), the option_value read-only buffer: is it
2633 * a "char *", or a "void *", const or not. Some compilers
2634 * don't take kindly to e.g. assuming that "char *" implicitly
2635 * promotes to a "void *", or to explicitly promoting/demoting
2636 * consts to non/vice versa. The "const void *" is the SUS
2637 * definition, but that does not fly everywhere for the above
2639 SETSOCKOPT_OPTION_VALUE_T buf;
2643 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2647 aint = (int)SvIV(sv);
2648 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2651 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2661 SETERRNO(EBADF,SS_IVCHAN);
2670 const int optype = PL_op->op_type;
2671 GV * const gv = MUTABLE_GV(POPs);
2672 IO * const io = GvIOn(gv);
2680 sv = sv_2mortal(newSV(257));
2681 (void)SvPOK_only(sv);
2685 fd = PerlIO_fileno(IoIFP(io));
2687 case OP_GETSOCKNAME:
2688 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2691 case OP_GETPEERNAME:
2692 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2694 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2696 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";
2697 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2698 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2699 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2700 sizeof(u_short) + sizeof(struct in_addr))) {
2707 #ifdef BOGUS_GETNAME_RETURN
2708 /* Interactive Unix, getpeername() and getsockname()
2709 does not return valid namelen */
2710 if (len == BOGUS_GETNAME_RETURN)
2711 len = sizeof(struct sockaddr);
2720 SETERRNO(EBADF,SS_IVCHAN);
2739 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2740 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2741 if (PL_op->op_type == OP_LSTAT) {
2742 if (gv != PL_defgv) {
2743 do_fstat_warning_check:
2744 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2745 "lstat() on filehandle%s%"SVf,
2748 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2750 } else if (PL_laststype != OP_LSTAT)
2751 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2752 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2755 if (gv != PL_defgv) {
2759 PL_laststype = OP_STAT;
2760 PL_statgv = gv ? gv : (GV *)io;
2761 sv_setpvs(PL_statname, "");
2768 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2770 } else if (IoDIRP(io)) {
2772 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2775 PL_laststatval = -1;
2778 else PL_laststatval = -1;
2779 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2782 if (PL_laststatval < 0) {
2788 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2789 io = MUTABLE_IO(SvRV(sv));
2790 if (PL_op->op_type == OP_LSTAT)
2791 goto do_fstat_warning_check;
2792 goto do_fstat_have_io;
2795 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2796 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2798 PL_laststype = PL_op->op_type;
2799 file = SvPV_nolen_const(PL_statname);
2800 if (PL_op->op_type == OP_LSTAT)
2801 PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
2803 PL_laststatval = PerlLIO_stat(file, &PL_statcache);
2804 if (PL_laststatval < 0) {
2805 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
2806 /* PL_warn_nl is constant */
2807 GCC_DIAG_IGNORE(-Wformat-nonliteral);
2808 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2816 if (gimme != G_ARRAY) {
2817 if (gimme != G_VOID)
2818 XPUSHs(boolSV(max));
2824 mPUSHi(PL_statcache.st_dev);
2825 #if ST_INO_SIZE > IVSIZE
2826 mPUSHn(PL_statcache.st_ino);
2828 # if ST_INO_SIGN <= 0
2829 mPUSHi(PL_statcache.st_ino);
2831 mPUSHu(PL_statcache.st_ino);
2834 mPUSHu(PL_statcache.st_mode);
2835 mPUSHu(PL_statcache.st_nlink);
2837 sv_setuid(PUSHmortal, PL_statcache.st_uid);
2838 sv_setgid(PUSHmortal, PL_statcache.st_gid);
2840 #ifdef USE_STAT_RDEV
2841 mPUSHi(PL_statcache.st_rdev);
2843 PUSHs(newSVpvs_flags("", SVs_TEMP));
2845 #if Off_t_size > IVSIZE
2846 mPUSHn(PL_statcache.st_size);
2848 mPUSHi(PL_statcache.st_size);
2851 mPUSHn(PL_statcache.st_atime);
2852 mPUSHn(PL_statcache.st_mtime);
2853 mPUSHn(PL_statcache.st_ctime);
2855 mPUSHi(PL_statcache.st_atime);
2856 mPUSHi(PL_statcache.st_mtime);
2857 mPUSHi(PL_statcache.st_ctime);
2859 #ifdef USE_STAT_BLOCKS
2860 mPUSHu(PL_statcache.st_blksize);
2861 mPUSHu(PL_statcache.st_blocks);
2863 PUSHs(newSVpvs_flags("", SVs_TEMP));
2864 PUSHs(newSVpvs_flags("", SVs_TEMP));
2870 /* All filetest ops avoid manipulating the perl stack pointer in their main
2871 bodies (since commit d2c4d2d1e22d3125), and return using either
2872 S_ft_return_false() or S_ft_return_true(). These two helper functions are
2873 the only two which manipulate the perl stack. To ensure that no stack
2874 manipulation macros are used, the filetest ops avoid defining a local copy
2875 of the stack pointer with dSP. */
2877 /* If the next filetest is stacked up with this one
2878 (PL_op->op_private & OPpFT_STACKING), we leave
2879 the original argument on the stack for success,
2880 and skip the stacked operators on failure.
2881 The next few macros/functions take care of this.
2885 S_ft_return_false(pTHX_ SV *ret) {
2889 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
2893 if (PL_op->op_private & OPpFT_STACKING) {
2894 while (OP_IS_FILETEST(next->op_type)
2895 && next->op_private & OPpFT_STACKED)
2896 next = next->op_next;
2901 PERL_STATIC_INLINE OP *
2902 S_ft_return_true(pTHX_ SV *ret) {
2904 if (PL_op->op_flags & OPf_REF)
2905 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
2906 else if (!(PL_op->op_private & OPpFT_STACKING))
2912 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
2913 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
2914 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
2916 #define tryAMAGICftest_MG(chr) STMT_START { \
2917 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
2918 && PL_op->op_flags & OPf_KIDS) { \
2919 OP *next = S_try_amagic_ftest(aTHX_ chr); \
2920 if (next) return next; \
2925 S_try_amagic_ftest(pTHX_ char chr) {
2927 SV *const arg = *PL_stack_sp;
2930 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
2934 const char tmpchr = chr;
2935 SV * const tmpsv = amagic_call(arg,
2936 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2937 ftest_amg, AMGf_unary);
2942 return SvTRUE(tmpsv)
2943 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
2953 /* Not const, because things tweak this below. Not bool, because there's
2954 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2955 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2956 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2957 /* Giving some sort of initial value silences compilers. */
2959 int access_mode = R_OK;
2961 int access_mode = 0;
2964 /* access_mode is never used, but leaving use_access in makes the
2965 conditional compiling below much clearer. */
2968 Mode_t stat_mode = S_IRUSR;
2970 bool effective = FALSE;
2973 switch (PL_op->op_type) {
2974 case OP_FTRREAD: opchar = 'R'; break;
2975 case OP_FTRWRITE: opchar = 'W'; break;
2976 case OP_FTREXEC: opchar = 'X'; break;
2977 case OP_FTEREAD: opchar = 'r'; break;
2978 case OP_FTEWRITE: opchar = 'w'; break;
2979 case OP_FTEEXEC: opchar = 'x'; break;
2981 tryAMAGICftest_MG(opchar);
2983 switch (PL_op->op_type) {
2985 #if !(defined(HAS_ACCESS) && defined(R_OK))
2991 #if defined(HAS_ACCESS) && defined(W_OK)
2996 stat_mode = S_IWUSR;
3000 #if defined(HAS_ACCESS) && defined(X_OK)
3005 stat_mode = S_IXUSR;
3009 #ifdef PERL_EFF_ACCESS
3012 stat_mode = S_IWUSR;
3016 #ifndef PERL_EFF_ACCESS
3023 #ifdef PERL_EFF_ACCESS
3028 stat_mode = S_IXUSR;
3034 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3035 const char *name = SvPV_nolen(*PL_stack_sp);
3037 # ifdef PERL_EFF_ACCESS
3038 result = PERL_EFF_ACCESS(name, access_mode);
3040 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3046 result = access(name, access_mode);
3048 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3059 result = my_stat_flags(0);
3062 if (cando(stat_mode, effective, &PL_statcache))
3071 const int op_type = PL_op->op_type;
3075 case OP_FTIS: opchar = 'e'; break;
3076 case OP_FTSIZE: opchar = 's'; break;
3077 case OP_FTMTIME: opchar = 'M'; break;
3078 case OP_FTCTIME: opchar = 'C'; break;
3079 case OP_FTATIME: opchar = 'A'; break;
3081 tryAMAGICftest_MG(opchar);
3083 result = my_stat_flags(0);
3086 if (op_type == OP_FTIS)
3089 /* You can't dTARGET inside OP_FTIS, because you'll get
3090 "panic: pad_sv po" - the op is not flagged to have a target. */
3094 #if Off_t_size > IVSIZE
3095 sv_setnv(TARG, (NV)PL_statcache.st_size);
3097 sv_setiv(TARG, (IV)PL_statcache.st_size);
3102 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3106 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3110 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3114 return SvTRUE_nomg(TARG)
3115 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3125 switch (PL_op->op_type) {
3126 case OP_FTROWNED: opchar = 'O'; break;
3127 case OP_FTEOWNED: opchar = 'o'; break;
3128 case OP_FTZERO: opchar = 'z'; break;
3129 case OP_FTSOCK: opchar = 'S'; break;
3130 case OP_FTCHR: opchar = 'c'; break;
3131 case OP_FTBLK: opchar = 'b'; break;
3132 case OP_FTFILE: opchar = 'f'; break;
3133 case OP_FTDIR: opchar = 'd'; break;
3134 case OP_FTPIPE: opchar = 'p'; break;
3135 case OP_FTSUID: opchar = 'u'; break;
3136 case OP_FTSGID: opchar = 'g'; break;
3137 case OP_FTSVTX: opchar = 'k'; break;
3139 tryAMAGICftest_MG(opchar);
3141 /* I believe that all these three are likely to be defined on most every
3142 system these days. */
3144 if(PL_op->op_type == OP_FTSUID) {
3149 if(PL_op->op_type == OP_FTSGID) {
3154 if(PL_op->op_type == OP_FTSVTX) {
3159 result = my_stat_flags(0);
3162 switch (PL_op->op_type) {
3164 if (PL_statcache.st_uid == PerlProc_getuid())
3168 if (PL_statcache.st_uid == PerlProc_geteuid())
3172 if (PL_statcache.st_size == 0)
3176 if (S_ISSOCK(PL_statcache.st_mode))
3180 if (S_ISCHR(PL_statcache.st_mode))
3184 if (S_ISBLK(PL_statcache.st_mode))
3188 if (S_ISREG(PL_statcache.st_mode))
3192 if (S_ISDIR(PL_statcache.st_mode))
3196 if (S_ISFIFO(PL_statcache.st_mode))
3201 if (PL_statcache.st_mode & S_ISUID)
3207 if (PL_statcache.st_mode & S_ISGID)
3213 if (PL_statcache.st_mode & S_ISVTX)
3226 tryAMAGICftest_MG('l');
3227 result = my_lstat_flags(0);
3231 if (S_ISLNK(PL_statcache.st_mode))
3244 tryAMAGICftest_MG('t');
3246 if (PL_op->op_flags & OPf_REF)
3249 SV *tmpsv = *PL_stack_sp;
3250 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3251 name = SvPV_nomg(tmpsv, namelen);
3252 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3256 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3257 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3258 else if (name && isDIGIT(*name))
3262 if (PerlLIO_isatty(fd))
3280 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3282 if (PL_op->op_flags & OPf_REF)
3284 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3289 gv = MAYBE_DEREF_GV_nomg(sv);
3293 if (gv == PL_defgv) {
3295 io = SvTYPE(PL_statgv) == SVt_PVIO
3299 goto really_filename;
3304 sv_setpvs(PL_statname, "");
3305 io = GvIO(PL_statgv);
3307 PL_laststatval = -1;
3308 PL_laststype = OP_STAT;
3309 if (io && IoIFP(io)) {
3310 if (! PerlIO_has_base(IoIFP(io)))
3311 DIE(aTHX_ "-T and -B not implemented on filehandles");
3312 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3313 if (PL_laststatval < 0)
3315 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3316 if (PL_op->op_type == OP_FTTEXT)
3321 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3322 i = PerlIO_getc(IoIFP(io));
3324 (void)PerlIO_ungetc(IoIFP(io),i);
3326 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3328 len = PerlIO_get_bufsiz(IoIFP(io));
3329 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3330 /* sfio can have large buffers - limit to 512 */
3335 SETERRNO(EBADF,RMS_IFI);
3337 SETERRNO(EBADF,RMS_IFI);
3344 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3346 file = SvPVX_const(PL_statname);
3348 if (!(fp = PerlIO_open(file, "r"))) {
3350 PL_laststatval = -1;
3351 PL_laststype = OP_STAT;
3353 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
3354 /* PL_warn_nl is constant */
3355 GCC_DIAG_IGNORE(-Wformat-nonliteral);
3356 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3361 PL_laststype = OP_STAT;
3362 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3363 if (PL_laststatval < 0) {
3364 (void)PerlIO_close(fp);
3367 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3368 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3369 (void)PerlIO_close(fp);
3371 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3372 FT_RETURNNO; /* special case NFS directories */
3373 FT_RETURNYES; /* null file is anything */
3378 /* now scan s to look for textiness */
3379 /* XXX ASCII dependent code */
3381 #if defined(DOSISH) || defined(USEMYBINMODE)
3382 /* ignore trailing ^Z on short files */
3383 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3387 for (i = 0; i < len; i++, s++) {
3388 if (!*s) { /* null never allowed in text */
3393 else if (!(isPRINT(*s) || isSPACE(*s)))
3396 else if (*s & 128) {
3398 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3401 /* utf8 characters don't count as odd */
3402 if (UTF8_IS_START(*s)) {
3403 int ulen = UTF8SKIP(s);
3404 if (ulen < len - i) {
3406 for (j = 1; j < ulen; j++) {
3407 if (!UTF8_IS_CONTINUATION(s[j]))
3410 --ulen; /* loop does extra increment */
3420 *s != '\n' && *s != '\r' && *s != '\b' &&
3421 *s != '\t' && *s != '\f' && *s != 27)
3426 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3437 const char *tmps = NULL;
3441 SV * const sv = POPs;
3442 if (PL_op->op_flags & OPf_SPECIAL) {
3443 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3445 else if (!(gv = MAYBE_DEREF_GV(sv)))
3446 tmps = SvPV_nomg_const_nolen(sv);
3449 if( !gv && (!tmps || !*tmps) ) {
3450 HV * const table = GvHVn(PL_envgv);
3453 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3454 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3456 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3461 deprecate("chdir('') or chdir(undef) as chdir()");
3462 tmps = SvPV_nolen_const(*svp);
3466 TAINT_PROPER("chdir");
3471 TAINT_PROPER("chdir");
3474 IO* const io = GvIO(gv);
3477 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3478 } else if (IoIFP(io)) {
3479 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3483 SETERRNO(EBADF, RMS_IFI);
3489 SETERRNO(EBADF,RMS_IFI);
3493 DIE(aTHX_ PL_no_func, "fchdir");
3497 PUSHi( PerlDir_chdir(tmps) >= 0 );
3499 /* Clear the DEFAULT element of ENV so we'll get the new value
3501 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3508 dVAR; dSP; dMARK; dTARGET;
3509 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3520 char * const tmps = POPpx;
3521 TAINT_PROPER("chroot");
3522 PUSHi( chroot(tmps) >= 0 );
3525 DIE(aTHX_ PL_no_func, "chroot");
3533 const char * const tmps2 = POPpconstx;
3534 const char * const tmps = SvPV_nolen_const(TOPs);
3535 TAINT_PROPER("rename");
3537 anum = PerlLIO_rename(tmps, tmps2);
3539 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3540 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3543 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3544 (void)UNLINK(tmps2);
3545 if (!(anum = link(tmps, tmps2)))
3546 anum = UNLINK(tmps);
3554 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3558 const int op_type = PL_op->op_type;
3562 if (op_type == OP_LINK)
3563 DIE(aTHX_ PL_no_func, "link");
3565 # ifndef HAS_SYMLINK
3566 if (op_type == OP_SYMLINK)
3567 DIE(aTHX_ PL_no_func, "symlink");
3571 const char * const tmps2 = POPpconstx;
3572 const char * const tmps = SvPV_nolen_const(TOPs);
3573 TAINT_PROPER(PL_op_desc[op_type]);
3575 # if defined(HAS_LINK)
3576 # if defined(HAS_SYMLINK)
3577 /* Both present - need to choose which. */
3578 (op_type == OP_LINK) ?
3579 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3581 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3582 PerlLIO_link(tmps, tmps2);
3585 # if defined(HAS_SYMLINK)
3586 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3587 symlink(tmps, tmps2);
3592 SETi( result >= 0 );
3599 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3610 char buf[MAXPATHLEN];
3615 len = readlink(tmps, buf, sizeof(buf) - 1);
3622 RETSETUNDEF; /* just pretend it's a normal file */
3626 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3628 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3630 char * const save_filename = filename;
3635 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3637 PERL_ARGS_ASSERT_DOONELINER;
3639 Newx(cmdline, size, char);
3640 my_strlcpy(cmdline, cmd, size);
3641 my_strlcat(cmdline, " ", size);
3642 for (s = cmdline + strlen(cmdline); *filename; ) {
3646 if (s - cmdline < size)
3647 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3648 myfp = PerlProc_popen(cmdline, "r");
3652 SV * const tmpsv = sv_newmortal();
3653 /* Need to save/restore 'PL_rs' ?? */
3654 s = sv_gets(tmpsv, myfp, 0);
3655 (void)PerlProc_pclose(myfp);
3659 #ifdef HAS_SYS_ERRLIST
3664 /* you don't see this */
3665 const char * const errmsg = Strerror(e) ;
3668 if (instr(s, errmsg)) {
3675 #define EACCES EPERM
3677 if (instr(s, "cannot make"))
3678 SETERRNO(EEXIST,RMS_FEX);
3679 else if (instr(s, "existing file"))
3680 SETERRNO(EEXIST,RMS_FEX);
3681 else if (instr(s, "ile exists"))
3682 SETERRNO(EEXIST,RMS_FEX);
3683 else if (instr(s, "non-exist"))
3684 SETERRNO(ENOENT,RMS_FNF);
3685 else if (instr(s, "does not exist"))
3686 SETERRNO(ENOENT,RMS_FNF);
3687 else if (instr(s, "not empty"))
3688 SETERRNO(EBUSY,SS_DEVOFFLINE);
3689 else if (instr(s, "cannot access"))
3690 SETERRNO(EACCES,RMS_PRV);
3692 SETERRNO(EPERM,RMS_PRV);
3695 else { /* some mkdirs return no failure indication */
3696 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3697 if (PL_op->op_type == OP_RMDIR)
3702 SETERRNO(EACCES,RMS_PRV); /* a guess */
3711 /* This macro removes trailing slashes from a directory name.
3712 * Different operating and file systems take differently to
3713 * trailing slashes. According to POSIX 1003.1 1996 Edition
3714 * any number of trailing slashes should be allowed.
3715 * Thusly we snip them away so that even non-conforming
3716 * systems are happy.
3717 * We should probably do this "filtering" for all
3718 * the functions that expect (potentially) directory names:
3719 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3720 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3722 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3723 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3726 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3727 (tmps) = savepvn((tmps), (len)); \
3737 const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3739 TRIMSLASHES(tmps,len,copy);
3741 TAINT_PROPER("mkdir");
3743 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3747 SETi( dooneliner("mkdir", tmps) );
3748 oldumask = PerlLIO_umask(0);
3749 PerlLIO_umask(oldumask);
3750 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3765 TRIMSLASHES(tmps,len,copy);
3766 TAINT_PROPER("rmdir");
3768 SETi( PerlDir_rmdir(tmps) >= 0 );
3770 SETi( dooneliner("rmdir", tmps) );
3777 /* Directory calls. */
3781 #if defined(Direntry_t) && defined(HAS_READDIR)
3783 const char * const dirname = POPpconstx;
3784 GV * const gv = MUTABLE_GV(POPs);
3785 IO * const io = GvIOn(gv);
3787 if ((IoIFP(io) || IoOFP(io)))
3788 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3789 "Opening filehandle %"HEKf" also as a directory",
3790 HEKfARG(GvENAME_HEK(gv)) );
3792 PerlDir_close(IoDIRP(io));
3793 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3799 SETERRNO(EBADF,RMS_DIR);
3802 DIE(aTHX_ PL_no_dir_func, "opendir");
3808 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3809 DIE(aTHX_ PL_no_dir_func, "readdir");
3811 #if !defined(I_DIRENT) && !defined(VMS)
3812 Direntry_t *readdir (DIR *);
3818 const I32 gimme = GIMME;
3819 GV * const gv = MUTABLE_GV(POPs);
3820 const Direntry_t *dp;
3821 IO * const io = GvIOn(gv);
3824 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3825 "readdir() attempted on invalid dirhandle %"HEKf,
3826 HEKfARG(GvENAME_HEK(gv)));
3831 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3835 sv = newSVpvn(dp->d_name, dp->d_namlen);
3837 sv = newSVpv(dp->d_name, 0);
3839 if (!(IoFLAGS(io) & IOf_UNTAINT))
3842 } while (gimme == G_ARRAY);
3844 if (!dp && gimme != G_ARRAY)
3851 SETERRNO(EBADF,RMS_ISI);
3852 if (GIMME == G_ARRAY)
3861 #if defined(HAS_TELLDIR) || defined(telldir)
3863 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3864 /* XXX netbsd still seemed to.
3865 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3866 --JHI 1999-Feb-02 */
3867 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3868 long telldir (DIR *);
3870 GV * const gv = MUTABLE_GV(POPs);
3871 IO * const io = GvIOn(gv);
3874 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3875 "telldir() attempted on invalid dirhandle %"HEKf,
3876 HEKfARG(GvENAME_HEK(gv)));
3880 PUSHi( PerlDir_tell(IoDIRP(io)) );
3884 SETERRNO(EBADF,RMS_ISI);
3887 DIE(aTHX_ PL_no_dir_func, "telldir");
3893 #if defined(HAS_SEEKDIR) || defined(seekdir)
3895 const long along = POPl;
3896 GV * const gv = MUTABLE_GV(POPs);
3897 IO * const io = GvIOn(gv);
3900 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3901 "seekdir() attempted on invalid dirhandle %"HEKf,
3902 HEKfARG(GvENAME_HEK(gv)));
3905 (void)PerlDir_seek(IoDIRP(io), along);
3910 SETERRNO(EBADF,RMS_ISI);
3913 DIE(aTHX_ PL_no_dir_func, "seekdir");
3919 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3921 GV * const gv = MUTABLE_GV(POPs);
3922 IO * const io = GvIOn(gv);
3925 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3926 "rewinddir() attempted on invalid dirhandle %"HEKf,
3927 HEKfARG(GvENAME_HEK(gv)));
3930 (void)PerlDir_rewind(IoDIRP(io));
3934 SETERRNO(EBADF,RMS_ISI);
3937 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3943 #if defined(Direntry_t) && defined(HAS_READDIR)
3945 GV * const gv = MUTABLE_GV(POPs);
3946 IO * const io = GvIOn(gv);
3949 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3950 "closedir() attempted on invalid dirhandle %"HEKf,
3951 HEKfARG(GvENAME_HEK(gv)));
3954 #ifdef VOID_CLOSEDIR
3955 PerlDir_close(IoDIRP(io));
3957 if (PerlDir_close(IoDIRP(io)) < 0) {
3958 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3967 SETERRNO(EBADF,RMS_IFI);
3970 DIE(aTHX_ PL_no_dir_func, "closedir");
3974 /* Process control. */
3981 #ifdef HAS_SIGPROCMASK
3982 sigset_t oldmask, newmask;
3986 PERL_FLUSHALL_FOR_CHILD;
3987 #ifdef HAS_SIGPROCMASK
3988 sigfillset(&newmask);
3989 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
3991 childpid = PerlProc_fork();
3992 if (childpid == 0) {
3996 for (sig = 1; sig < SIG_SIZE; sig++)
3997 PL_psig_pend[sig] = 0;
3999 #ifdef HAS_SIGPROCMASK
4002 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4009 #ifdef PERL_USES_PL_PIDSTATUS
4010 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4016 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4021 PERL_FLUSHALL_FOR_CHILD;
4022 childpid = PerlProc_fork();
4028 DIE(aTHX_ PL_no_func, "fork");
4035 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4040 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4041 childpid = wait4pid(-1, &argflags, 0);
4043 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4048 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4049 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4050 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4052 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4057 DIE(aTHX_ PL_no_func, "wait");
4063 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4065 const int optype = POPi;
4066 const Pid_t pid = TOPi;
4070 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4071 result = wait4pid(pid, &argflags, optype);
4073 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4078 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4079 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4080 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4082 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4087 DIE(aTHX_ PL_no_func, "waitpid");
4093 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4094 #if defined(__LIBCATAMOUNT__)
4095 PL_statusvalue = -1;
4104 while (++MARK <= SP) {
4105 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4110 TAINT_PROPER("system");
4112 PERL_FLUSHALL_FOR_CHILD;
4113 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4118 #ifdef HAS_SIGPROCMASK
4119 sigset_t newset, oldset;
4122 if (PerlProc_pipe(pp) >= 0)
4124 #ifdef HAS_SIGPROCMASK
4125 sigemptyset(&newset);
4126 sigaddset(&newset, SIGCHLD);
4127 sigprocmask(SIG_BLOCK, &newset, &oldset);
4129 while ((childpid = PerlProc_fork()) == -1) {
4130 if (errno != EAGAIN) {
4135 PerlLIO_close(pp[0]);
4136 PerlLIO_close(pp[1]);
4138 #ifdef HAS_SIGPROCMASK
4139 sigprocmask(SIG_SETMASK, &oldset, NULL);
4146 Sigsave_t ihand,qhand; /* place to save signals during system() */
4150 PerlLIO_close(pp[1]);
4152 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4153 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4156 result = wait4pid(childpid, &status, 0);
4157 } while (result == -1 && errno == EINTR);
4159 #ifdef HAS_SIGPROCMASK
4160 sigprocmask(SIG_SETMASK, &oldset, NULL);
4162 (void)rsignal_restore(SIGINT, &ihand);
4163 (void)rsignal_restore(SIGQUIT, &qhand);
4165 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4166 do_execfree(); /* free any memory child malloced on fork */
4173 while (n < sizeof(int)) {
4174 n1 = PerlLIO_read(pp[0],
4175 (void*)(((char*)&errkid)+n),
4181 PerlLIO_close(pp[0]);
4182 if (n) { /* Error */
4183 if (n != sizeof(int))
4184 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4185 errno = errkid; /* Propagate errno from kid */
4186 STATUS_NATIVE_CHILD_SET(-1);
4189 XPUSHi(STATUS_CURRENT);
4192 #ifdef HAS_SIGPROCMASK
4193 sigprocmask(SIG_SETMASK, &oldset, NULL);
4196 PerlLIO_close(pp[0]);
4197 #if defined(HAS_FCNTL) && defined(F_SETFD)
4198 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4201 if (PL_op->op_flags & OPf_STACKED) {
4202 SV * const really = *++MARK;
4203 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4205 else if (SP - MARK != 1)
4206 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4208 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4212 #else /* ! FORK or VMS or OS/2 */
4215 if (PL_op->op_flags & OPf_STACKED) {
4216 SV * const really = *++MARK;
4217 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4218 value = (I32)do_aspawn(really, MARK, SP);
4220 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4223 else if (SP - MARK != 1) {
4224 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4225 value = (I32)do_aspawn(NULL, MARK, SP);
4227 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4231 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4233 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4235 STATUS_NATIVE_CHILD_SET(value);
4238 XPUSHi(result ? value : STATUS_CURRENT);
4239 #endif /* !FORK or VMS or OS/2 */
4246 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4251 while (++MARK <= SP) {
4252 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4257 TAINT_PROPER("exec");
4259 PERL_FLUSHALL_FOR_CHILD;
4260 if (PL_op->op_flags & OPf_STACKED) {
4261 SV * const really = *++MARK;
4262 value = (I32)do_aexec(really, MARK, SP);
4264 else if (SP - MARK != 1)
4266 value = (I32)vms_do_aexec(NULL, MARK, SP);
4268 value = (I32)do_aexec(NULL, MARK, SP);
4272 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4274 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4287 XPUSHi( getppid() );
4290 DIE(aTHX_ PL_no_func, "getppid");
4300 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4303 pgrp = (I32)BSD_GETPGRP(pid);
4305 if (pid != 0 && pid != PerlProc_getpid())
4306 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4312 DIE(aTHX_ PL_no_func, "getpgrp()");
4322 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4323 if (MAXARG > 0) pid = TOPs && TOPi;
4329 TAINT_PROPER("setpgrp");
4331 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4333 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4334 || (pid != 0 && pid != PerlProc_getpid()))
4336 DIE(aTHX_ "setpgrp can't take arguments");
4338 SETi( setpgrp() >= 0 );
4339 #endif /* USE_BSDPGRP */
4342 DIE(aTHX_ PL_no_func, "setpgrp()");
4346 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4347 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4349 # define PRIORITY_WHICH_T(which) which
4354 #ifdef HAS_GETPRIORITY
4356 const int who = POPi;
4357 const int which = TOPi;
4358 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4361 DIE(aTHX_ PL_no_func, "getpriority()");
4367 #ifdef HAS_SETPRIORITY
4369 const int niceval = POPi;
4370 const int who = POPi;
4371 const int which = TOPi;
4372 TAINT_PROPER("setpriority");
4373 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4376 DIE(aTHX_ PL_no_func, "setpriority()");
4380 #undef PRIORITY_WHICH_T
4388 XPUSHn( time(NULL) );
4390 XPUSHi( time(NULL) );
4400 struct tms timesbuf;
4403 (void)PerlProc_times(×buf);
4405 mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
4406 if (GIMME == G_ARRAY) {
4407 mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
4408 mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
4409 mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
4417 if (GIMME == G_ARRAY) {
4424 DIE(aTHX_ "times not implemented");
4426 #endif /* HAS_TIMES */
4429 /* The 32 bit int year limits the times we can represent to these
4430 boundaries with a few days wiggle room to account for time zone
4433 /* Sat Jan 3 00:00:00 -2147481748 */
4434 #define TIME_LOWER_BOUND -67768100567755200.0
4435 /* Sun Dec 29 12:00:00 2147483647 */
4436 #define TIME_UPPER_BOUND 67767976233316800.0
4445 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4446 static const char * const dayname[] =
4447 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4448 static const char * const monname[] =
4449 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4450 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4452 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4455 when = (Time64_T)now;
4458 NV input = Perl_floor(POPn);
4459 when = (Time64_T)input;
4460 if (when != input) {
4461 /* diag_listed_as: gmtime(%f) too large */
4462 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4463 "%s(%.0" NVff ") too large", opname, input);
4467 if ( TIME_LOWER_BOUND > when ) {
4468 /* diag_listed_as: gmtime(%f) too small */
4469 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4470 "%s(%.0" NVff ") too small", opname, when);
4473 else if( when > TIME_UPPER_BOUND ) {
4474 /* diag_listed_as: gmtime(%f) too small */
4475 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4476 "%s(%.0" NVff ") too large", opname, when);
4480 if (PL_op->op_type == OP_LOCALTIME)
4481 err = S_localtime64_r(&when, &tmbuf);
4483 err = S_gmtime64_r(&when, &tmbuf);
4487 /* XXX %lld broken for quads */
4488 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4489 "%s(%.0" NVff ") failed", opname, when);
4492 if (GIMME != G_ARRAY) { /* scalar context */
4494 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4495 double year = (double)tmbuf.tm_year + 1900;
4502 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4503 dayname[tmbuf.tm_wday],
4504 monname[tmbuf.tm_mon],
4512 else { /* list context */
4518 mPUSHi(tmbuf.tm_sec);
4519 mPUSHi(tmbuf.tm_min);
4520 mPUSHi(tmbuf.tm_hour);
4521 mPUSHi(tmbuf.tm_mday);
4522 mPUSHi(tmbuf.tm_mon);
4523 mPUSHn(tmbuf.tm_year);
4524 mPUSHi(tmbuf.tm_wday);
4525 mPUSHi(tmbuf.tm_yday);
4526 mPUSHi(tmbuf.tm_isdst);
4537 anum = alarm((unsigned int)anum);
4543 DIE(aTHX_ PL_no_func, "alarm");
4554 (void)time(&lasttime);
4555 if (MAXARG < 1 || (!TOPs && !POPs))
4559 PerlProc_sleep((unsigned int)duration);
4562 XPUSHi(when - lasttime);
4566 /* Shared memory. */
4567 /* Merged with some message passing. */
4571 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4572 dVAR; dSP; dMARK; dTARGET;
4573 const int op_type = PL_op->op_type;
4578 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4581 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4584 value = (I32)(do_semop(MARK, SP) >= 0);
4587 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4595 return Perl_pp_semget(aTHX);
4603 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4604 dVAR; dSP; dMARK; dTARGET;
4605 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4612 DIE(aTHX_ "System V IPC is not implemented on this machine");
4618 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4619 dVAR; dSP; dMARK; dTARGET;
4620 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4628 PUSHp(zero_but_true, ZBTLEN);
4632 return Perl_pp_semget(aTHX);
4636 /* I can't const this further without getting warnings about the types of
4637 various arrays passed in from structures. */
4639 S_space_join_names_mortal(pTHX_ char *const *array)
4643 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4645 if (array && *array) {
4646 target = newSVpvs_flags("", SVs_TEMP);
4648 sv_catpv(target, *array);
4651 sv_catpvs(target, " ");
4654 target = sv_mortalcopy(&PL_sv_no);
4659 /* Get system info. */
4663 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4665 I32 which = PL_op->op_type;
4668 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4669 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4670 struct hostent *gethostbyname(Netdb_name_t);
4671 struct hostent *gethostent(void);
4673 struct hostent *hent = NULL;
4677 if (which == OP_GHBYNAME) {
4678 #ifdef HAS_GETHOSTBYNAME
4679 const char* const name = POPpbytex;
4680 hent = PerlSock_gethostbyname(name);
4682 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4685 else if (which == OP_GHBYADDR) {
4686 #ifdef HAS_GETHOSTBYADDR
4687 const int addrtype = POPi;
4688 SV * const addrsv = POPs;
4690 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4692 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4694 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4698 #ifdef HAS_GETHOSTENT
4699 hent = PerlSock_gethostent();
4701 DIE(aTHX_ PL_no_sock_func, "gethostent");
4704 #ifdef HOST_NOT_FOUND
4706 #ifdef USE_REENTRANT_API
4707 # ifdef USE_GETHOSTENT_ERRNO
4708 h_errno = PL_reentrant_buffer->_gethostent_errno;
4711 STATUS_UNIX_SET(h_errno);
4715 if (GIMME != G_ARRAY) {
4716 PUSHs(sv = sv_newmortal());
4718 if (which == OP_GHBYNAME) {
4720 sv_setpvn(sv, hent->h_addr, hent->h_length);
4723 sv_setpv(sv, (char*)hent->h_name);
4729 mPUSHs(newSVpv((char*)hent->h_name, 0));
4730 PUSHs(space_join_names_mortal(hent->h_aliases));
4731 mPUSHi(hent->h_addrtype);
4732 len = hent->h_length;
4735 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4736 mXPUSHp(*elem, len);
4740 mPUSHp(hent->h_addr, len);
4742 PUSHs(sv_mortalcopy(&PL_sv_no));
4747 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4753 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4755 I32 which = PL_op->op_type;
4757 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4758 struct netent *getnetbyaddr(Netdb_net_t, int);
4759 struct netent *getnetbyname(Netdb_name_t);
4760 struct netent *getnetent(void);
4762 struct netent *nent;
4764 if (which == OP_GNBYNAME){
4765 #ifdef HAS_GETNETBYNAME
4766 const char * const name = POPpbytex;
4767 nent = PerlSock_getnetbyname(name);
4769 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4772 else if (which == OP_GNBYADDR) {
4773 #ifdef HAS_GETNETBYADDR
4774 const int addrtype = POPi;
4775 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4776 nent = PerlSock_getnetbyaddr(addr, addrtype);
4778 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4782 #ifdef HAS_GETNETENT
4783 nent = PerlSock_getnetent();
4785 DIE(aTHX_ PL_no_sock_func, "getnetent");
4788 #ifdef HOST_NOT_FOUND
4790 #ifdef USE_REENTRANT_API
4791 # ifdef USE_GETNETENT_ERRNO
4792 h_errno = PL_reentrant_buffer->_getnetent_errno;
4795 STATUS_UNIX_SET(h_errno);
4800 if (GIMME != G_ARRAY) {
4801 PUSHs(sv = sv_newmortal());
4803 if (which == OP_GNBYNAME)
4804 sv_setiv(sv, (IV)nent->n_net);
4806 sv_setpv(sv, nent->n_name);
4812 mPUSHs(newSVpv(nent->n_name, 0));
4813 PUSHs(space_join_names_mortal(nent->n_aliases));
4814 mPUSHi(nent->n_addrtype);
4815 mPUSHi(nent->n_net);
4820 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4826 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4828 I32 which = PL_op->op_type;
4830 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4831 struct protoent *getprotobyname(Netdb_name_t);
4832 struct protoent *getprotobynumber(int);
4833 struct protoent *getprotoent(void);
4835 struct protoent *pent;
4837 if (which == OP_GPBYNAME) {
4838 #ifdef HAS_GETPROTOBYNAME
4839 const char* const name = POPpbytex;
4840 pent = PerlSock_getprotobyname(name);
4842 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4845 else if (which == OP_GPBYNUMBER) {
4846 #ifdef HAS_GETPROTOBYNUMBER
4847 const int number = POPi;
4848 pent = PerlSock_getprotobynumber(number);
4850 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4854 #ifdef HAS_GETPROTOENT
4855 pent = PerlSock_getprotoent();
4857 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4861 if (GIMME != G_ARRAY) {
4862 PUSHs(sv = sv_newmortal());
4864 if (which == OP_GPBYNAME)
4865 sv_setiv(sv, (IV)pent->p_proto);
4867 sv_setpv(sv, pent->p_name);
4873 mPUSHs(newSVpv(pent->p_name, 0));
4874 PUSHs(space_join_names_mortal(pent->p_aliases));
4875 mPUSHi(pent->p_proto);
4880 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4886 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4888 I32 which = PL_op->op_type;
4890 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4891 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4892 struct servent *getservbyport(int, Netdb_name_t);
4893 struct servent *getservent(void);
4895 struct servent *sent;
4897 if (which == OP_GSBYNAME) {
4898 #ifdef HAS_GETSERVBYNAME
4899 const char * const proto = POPpbytex;
4900 const char * const name = POPpbytex;
4901 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4903 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4906 else if (which == OP_GSBYPORT) {
4907 #ifdef HAS_GETSERVBYPORT
4908 const char * const proto = POPpbytex;
4909 unsigned short port = (unsigned short)POPu;
4910 port = PerlSock_htons(port);
4911 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4913 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4917 #ifdef HAS_GETSERVENT
4918 sent = PerlSock_getservent();
4920 DIE(aTHX_ PL_no_sock_func, "getservent");
4924 if (GIMME != G_ARRAY) {
4925 PUSHs(sv = sv_newmortal());
4927 if (which == OP_GSBYNAME) {
4928 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4931 sv_setpv(sv, sent->s_name);
4937 mPUSHs(newSVpv(sent->s_name, 0));
4938 PUSHs(space_join_names_mortal(sent->s_aliases));
4939 mPUSHi(PerlSock_ntohs(sent->s_port));
4940 mPUSHs(newSVpv(sent->s_proto, 0));
4945 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4952 const int stayopen = TOPi;
4953 switch(PL_op->op_type) {
4955 #ifdef HAS_SETHOSTENT
4956 PerlSock_sethostent(stayopen);
4958 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4961 #ifdef HAS_SETNETENT
4963 PerlSock_setnetent(stayopen);
4965 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4969 #ifdef HAS_SETPROTOENT
4970 PerlSock_setprotoent(stayopen);
4972 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4976 #ifdef HAS_SETSERVENT
4977 PerlSock_setservent(stayopen);
4979 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4989 switch(PL_op->op_type) {
4991 #ifdef HAS_ENDHOSTENT
4992 PerlSock_endhostent();
4994 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4998 #ifdef HAS_ENDNETENT
4999 PerlSock_endnetent();
5001 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5005 #ifdef HAS_ENDPROTOENT
5006 PerlSock_endprotoent();
5008 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5012 #ifdef HAS_ENDSERVENT
5013 PerlSock_endservent();
5015 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5019 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5022 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5026 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5029 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5033 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5036 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5040 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5043 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5055 I32 which = PL_op->op_type;
5057 struct passwd *pwent = NULL;
5059 * We currently support only the SysV getsp* shadow password interface.
5060 * The interface is declared in <shadow.h> and often one needs to link
5061 * with -lsecurity or some such.
5062 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5065 * AIX getpwnam() is clever enough to return the encrypted password
5066 * only if the caller (euid?) is root.
5068 * There are at least three other shadow password APIs. Many platforms
5069 * seem to contain more than one interface for accessing the shadow
5070 * password databases, possibly for compatibility reasons.
5071 * The getsp*() is by far he simplest one, the other two interfaces
5072 * are much more complicated, but also very similar to each other.
5077 * struct pr_passwd *getprpw*();
5078 * The password is in
5079 * char getprpw*(...).ufld.fd_encrypt[]
5080 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5085 * struct es_passwd *getespw*();
5086 * The password is in
5087 * char *(getespw*(...).ufld.fd_encrypt)
5088 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5091 * struct userpw *getuserpw();
5092 * The password is in
5093 * char *(getuserpw(...)).spw_upw_passwd
5094 * (but the de facto standard getpwnam() should work okay)
5096 * Mention I_PROT here so that Configure probes for it.
5098 * In HP-UX for getprpw*() the manual page claims that one should include
5099 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5100 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5101 * and pp_sys.c already includes <shadow.h> if there is such.
5103 * Note that <sys/security.h> is already probed for, but currently
5104 * it is only included in special cases.
5106 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5107 * be preferred interface, even though also the getprpw*() interface
5108 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5109 * One also needs to call set_auth_parameters() in main() before
5110 * doing anything else, whether one is using getespw*() or getprpw*().
5112 * Note that accessing the shadow databases can be magnitudes
5113 * slower than accessing the standard databases.
5118 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5119 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5120 * the pw_comment is left uninitialized. */
5121 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5127 const char* const name = POPpbytex;
5128 pwent = getpwnam(name);
5134 pwent = getpwuid(uid);
5138 # ifdef HAS_GETPWENT
5140 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5141 if (pwent) pwent = getpwnam(pwent->pw_name);
5144 DIE(aTHX_ PL_no_func, "getpwent");
5150 if (GIMME != G_ARRAY) {
5151 PUSHs(sv = sv_newmortal());
5153 if (which == OP_GPWNAM)
5154 sv_setuid(sv, pwent->pw_uid);
5156 sv_setpv(sv, pwent->pw_name);
5162 mPUSHs(newSVpv(pwent->pw_name, 0));
5166 /* If we have getspnam(), we try to dig up the shadow
5167 * password. If we are underprivileged, the shadow
5168 * interface will set the errno to EACCES or similar,
5169 * and return a null pointer. If this happens, we will
5170 * use the dummy password (usually "*" or "x") from the
5171 * standard password database.
5173 * In theory we could skip the shadow call completely
5174 * if euid != 0 but in practice we cannot know which
5175 * security measures are guarding the shadow databases
5176 * on a random platform.
5178 * Resist the urge to use additional shadow interfaces.
5179 * Divert the urge to writing an extension instead.
5182 /* Some AIX setups falsely(?) detect some getspnam(), which
5183 * has a different API than the Solaris/IRIX one. */
5184 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5187 const struct spwd * const spwent = getspnam(pwent->pw_name);
5188 /* Save and restore errno so that
5189 * underprivileged attempts seem
5190 * to have never made the unsuccessful
5191 * attempt to retrieve the shadow password. */
5193 if (spwent && spwent->sp_pwdp)
5194 sv_setpv(sv, spwent->sp_pwdp);
5198 if (!SvPOK(sv)) /* Use the standard password, then. */
5199 sv_setpv(sv, pwent->pw_passwd);
5202 /* passwd is tainted because user himself can diddle with it.
5203 * admittedly not much and in a very limited way, but nevertheless. */
5206 sv_setuid(PUSHmortal, pwent->pw_uid);
5207 sv_setgid(PUSHmortal, pwent->pw_gid);
5209 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5210 * because of the poor interface of the Perl getpw*(),
5211 * not because there's some standard/convention saying so.
5212 * A better interface would have been to return a hash,
5213 * but we are accursed by our history, alas. --jhi. */
5215 mPUSHi(pwent->pw_change);
5218 mPUSHi(pwent->pw_quota);
5221 mPUSHs(newSVpv(pwent->pw_age, 0));
5223 /* I think that you can never get this compiled, but just in case. */
5224 PUSHs(sv_mortalcopy(&PL_sv_no));
5229 /* pw_class and pw_comment are mutually exclusive--.
5230 * see the above note for pw_change, pw_quota, and pw_age. */
5232 mPUSHs(newSVpv(pwent->pw_class, 0));
5235 mPUSHs(newSVpv(pwent->pw_comment, 0));
5237 /* I think that you can never get this compiled, but just in case. */
5238 PUSHs(sv_mortalcopy(&PL_sv_no));
5243 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5245 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5247 /* pw_gecos is tainted because user himself can diddle with it. */
5250 mPUSHs(newSVpv(pwent->pw_dir, 0));
5252 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5253 /* pw_shell is tainted because user himself can diddle with it. */
5257 mPUSHi(pwent->pw_expire);
5262 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5270 const I32 which = PL_op->op_type;
5271 const struct group *grent;
5273 if (which == OP_GGRNAM) {
5274 const char* const name = POPpbytex;
5275 grent = (const struct group *)getgrnam(name);
5277 else if (which == OP_GGRGID) {
5278 const Gid_t gid = POPi;
5279 grent = (const struct group *)getgrgid(gid);
5283 grent = (struct group *)getgrent();
5285 DIE(aTHX_ PL_no_func, "getgrent");
5289 if (GIMME != G_ARRAY) {
5290 SV * const sv = sv_newmortal();
5294 if (which == OP_GGRNAM)
5295 sv_setgid(sv, grent->gr_gid);
5297 sv_setpv(sv, grent->gr_name);
5303 mPUSHs(newSVpv(grent->gr_name, 0));
5306 mPUSHs(newSVpv(grent->gr_passwd, 0));
5308 PUSHs(sv_mortalcopy(&PL_sv_no));
5311 sv_setgid(PUSHmortal, grent->gr_gid);
5313 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5314 /* In UNICOS/mk (_CRAYMPP) the multithreading
5315 * versions (getgrnam_r, getgrgid_r)
5316 * seem to return an illegal pointer
5317 * as the group members list, gr_mem.
5318 * getgrent() doesn't even have a _r version
5319 * but the gr_mem is poisonous anyway.
5320 * So yes, you cannot get the list of group
5321 * members if building multithreaded in UNICOS/mk. */
5322 PUSHs(space_join_names_mortal(grent->gr_mem));
5328 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5338 if (!(tmps = PerlProc_getlogin()))
5340 sv_setpv_mg(TARG, tmps);
5344 DIE(aTHX_ PL_no_func, "getlogin");
5348 /* Miscellaneous. */
5353 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5354 I32 items = SP - MARK;
5355 unsigned long a[20];
5360 while (++MARK <= SP) {
5361 if (SvTAINTED(*MARK)) {
5367 TAINT_PROPER("syscall");
5370 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5371 * or where sizeof(long) != sizeof(char*). But such machines will
5372 * not likely have syscall implemented either, so who cares?
5374 while (++MARK <= SP) {
5375 if (SvNIOK(*MARK) || !i)
5376 a[i++] = SvIV(*MARK);
5377 else if (*MARK == &PL_sv_undef)
5380 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5386 DIE(aTHX_ "Too many args to syscall");
5388 DIE(aTHX_ "Too few args to syscall");
5390 retval = syscall(a[0]);
5393 retval = syscall(a[0],a[1]);
5396 retval = syscall(a[0],a[1],a[2]);
5399 retval = syscall(a[0],a[1],a[2],a[3]);
5402 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5405 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5408 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5411 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5418 DIE(aTHX_ PL_no_func, "syscall");
5422 #ifdef FCNTL_EMULATE_FLOCK
5424 /* XXX Emulate flock() with fcntl().
5425 What's really needed is a good file locking module.
5429 fcntl_emulate_flock(int fd, int operation)
5434 switch (operation & ~LOCK_NB) {
5436 flock.l_type = F_RDLCK;
5439 flock.l_type = F_WRLCK;
5442 flock.l_type = F_UNLCK;
5448 flock.l_whence = SEEK_SET;
5449 flock.l_start = flock.l_len = (Off_t)0;
5451 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5452 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5453 errno = EWOULDBLOCK;
5457 #endif /* FCNTL_EMULATE_FLOCK */
5459 #ifdef LOCKF_EMULATE_FLOCK
5461 /* XXX Emulate flock() with lockf(). This is just to increase
5462 portability of scripts. The calls are not completely
5463 interchangeable. What's really needed is a good file
5467 /* The lockf() constants might have been defined in <unistd.h>.
5468 Unfortunately, <unistd.h> causes troubles on some mixed
5469 (BSD/POSIX) systems, such as SunOS 4.1.3.
5471 Further, the lockf() constants aren't POSIX, so they might not be
5472 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5473 just stick in the SVID values and be done with it. Sigh.
5477 # define F_ULOCK 0 /* Unlock a previously locked region */
5480 # define F_LOCK 1 /* Lock a region for exclusive use */
5483 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5486 # define F_TEST 3 /* Test a region for other processes locks */
5490 lockf_emulate_flock(int fd, int operation)
5496 /* flock locks entire file so for lockf we need to do the same */
5497 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5498 if (pos > 0) /* is seekable and needs to be repositioned */
5499 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5500 pos = -1; /* seek failed, so don't seek back afterwards */
5503 switch (operation) {
5505 /* LOCK_SH - get a shared lock */
5507 /* LOCK_EX - get an exclusive lock */
5509 i = lockf (fd, F_LOCK, 0);
5512 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5513 case LOCK_SH|LOCK_NB:
5514 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5515 case LOCK_EX|LOCK_NB:
5516 i = lockf (fd, F_TLOCK, 0);
5518 if ((errno == EAGAIN) || (errno == EACCES))
5519 errno = EWOULDBLOCK;
5522 /* LOCK_UN - unlock (non-blocking is a no-op) */
5524 case LOCK_UN|LOCK_NB:
5525 i = lockf (fd, F_ULOCK, 0);
5528 /* Default - can't decipher operation */
5535 if (pos > 0) /* need to restore position of the handle */
5536 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5541 #endif /* LOCKF_EMULATE_FLOCK */
5545 * c-indentation-style: bsd
5547 * indent-tabs-mode: nil
5550 * ex: set ts=8 sts=4 sw=4 et: