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>
185 /* Missing protos on LynxOS */
186 void sethostent(int);
187 void endhostent(void);
189 void endnetent(void);
190 void setprotoent(int);
191 void endprotoent(void);
192 void setservent(int);
193 void endservent(void);
196 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
198 /* F_OK unused: if stat() cannot find it... */
200 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
201 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
202 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
205 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
206 # ifdef I_SYS_SECURITY
207 # include <sys/security.h>
211 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
214 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
218 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
220 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
224 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
225 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
226 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
229 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
231 const Uid_t ruid = getuid();
232 const Uid_t euid = geteuid();
233 const Gid_t rgid = getgid();
234 const Gid_t egid = getegid();
237 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
238 Perl_croak(aTHX_ "switching effective uid is not implemented");
241 if (setreuid(euid, ruid))
244 if (setresuid(euid, ruid, (Uid_t)-1))
247 /* diag_listed_as: entering effective %s failed */
248 Perl_croak(aTHX_ "entering effective uid failed");
251 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
252 Perl_croak(aTHX_ "switching effective gid is not implemented");
255 if (setregid(egid, rgid))
258 if (setresgid(egid, rgid, (Gid_t)-1))
261 /* diag_listed_as: entering effective %s failed */
262 Perl_croak(aTHX_ "entering effective gid failed");
265 res = access(path, mode);
268 if (setreuid(ruid, euid))
271 if (setresuid(ruid, euid, (Uid_t)-1))
274 /* diag_listed_as: leaving effective %s failed */
275 Perl_croak(aTHX_ "leaving effective uid failed");
278 if (setregid(rgid, egid))
281 if (setresgid(rgid, egid, (Gid_t)-1))
284 /* diag_listed_as: leaving effective %s failed */
285 Perl_croak(aTHX_ "leaving effective gid failed");
289 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
296 const char * const tmps = POPpconstx;
297 const I32 gimme = GIMME_V;
298 const char *mode = "r";
301 if (PL_op->op_private & OPpOPEN_IN_RAW)
303 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
305 fp = PerlProc_popen(tmps, mode);
307 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
309 PerlIO_apply_layers(aTHX_ fp,mode,type);
311 if (gimme == G_VOID) {
313 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
316 else if (gimme == G_SCALAR) {
317 ENTER_with_name("backtick");
319 PL_rs = &PL_sv_undef;
320 sv_setpvs(TARG, ""); /* note that this preserves previous buffer */
321 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
323 LEAVE_with_name("backtick");
329 SV * const sv = newSV(79);
330 if (sv_gets(sv, fp, 0) == NULL) {
335 if (SvLEN(sv) - SvCUR(sv) > 20) {
336 SvPV_shrink_to_cur(sv);
341 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
342 TAINT; /* "I believe that this is not gratuitous!" */
345 STATUS_NATIVE_CHILD_SET(-1);
346 if (gimme == G_SCALAR)
357 GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs;
361 /* make a copy of the pattern if it is gmagical, to ensure that magic
362 * is called once and only once */
363 if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs));
365 tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL));
367 if (PL_op->op_flags & OPf_SPECIAL) {
368 /* call Perl-level glob function instead. Stack args are:
370 * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
379 /* Note that we only ever get here if File::Glob fails to load
380 * without at the same time croaking, for some reason, or if
381 * perl was built with PERL_EXTERNAL_GLOB */
383 ENTER_with_name("glob");
388 * The external globbing program may use things we can't control,
389 * so for security reasons we must assume the worst.
392 taint_proper(PL_no_security, "glob");
396 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
399 SAVESPTR(PL_rs); /* This is not permanent, either. */
400 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
403 *SvPVX(PL_rs) = '\n';
407 result = do_readline();
408 LEAVE_with_name("glob");
414 PL_last_in_gv = cGVOP_gv;
415 return do_readline();
425 do_join(TARG, &PL_sv_no, MARK, SP);
429 else if (SP == MARK) {
436 if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
439 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
440 /* well-formed exception supplied */
443 SV * const errsv = ERRSV;
446 if (SvGMAGICAL(errsv)) {
447 exsv = sv_newmortal();
448 sv_setsv_nomg(exsv, errsv);
452 else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) {
453 exsv = sv_newmortal();
454 sv_setsv_nomg(exsv, errsv);
455 sv_catpvs(exsv, "\t...caught");
458 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
461 if (SvROK(exsv) && !PL_warnhook)
462 Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
474 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
476 if (SP - MARK != 1) {
478 do_join(TARG, &PL_sv_no, MARK, SP);
486 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
487 /* well-formed exception supplied */
490 SV * const errsv = ERRSV;
494 if (sv_isobject(exsv)) {
495 HV * const stash = SvSTASH(SvRV(exsv));
496 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
498 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
499 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
506 call_sv(MUTABLE_SV(GvCV(gv)),
507 G_SCALAR|G_EVAL|G_KEEPERR);
508 exsv = sv_mortalcopy(*PL_stack_sp--);
512 else if (SvPOK(errsv) && SvCUR(errsv)) {
513 exsv = sv_mortalcopy(errsv);
514 sv_catpvs(exsv, "\t...propagated");
517 exsv = newSVpvs_flags("Died", SVs_TEMP);
521 NOT_REACHED; /* NOTREACHED */
522 return NULL; /* avoid missing return from non-void function warning */
528 Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv,
529 const MAGIC *const mg, const U32 flags, U32 argc, ...)
534 PERL_ARGS_ASSERT_TIED_METHOD;
536 /* Ensure that our flag bits do not overlap. */
537 assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
538 assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
539 assert((TIED_METHOD_SAY & G_WANT) == 0);
541 PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
542 PUSHSTACKi(PERLSI_MAGIC);
543 EXTEND(SP, argc+1); /* object + args */
545 PUSHs(SvTIED_obj(sv, mg));
546 if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
547 Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
551 const U32 mortalize_not_needed
552 = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
554 va_start(args, argc);
556 SV *const arg = va_arg(args, SV *);
557 if(mortalize_not_needed)
566 ENTER_with_name("call_tied_method");
567 if (flags & TIED_METHOD_SAY) {
568 /* local $\ = "\n" */
569 SAVEGENERICSV(PL_ors_sv);
570 PL_ors_sv = newSVpvs("\n");
572 ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED);
577 if (ret_args) { /* copy results back to original stack */
578 EXTEND(sp, ret_args);
579 Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
583 LEAVE_with_name("call_tied_method");
587 #define tied_method0(a,b,c,d) \
588 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
589 #define tied_method1(a,b,c,d,e) \
590 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
591 #define tied_method2(a,b,c,d,e,f) \
592 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
605 GV * const gv = MUTABLE_GV(*++MARK);
607 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
608 DIE(aTHX_ PL_no_usym, "filehandle");
610 if ((io = GvIOp(gv))) {
612 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
615 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
616 "Opening dirhandle %"HEKf" also as a file",
617 HEKfARG(GvENAME_HEK(gv)));
619 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
621 /* Method's args are same as ours ... */
622 /* ... except handle is replaced by the object */
623 return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg,
624 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
636 tmps = SvPV_const(sv, len);
637 ok = do_open6(gv, tmps, len, NULL, MARK+1, (SP-MARK));
640 PUSHi( (I32)PL_forkprocess );
641 else if (PL_forkprocess == 0) /* we are a new child */
652 MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
658 IO * const io = GvIO(gv);
660 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
662 return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg);
666 PUSHs(boolSV(do_close(gv, TRUE)));
678 GV * const wgv = MUTABLE_GV(POPs);
679 GV * const rgv = MUTABLE_GV(POPs);
681 assert (isGV_with_GP(rgv));
682 assert (isGV_with_GP(wgv));
685 do_close(rgv, FALSE);
689 do_close(wgv, FALSE);
691 if (PerlProc_pipe(fd) < 0)
694 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
695 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
696 IoOFP(rstio) = IoIFP(rstio);
697 IoIFP(wstio) = IoOFP(wstio);
698 IoTYPE(rstio) = IoTYPE_RDONLY;
699 IoTYPE(wstio) = IoTYPE_WRONLY;
701 if (!IoIFP(rstio) || !IoOFP(wstio)) {
703 PerlIO_close(IoIFP(rstio));
705 PerlLIO_close(fd[0]);
707 PerlIO_close(IoOFP(wstio));
709 PerlLIO_close(fd[1]);
712 #if defined(HAS_FCNTL) && defined(F_SETFD)
713 /* ensure close-on-exec */
714 if ((fcntl(fd[0], F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
715 (fcntl(fd[1], F_SETFD,fd[1] > PL_maxsysfd) < 0))
723 DIE(aTHX_ PL_no_func, "pipe");
737 gv = MUTABLE_GV(POPs);
741 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
743 return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg);
746 if (!io || !(fp = IoIFP(io))) {
747 /* Can't do this because people seem to do things like
748 defined(fileno($foo)) to check whether $foo is a valid fh.
755 PUSHi(PerlIO_fileno(fp));
766 if (MAXARG < 1 || (!TOPs && !POPs)) {
767 anum = PerlLIO_umask(022);
768 /* setting it to 022 between the two calls to umask avoids
769 * to have a window where the umask is set to 0 -- meaning
770 * that another thread could create world-writeable files. */
772 (void)PerlLIO_umask(anum);
775 anum = PerlLIO_umask(POPi);
776 TAINT_PROPER("umask");
779 /* Only DIE if trying to restrict permissions on "user" (self).
780 * Otherwise it's harmless and more useful to just return undef
781 * since 'group' and 'other' concepts probably don't exist here. */
782 if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
783 DIE(aTHX_ "umask not implemented");
784 XPUSHs(&PL_sv_undef);
803 gv = MUTABLE_GV(POPs);
807 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
809 /* This takes advantage of the implementation of the varargs
810 function, which I don't think that the optimiser will be able to
811 figure out. Although, as it's a static function, in theory it
813 return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg,
814 G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
815 discp ? 1 : 0, discp);
819 if (!io || !(fp = IoIFP(io))) {
821 SETERRNO(EBADF,RMS_IFI);
828 const char *d = NULL;
831 d = SvPV_const(discp, len);
832 mode = mode_from_discipline(d, len);
833 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
834 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
835 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
856 const I32 markoff = MARK - PL_stack_base;
857 const char *methname;
858 int how = PERL_MAGIC_tied;
862 switch(SvTYPE(varsv)) {
866 methname = "TIEHASH";
867 if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
868 HvLAZYDEL_off(varsv);
869 hv_free_ent((HV *)varsv, entry);
871 HvEITER_set(MUTABLE_HV(varsv), 0);
875 methname = "TIEARRAY";
876 if (!AvREAL(varsv)) {
878 Perl_croak(aTHX_ "Cannot tie unreifiable array");
879 av_clear((AV *)varsv);
886 if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
887 methname = "TIEHANDLE";
888 how = PERL_MAGIC_tiedscalar;
889 /* For tied filehandles, we apply tiedscalar magic to the IO
890 slot of the GP rather than the GV itself. AMS 20010812 */
892 GvIOp(varsv) = newIO();
893 varsv = MUTABLE_SV(GvIOp(varsv));
896 if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
897 vivify_defelem(varsv);
898 varsv = LvTARG(varsv);
902 methname = "TIESCALAR";
903 how = PERL_MAGIC_tiedscalar;
907 if (sv_isobject(*MARK)) { /* Calls GET magic. */
908 ENTER_with_name("call_TIE");
909 PUSHSTACKi(PERLSI_MAGIC);
911 EXTEND(SP,(I32)items);
915 call_method(methname, G_SCALAR);
918 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
919 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
920 * wrong error message, and worse case, supreme action at a distance.
921 * (Sorry obfuscation writers. You're not going to be given this one.)
923 stash = gv_stashsv(*MARK, 0);
924 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
925 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
926 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
928 ENTER_with_name("call_TIE");
929 PUSHSTACKi(PERLSI_MAGIC);
931 EXTEND(SP,(I32)items);
935 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
941 if (sv_isobject(sv)) {
942 sv_unmagic(varsv, how);
943 /* Croak if a self-tie on an aggregate is attempted. */
944 if (varsv == SvRV(sv) &&
945 (SvTYPE(varsv) == SVt_PVAV ||
946 SvTYPE(varsv) == SVt_PVHV))
948 "Self-ties of arrays and hashes are not supported");
949 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
951 LEAVE_with_name("call_TIE");
952 SP = PL_stack_base + markoff;
962 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
963 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
965 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
968 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
969 !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
971 if ((mg = SvTIED_mg(sv, how))) {
972 SV * const obj = SvRV(SvTIED_obj(sv, mg));
974 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
976 if (gv && isGV(gv) && (cv = GvCV(gv))) {
978 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
979 mXPUSHi(SvREFCNT(obj) - 1);
981 ENTER_with_name("call_UNTIE");
982 call_sv(MUTABLE_SV(cv), G_VOID);
983 LEAVE_with_name("call_UNTIE");
986 else if (mg && SvREFCNT(obj) > 1) {
987 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
988 "untie attempted while %"UVuf" inner references still exist",
989 (UV)SvREFCNT(obj) - 1 ) ;
993 sv_unmagic(sv, how) ;
1002 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1003 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1005 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1008 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1009 !(sv = defelem_target(sv, NULL))) goto ret_undef;
1011 if ((mg = SvTIED_mg(sv, how))) {
1012 SETs(SvTIED_obj(sv, mg));
1013 return NORMAL; /* PUTBACK not needed, pp_tied never moves SP */
1027 HV * const hv = MUTABLE_HV(POPs);
1028 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1029 stash = gv_stashsv(sv, 0);
1030 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1032 require_pv("AnyDBM_File.pm");
1034 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1035 DIE(aTHX_ "No dbm on this machine");
1045 mPUSHu(O_RDWR|O_CREAT);
1049 if (!SvOK(right)) right = &PL_sv_no;
1053 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1056 if (!sv_isobject(TOPs)) {
1064 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1068 if (sv_isobject(TOPs)) {
1069 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1070 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1087 struct timeval timebuf;
1088 struct timeval *tbuf = &timebuf;
1091 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1096 # if BYTEORDER & 0xf0000
1097 # define ORDERBYTE (0x88888888 - BYTEORDER)
1099 # define ORDERBYTE (0x4444 - BYTEORDER)
1105 for (i = 1; i <= 3; i++) {
1106 SV * const sv = SP[i];
1110 if (SvREADONLY(sv)) {
1111 if (!(SvPOK(sv) && SvCUR(sv) == 0))
1112 Perl_croak_no_modify();
1114 else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
1117 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1118 "Non-string passed as bitmask");
1119 SvPV_force_nomg_nolen(sv); /* force string conversion */
1126 /* little endians can use vecs directly */
1127 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1134 masksize = NFDBITS / NBBY;
1136 masksize = sizeof(long); /* documented int, everyone seems to use long */
1138 Zero(&fd_sets[0], 4, char*);
1141 # if SELECT_MIN_BITS == 1
1142 growsize = sizeof(fd_set);
1144 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1145 # undef SELECT_MIN_BITS
1146 # define SELECT_MIN_BITS __FD_SETSIZE
1148 /* If SELECT_MIN_BITS is greater than one we most probably will want
1149 * to align the sizes with SELECT_MIN_BITS/8 because for example
1150 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1151 * UNIX, Solaris, Darwin) the smallest quantum select() operates
1152 * on (sets/tests/clears bits) is 32 bits. */
1153 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1159 value = SvNV_nomg(sv);
1162 timebuf.tv_sec = (long)value;
1163 value -= (NV)timebuf.tv_sec;
1164 timebuf.tv_usec = (long)(value * 1000000.0);
1169 for (i = 1; i <= 3; i++) {
1171 if (!SvOK(sv) || SvCUR(sv) == 0) {
1178 Sv_Grow(sv, growsize);
1182 while (++j <= growsize) {
1186 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1188 Newx(fd_sets[i], growsize, char);
1189 for (offset = 0; offset < growsize; offset += masksize) {
1190 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1191 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1194 fd_sets[i] = SvPVX(sv);
1198 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1199 /* Can't make just the (void*) conditional because that would be
1200 * cpp #if within cpp macro, and not all compilers like that. */
1201 nfound = PerlSock_select(
1203 (Select_fd_set_t) fd_sets[1],
1204 (Select_fd_set_t) fd_sets[2],
1205 (Select_fd_set_t) fd_sets[3],
1206 (void*) tbuf); /* Workaround for compiler bug. */
1208 nfound = PerlSock_select(
1210 (Select_fd_set_t) fd_sets[1],
1211 (Select_fd_set_t) fd_sets[2],
1212 (Select_fd_set_t) fd_sets[3],
1215 for (i = 1; i <= 3; i++) {
1218 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1220 for (offset = 0; offset < growsize; offset += masksize) {
1221 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1222 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1224 Safefree(fd_sets[i]);
1231 if (GIMME == G_ARRAY && tbuf) {
1232 value = (NV)(timebuf.tv_sec) +
1233 (NV)(timebuf.tv_usec) / 1000000.0;
1238 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)
1259 PERL_ARGS_ASSERT_SETDEFOUT;
1260 SvREFCNT_inc_simple_void_NN(gv);
1261 SvREFCNT_dec(PL_defoutgv);
1269 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1270 GV * egv = GvEGVx(PL_defoutgv);
1275 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1276 gvp = hv && HvENAME(hv)
1277 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1279 if (gvp && *gvp == egv) {
1280 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1284 mXPUSHs(newRV(MUTABLE_SV(egv)));
1288 if (!GvIO(newdefout))
1289 gv_IOadd(newdefout);
1290 setdefout(newdefout);
1300 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1301 IO *const io = GvIO(gv);
1307 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1309 const U32 gimme = GIMME_V;
1310 Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1311 if (gimme == G_SCALAR) {
1313 SvSetMagicSV_nosteal(TARG, TOPs);
1318 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1319 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1321 SETERRNO(EBADF,RMS_IFI);
1325 sv_setpvs(TARG, " ");
1326 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1327 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1328 /* Find out how many bytes the char needs */
1329 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1332 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1333 SvCUR_set(TARG,1+len);
1337 else SvUTF8_off(TARG);
1343 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1346 const I32 gimme = GIMME_V;
1348 PERL_ARGS_ASSERT_DOFORM;
1351 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1356 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1357 PUSHFORMAT(cx, retop);
1358 if (CvDEPTH(cv) >= 2) {
1359 PERL_STACK_OVERFLOW_CHECK();
1360 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1363 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1365 setdefout(gv); /* locally select filehandle so $% et al work */
1383 gv = MUTABLE_GV(POPs);
1400 tmpsv = sv_newmortal();
1401 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1402 DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
1404 IoFLAGS(io) &= ~IOf_DIDTOP;
1405 RETURNOP(doform(cv,gv,PL_op->op_next));
1411 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1412 IO * const io = GvIOp(gv);
1420 if (!io || !(ofp = IoOFP(io)))
1423 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1424 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1426 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1427 PL_formtarget != PL_toptarget)
1431 if (!IoTOP_GV(io)) {
1434 if (!IoTOP_NAME(io)) {
1436 if (!IoFMT_NAME(io))
1437 IoFMT_NAME(io) = savepv(GvNAME(gv));
1438 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1439 HEKfARG(GvNAME_HEK(gv))));
1440 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1441 if ((topgv && GvFORM(topgv)) ||
1442 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1443 IoTOP_NAME(io) = savesvpv(topname);
1445 IoTOP_NAME(io) = savepvs("top");
1447 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1448 if (!topgv || !GvFORM(topgv)) {
1449 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1452 IoTOP_GV(io) = topgv;
1454 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1455 I32 lines = IoLINES_LEFT(io);
1456 const char *s = SvPVX_const(PL_formtarget);
1457 if (lines <= 0) /* Yow, header didn't even fit!!! */
1459 while (lines-- > 0) {
1460 s = strchr(s, '\n');
1466 const STRLEN save = SvCUR(PL_formtarget);
1467 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1468 do_print(PL_formtarget, ofp);
1469 SvCUR_set(PL_formtarget, save);
1470 sv_chop(PL_formtarget, s);
1471 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1474 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1475 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1476 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1478 PL_formtarget = PL_toptarget;
1479 IoFLAGS(io) |= IOf_DIDTOP;
1481 assert(fgv); /* IoTOP_GV(io) should have been set above */
1484 SV * const sv = sv_newmortal();
1485 gv_efullname4(sv, fgv, NULL, FALSE);
1486 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1488 return doform(cv, gv, PL_op);
1492 POPBLOCK(cx,PL_curpm);
1493 retop = cx->blk_sub.retop;
1495 SP = newsp; /* ignore retval of formline */
1498 if (!io || !(fp = IoOFP(io))) {
1499 if (io && IoIFP(io))
1500 report_wrongway_fh(gv, '<');
1506 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1507 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1509 if (!do_print(PL_formtarget, fp))
1512 FmLINES(PL_formtarget) = 0;
1513 SvCUR_set(PL_formtarget, 0);
1514 *SvEND(PL_formtarget) = '\0';
1515 if (IoFLAGS(io) & IOf_FLUSH)
1516 (void)PerlIO_flush(fp);
1520 PL_formtarget = PL_bodytarget;
1521 PERL_UNUSED_VAR(gimme);
1527 dSP; dMARK; dORIGMARK;
1531 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1532 IO *const io = GvIO(gv);
1534 /* Treat empty list as "" */
1535 if (MARK == SP) XPUSHs(&PL_sv_no);
1538 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1540 if (MARK == ORIGMARK) {
1543 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1546 return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1548 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1555 SETERRNO(EBADF,RMS_IFI);
1558 else if (!(fp = IoOFP(io))) {
1560 report_wrongway_fh(gv, '<');
1561 else if (ckWARN(WARN_CLOSED))
1563 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1567 SV *sv = sv_newmortal();
1568 do_sprintf(sv, SP - MARK, MARK + 1);
1569 if (!do_print(sv, fp))
1572 if (IoFLAGS(io) & IOf_FLUSH)
1573 if (PerlIO_flush(fp) == EOF)
1582 PUSHs(&PL_sv_undef);
1589 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1590 const int mode = POPi;
1591 SV * const sv = POPs;
1592 GV * const gv = MUTABLE_GV(POPs);
1595 /* Need TIEHANDLE method ? */
1596 const char * const tmps = SvPV_const(sv, len);
1597 if (do_open_raw(gv, tmps, len, mode, perm)) {
1598 IoLINES(GvIOp(gv)) = 0;
1602 PUSHs(&PL_sv_undef);
1609 dSP; dMARK; dORIGMARK; dTARGET;
1623 bool charstart = FALSE;
1624 STRLEN charskip = 0;
1626 GV * const gv = MUTABLE_GV(*++MARK);
1629 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1630 && gv && (io = GvIO(gv)) )
1632 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1634 return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1635 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1644 sv_setpvs(bufsv, "");
1645 length = SvIVx(*++MARK);
1647 DIE(aTHX_ "Negative length");
1650 offset = SvIVx(*++MARK);
1654 if (!io || !IoIFP(io)) {
1656 SETERRNO(EBADF,RMS_IFI);
1660 /* Note that fd can here validly be -1, don't check it yet. */
1661 fd = PerlIO_fileno(IoIFP(io));
1663 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1664 buffer = SvPVutf8_force(bufsv, blen);
1665 /* UTF-8 may not have been set if they are all low bytes */
1670 buffer = SvPV_force(bufsv, blen);
1671 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1673 if (DO_UTF8(bufsv)) {
1674 blen = sv_len_utf8_nomg(bufsv);
1683 if (PL_op->op_type == OP_RECV) {
1684 Sock_size_t bufsize;
1685 char namebuf[MAXPATHLEN];
1687 SETERRNO(EBADF,SS_IVCHAN);
1690 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1691 bufsize = sizeof (struct sockaddr_in);
1693 bufsize = sizeof namebuf;
1695 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1699 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1700 /* 'offset' means 'flags' here */
1701 count = PerlSock_recvfrom(fd, buffer, length, offset,
1702 (struct sockaddr *)namebuf, &bufsize);
1705 /* MSG_TRUNC can give oversized count; quietly lose it */
1708 SvCUR_set(bufsv, count);
1709 *SvEND(bufsv) = '\0';
1710 (void)SvPOK_only(bufsv);
1714 /* This should not be marked tainted if the fp is marked clean */
1715 if (!(IoFLAGS(io) & IOf_UNTAINT))
1716 SvTAINTED_on(bufsv);
1718 #if defined(__CYGWIN__)
1719 /* recvfrom() on cygwin doesn't set bufsize at all for
1720 connected sockets, leaving us with trash in the returned
1721 name, so use the same test as the Win32 code to check if it
1722 wasn't set, and set it [perl #118843] */
1723 if (bufsize == sizeof namebuf)
1726 sv_setpvn(TARG, namebuf, bufsize);
1732 if (-offset > (SSize_t)blen)
1733 DIE(aTHX_ "Offset outside string");
1736 if (DO_UTF8(bufsv)) {
1737 /* convert offset-as-chars to offset-as-bytes */
1738 if (offset >= (SSize_t)blen)
1739 offset += SvCUR(bufsv) - blen;
1741 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1745 /* Reestablish the fd in case it shifted from underneath us. */
1746 fd = PerlIO_fileno(IoIFP(io));
1748 orig_size = SvCUR(bufsv);
1749 /* Allocating length + offset + 1 isn't perfect in the case of reading
1750 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1752 (should be 2 * length + offset + 1, or possibly something longer if
1753 PL_encoding is true) */
1754 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1755 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1756 Zero(buffer+orig_size, offset-orig_size, char);
1758 buffer = buffer + offset;
1760 read_target = bufsv;
1762 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1763 concatenate it to the current buffer. */
1765 /* Truncate the existing buffer to the start of where we will be
1767 SvCUR_set(bufsv, offset);
1769 read_target = sv_newmortal();
1770 SvUPGRADE(read_target, SVt_PV);
1771 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1774 if (PL_op->op_type == OP_SYSREAD) {
1775 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1776 if (IoTYPE(io) == IoTYPE_SOCKET) {
1778 SETERRNO(EBADF,SS_IVCHAN);
1782 count = PerlSock_recv(fd, buffer, length, 0);
1788 SETERRNO(EBADF,RMS_IFI);
1792 count = PerlLIO_read(fd, buffer, length);
1797 count = PerlIO_read(IoIFP(io), buffer, length);
1798 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1799 if (count == 0 && PerlIO_error(IoIFP(io)))
1803 if (IoTYPE(io) == IoTYPE_WRONLY)
1804 report_wrongway_fh(gv, '>');
1807 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1808 *SvEND(read_target) = '\0';
1809 (void)SvPOK_only(read_target);
1810 if (fp_utf8 && !IN_BYTES) {
1811 /* Look at utf8 we got back and count the characters */
1812 const char *bend = buffer + count;
1813 while (buffer < bend) {
1815 skip = UTF8SKIP(buffer);
1818 if (buffer - charskip + skip > bend) {
1819 /* partial character - try for rest of it */
1820 length = skip - (bend-buffer);
1821 offset = bend - SvPVX_const(bufsv);
1833 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1834 provided amount read (count) was what was requested (length)
1836 if (got < wanted && count == length) {
1837 length = wanted - got;
1838 offset = bend - SvPVX_const(bufsv);
1841 /* return value is character count */
1845 else if (buffer_utf8) {
1846 /* Let svcatsv upgrade the bytes we read in to utf8.
1847 The buffer is a mortal so will be freed soon. */
1848 sv_catsv_nomg(bufsv, read_target);
1851 /* This should not be marked tainted if the fp is marked clean */
1852 if (!(IoFLAGS(io) & IOf_UNTAINT))
1853 SvTAINTED_on(bufsv);
1865 dSP; dMARK; dORIGMARK; dTARGET;
1870 STRLEN orig_blen_bytes;
1871 const int op_type = PL_op->op_type;
1874 GV *const gv = MUTABLE_GV(*++MARK);
1875 IO *const io = GvIO(gv);
1878 if (op_type == OP_SYSWRITE && io) {
1879 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1881 if (MARK == SP - 1) {
1883 mXPUSHi(sv_len(sv));
1887 return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1888 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1898 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1900 if (io && IoIFP(io))
1901 report_wrongway_fh(gv, '<');
1904 SETERRNO(EBADF,RMS_IFI);
1907 fd = PerlIO_fileno(IoIFP(io));
1909 SETERRNO(EBADF,SS_IVCHAN);
1914 /* Do this first to trigger any overloading. */
1915 buffer = SvPV_const(bufsv, blen);
1916 orig_blen_bytes = blen;
1917 doing_utf8 = DO_UTF8(bufsv);
1919 if (PerlIO_isutf8(IoIFP(io))) {
1920 if (!SvUTF8(bufsv)) {
1921 /* We don't modify the original scalar. */
1922 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1923 buffer = (char *) tmpbuf;
1927 else if (doing_utf8) {
1928 STRLEN tmplen = blen;
1929 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1932 buffer = (char *) tmpbuf;
1936 assert((char *)result == buffer);
1937 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1942 if (op_type == OP_SEND) {
1943 const int flags = SvIVx(*++MARK);
1946 char * const sockbuf = SvPVx(*++MARK, mlen);
1947 retval = PerlSock_sendto(fd, buffer, blen,
1948 flags, (struct sockaddr *)sockbuf, mlen);
1951 retval = PerlSock_send(fd, buffer, blen, flags);
1957 Size_t length = 0; /* This length is in characters. */
1963 /* The SV is bytes, and we've had to upgrade it. */
1964 blen_chars = orig_blen_bytes;
1966 /* The SV really is UTF-8. */
1967 /* Don't call sv_len_utf8 on a magical or overloaded
1968 scalar, as we might get back a different result. */
1969 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
1976 length = blen_chars;
1978 #if Size_t_size > IVSIZE
1979 length = (Size_t)SvNVx(*++MARK);
1981 length = (Size_t)SvIVx(*++MARK);
1983 if ((SSize_t)length < 0) {
1985 DIE(aTHX_ "Negative length");
1990 offset = SvIVx(*++MARK);
1992 if (-offset > (IV)blen_chars) {
1994 DIE(aTHX_ "Offset outside string");
1996 offset += blen_chars;
1997 } else if (offset > (IV)blen_chars) {
1999 DIE(aTHX_ "Offset outside string");
2003 if (length > blen_chars - offset)
2004 length = blen_chars - offset;
2006 /* Here we convert length from characters to bytes. */
2007 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
2008 /* Either we had to convert the SV, or the SV is magical, or
2009 the SV has overloading, in which case we can't or mustn't
2010 or mustn't call it again. */
2012 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
2013 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
2015 /* It's a real UTF-8 SV, and it's not going to change under
2016 us. Take advantage of any cache. */
2018 I32 len_I32 = length;
2020 /* Convert the start and end character positions to bytes.
2021 Remember that the second argument to sv_pos_u2b is relative
2023 sv_pos_u2b(bufsv, &start, &len_I32);
2030 buffer = buffer+offset;
2032 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2033 if (IoTYPE(io) == IoTYPE_SOCKET) {
2034 retval = PerlSock_send(fd, buffer, length, 0);
2039 /* See the note at doio.c:do_print about filesize limits. --jhi */
2040 retval = PerlLIO_write(fd, buffer, length);
2048 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2051 #if Size_t_size > IVSIZE
2071 * in Perl 5.12 and later, the additional parameter is a bitmask:
2074 * 2 = eof() <- ARGV magic
2076 * I'll rely on the compiler's trace flow analysis to decide whether to
2077 * actually assign this out here, or punt it into the only block where it is
2078 * used. Doing it out here is DRY on the condition logic.
2083 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2089 if (PL_op->op_flags & OPf_SPECIAL) {
2090 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2094 gv = PL_last_in_gv; /* eof */
2102 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2103 return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2106 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2107 if (io && !IoIFP(io)) {
2108 if ((IoFLAGS(io) & IOf_START) && av_tindex(GvAVn(gv)) < 0) {
2110 IoFLAGS(io) &= ~IOf_START;
2111 do_open6(gv, "-", 1, NULL, NULL, 0);
2113 sv_setpvs(GvSV(gv), "-");
2115 GvSV(gv) = newSVpvs("-");
2116 SvSETMAGIC(GvSV(gv));
2118 else if (!nextargv(gv))
2123 PUSHs(boolSV(do_eof(gv)));
2133 if (MAXARG != 0 && (TOPs || POPs))
2134 PL_last_in_gv = MUTABLE_GV(POPs);
2141 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2143 return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2148 SETERRNO(EBADF,RMS_IFI);
2153 #if LSEEKSIZE > IVSIZE
2154 PUSHn( do_tell(gv) );
2156 PUSHi( do_tell(gv) );
2164 const int whence = POPi;
2165 #if LSEEKSIZE > IVSIZE
2166 const Off_t offset = (Off_t)SvNVx(POPs);
2168 const Off_t offset = (Off_t)SvIVx(POPs);
2171 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2172 IO *const io = GvIO(gv);
2175 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2177 #if LSEEKSIZE > IVSIZE
2178 SV *const offset_sv = newSVnv((NV) offset);
2180 SV *const offset_sv = newSViv(offset);
2183 return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2188 if (PL_op->op_type == OP_SEEK)
2189 PUSHs(boolSV(do_seek(gv, offset, whence)));
2191 const Off_t sought = do_sysseek(gv, offset, whence);
2193 PUSHs(&PL_sv_undef);
2195 SV* const sv = sought ?
2196 #if LSEEKSIZE > IVSIZE
2201 : newSVpvn(zero_but_true, ZBTLEN);
2211 /* There seems to be no consensus on the length type of truncate()
2212 * and ftruncate(), both off_t and size_t have supporters. In
2213 * general one would think that when using large files, off_t is
2214 * at least as wide as size_t, so using an off_t should be okay. */
2215 /* XXX Configure probe for the length type of *truncate() needed XXX */
2218 #if Off_t_size > IVSIZE
2223 /* Checking for length < 0 is problematic as the type might or
2224 * might not be signed: if it is not, clever compilers will moan. */
2225 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2228 SV * const sv = POPs;
2233 if (PL_op->op_flags & OPf_SPECIAL
2234 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2235 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2242 TAINT_PROPER("truncate");
2243 if (!(fp = IoIFP(io))) {
2247 int fd = PerlIO_fileno(fp);
2249 SETERRNO(EBADF,RMS_IFI);
2254 if (ftruncate(fd, len) < 0)
2256 if (my_chsize(fd, len) < 0)
2263 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2264 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2265 goto do_ftruncate_io;
2268 const char * const name = SvPV_nomg_const_nolen(sv);
2269 TAINT_PROPER("truncate");
2271 if (truncate(name, len) < 0)
2275 const int tmpfd = PerlLIO_open(name, O_RDWR);
2278 SETERRNO(EBADF,RMS_IFI);
2281 if (my_chsize(tmpfd, len) < 0)
2283 PerlLIO_close(tmpfd);
2292 SETERRNO(EBADF,RMS_IFI);
2300 SV * const argsv = POPs;
2301 const unsigned int func = POPu;
2303 GV * const gv = MUTABLE_GV(POPs);
2304 IO * const io = GvIOn(gv);
2310 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2314 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2317 s = SvPV_force(argsv, len);
2318 need = IOCPARM_LEN(func);
2320 s = Sv_Grow(argsv, need + 1);
2321 SvCUR_set(argsv, need);
2324 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2327 retval = SvIV(argsv);
2328 s = INT2PTR(char*,retval); /* ouch */
2331 optype = PL_op->op_type;
2332 TAINT_PROPER(PL_op_desc[optype]);
2334 if (optype == OP_IOCTL)
2336 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2338 DIE(aTHX_ "ioctl is not implemented");
2342 DIE(aTHX_ "fcntl is not implemented");
2344 #if defined(OS2) && defined(__EMX__)
2345 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2347 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2351 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2353 if (s[SvCUR(argsv)] != 17)
2354 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2356 s[SvCUR(argsv)] = 0; /* put our null back */
2357 SvSETMAGIC(argsv); /* Assume it has changed */
2366 PUSHp(zero_but_true, ZBTLEN);
2377 const int argtype = POPi;
2378 GV * const gv = MUTABLE_GV(POPs);
2379 IO *const io = GvIO(gv);
2380 PerlIO *const fp = io ? IoIFP(io) : NULL;
2382 /* XXX Looks to me like io is always NULL at this point */
2384 (void)PerlIO_flush(fp);
2385 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2390 SETERRNO(EBADF,RMS_IFI);
2395 DIE(aTHX_ PL_no_func, "flock");
2406 const int protocol = POPi;
2407 const int type = POPi;
2408 const int domain = POPi;
2409 GV * const gv = MUTABLE_GV(POPs);
2410 IO * const io = GvIOn(gv);
2414 do_close(gv, FALSE);
2416 TAINT_PROPER("socket");
2417 fd = PerlSock_socket(domain, type, protocol);
2419 SETERRNO(EBADF,RMS_IFI);
2422 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2423 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2424 IoTYPE(io) = IoTYPE_SOCKET;
2425 if (!IoIFP(io) || !IoOFP(io)) {
2426 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2427 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2428 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2431 #if defined(HAS_FCNTL) && defined(F_SETFD)
2432 if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) /* ensure close-on-exec */
2442 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2445 const int protocol = POPi;
2446 const int type = POPi;
2447 const int domain = POPi;
2449 GV * const gv2 = MUTABLE_GV(POPs);
2450 IO * const io2 = GvIOn(gv2);
2451 GV * const gv1 = MUTABLE_GV(POPs);
2452 IO * const io1 = GvIOn(gv1);
2455 do_close(gv1, FALSE);
2457 do_close(gv2, FALSE);
2459 TAINT_PROPER("socketpair");
2460 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2462 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2463 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2464 IoTYPE(io1) = IoTYPE_SOCKET;
2465 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2466 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2467 IoTYPE(io2) = IoTYPE_SOCKET;
2468 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2469 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2470 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2471 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2472 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2473 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2474 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2477 #if defined(HAS_FCNTL) && defined(F_SETFD)
2478 /* ensure close-on-exec */
2479 if ((fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
2480 (fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd) < 0))
2486 DIE(aTHX_ PL_no_sock_func, "socketpair");
2495 SV * const addrsv = POPs;
2496 /* OK, so on what platform does bind modify addr? */
2498 GV * const gv = MUTABLE_GV(POPs);
2499 IO * const io = GvIOn(gv);
2506 fd = PerlIO_fileno(IoIFP(io));
2510 addr = SvPV_const(addrsv, len);
2511 op_type = PL_op->op_type;
2512 TAINT_PROPER(PL_op_desc[op_type]);
2513 if ((op_type == OP_BIND
2514 ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
2515 : PerlSock_connect(fd, (struct sockaddr *)addr, len))
2523 SETERRNO(EBADF,SS_IVCHAN);
2530 const int backlog = POPi;
2531 GV * const gv = MUTABLE_GV(POPs);
2532 IO * const io = GvIOn(gv);
2537 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2544 SETERRNO(EBADF,SS_IVCHAN);
2552 char namebuf[MAXPATHLEN];
2553 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2554 Sock_size_t len = sizeof (struct sockaddr_in);
2556 Sock_size_t len = sizeof namebuf;
2558 GV * const ggv = MUTABLE_GV(POPs);
2559 GV * const ngv = MUTABLE_GV(POPs);
2562 IO * const gstio = GvIO(ggv);
2563 if (!gstio || !IoIFP(gstio))
2567 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2570 /* Some platforms indicate zero length when an AF_UNIX client is
2571 * not bound. Simulate a non-zero-length sockaddr structure in
2573 namebuf[0] = 0; /* sun_len */
2574 namebuf[1] = AF_UNIX; /* sun_family */
2582 do_close(ngv, FALSE);
2583 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2584 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2585 IoTYPE(nstio) = IoTYPE_SOCKET;
2586 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2587 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2588 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2589 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2592 #if defined(HAS_FCNTL) && defined(F_SETFD)
2593 if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) /* ensure close-on-exec */
2597 #ifdef __SCO_VERSION__
2598 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2601 PUSHp(namebuf, len);
2605 report_evil_fh(ggv);
2606 SETERRNO(EBADF,SS_IVCHAN);
2616 const int how = POPi;
2617 GV * const gv = MUTABLE_GV(POPs);
2618 IO * const io = GvIOn(gv);
2623 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2628 SETERRNO(EBADF,SS_IVCHAN);
2635 const int optype = PL_op->op_type;
2636 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2637 const unsigned int optname = (unsigned int) POPi;
2638 const unsigned int lvl = (unsigned int) POPi;
2639 GV * const gv = MUTABLE_GV(POPs);
2640 IO * const io = GvIOn(gv);
2647 fd = PerlIO_fileno(IoIFP(io));
2653 (void)SvPOK_only(sv);
2657 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2664 #if defined(__SYMBIAN32__)
2665 # define SETSOCKOPT_OPTION_VALUE_T void *
2667 # define SETSOCKOPT_OPTION_VALUE_T const char *
2669 /* XXX TODO: We need to have a proper type (a Configure probe,
2670 * etc.) for what the C headers think of the third argument of
2671 * setsockopt(), the option_value read-only buffer: is it
2672 * a "char *", or a "void *", const or not. Some compilers
2673 * don't take kindly to e.g. assuming that "char *" implicitly
2674 * promotes to a "void *", or to explicitly promoting/demoting
2675 * consts to non/vice versa. The "const void *" is the SUS
2676 * definition, but that does not fly everywhere for the above
2678 SETSOCKOPT_OPTION_VALUE_T buf;
2682 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2686 aint = (int)SvIV(sv);
2687 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2690 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2700 SETERRNO(EBADF,SS_IVCHAN);
2709 const int optype = PL_op->op_type;
2710 GV * const gv = MUTABLE_GV(POPs);
2711 IO * const io = GvIOn(gv);
2719 sv = sv_2mortal(newSV(257));
2720 (void)SvPOK_only(sv);
2724 fd = PerlIO_fileno(IoIFP(io));
2728 case OP_GETSOCKNAME:
2729 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2732 case OP_GETPEERNAME:
2733 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2735 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2737 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";
2738 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2739 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2740 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2741 sizeof(u_short) + sizeof(struct in_addr))) {
2748 #ifdef BOGUS_GETNAME_RETURN
2749 /* Interactive Unix, getpeername() and getsockname()
2750 does not return valid namelen */
2751 if (len == BOGUS_GETNAME_RETURN)
2752 len = sizeof(struct sockaddr);
2761 SETERRNO(EBADF,SS_IVCHAN);
2779 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2780 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2781 if (PL_op->op_type == OP_LSTAT) {
2782 if (gv != PL_defgv) {
2783 do_fstat_warning_check:
2784 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2785 "lstat() on filehandle%s%"SVf,
2788 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2790 } else if (PL_laststype != OP_LSTAT)
2791 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2792 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2795 if (gv != PL_defgv) {
2799 PL_laststype = OP_STAT;
2800 PL_statgv = gv ? gv : (GV *)io;
2801 sv_setpvs(PL_statname, "");
2807 int fd = PerlIO_fileno(IoIFP(io));
2809 PL_laststatval = -1;
2810 SETERRNO(EBADF,RMS_IFI);
2812 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
2815 } else if (IoDIRP(io)) {
2817 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2820 PL_laststatval = -1;
2823 else PL_laststatval = -1;
2824 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2827 if (PL_laststatval < 0) {
2833 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2834 io = MUTABLE_IO(SvRV(sv));
2835 if (PL_op->op_type == OP_LSTAT)
2836 goto do_fstat_warning_check;
2837 goto do_fstat_have_io;
2840 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2841 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2843 PL_laststype = PL_op->op_type;
2844 file = SvPV_nolen_const(PL_statname);
2845 if (PL_op->op_type == OP_LSTAT)
2846 PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
2848 PL_laststatval = PerlLIO_stat(file, &PL_statcache);
2849 if (PL_laststatval < 0) {
2850 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
2851 /* PL_warn_nl is constant */
2852 GCC_DIAG_IGNORE(-Wformat-nonliteral);
2853 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2861 if (gimme != G_ARRAY) {
2862 if (gimme != G_VOID)
2863 XPUSHs(boolSV(max));
2869 mPUSHi(PL_statcache.st_dev);
2870 #if ST_INO_SIZE > IVSIZE
2871 mPUSHn(PL_statcache.st_ino);
2873 # if ST_INO_SIGN <= 0
2874 mPUSHi(PL_statcache.st_ino);
2876 mPUSHu(PL_statcache.st_ino);
2879 mPUSHu(PL_statcache.st_mode);
2880 mPUSHu(PL_statcache.st_nlink);
2882 sv_setuid(PUSHmortal, PL_statcache.st_uid);
2883 sv_setgid(PUSHmortal, PL_statcache.st_gid);
2885 #ifdef USE_STAT_RDEV
2886 mPUSHi(PL_statcache.st_rdev);
2888 PUSHs(newSVpvs_flags("", SVs_TEMP));
2890 #if Off_t_size > IVSIZE
2891 mPUSHn(PL_statcache.st_size);
2893 mPUSHi(PL_statcache.st_size);
2896 mPUSHn(PL_statcache.st_atime);
2897 mPUSHn(PL_statcache.st_mtime);
2898 mPUSHn(PL_statcache.st_ctime);
2900 mPUSHi(PL_statcache.st_atime);
2901 mPUSHi(PL_statcache.st_mtime);
2902 mPUSHi(PL_statcache.st_ctime);
2904 #ifdef USE_STAT_BLOCKS
2905 mPUSHu(PL_statcache.st_blksize);
2906 mPUSHu(PL_statcache.st_blocks);
2908 PUSHs(newSVpvs_flags("", SVs_TEMP));
2909 PUSHs(newSVpvs_flags("", SVs_TEMP));
2915 /* All filetest ops avoid manipulating the perl stack pointer in their main
2916 bodies (since commit d2c4d2d1e22d3125), and return using either
2917 S_ft_return_false() or S_ft_return_true(). These two helper functions are
2918 the only two which manipulate the perl stack. To ensure that no stack
2919 manipulation macros are used, the filetest ops avoid defining a local copy
2920 of the stack pointer with dSP. */
2922 /* If the next filetest is stacked up with this one
2923 (PL_op->op_private & OPpFT_STACKING), we leave
2924 the original argument on the stack for success,
2925 and skip the stacked operators on failure.
2926 The next few macros/functions take care of this.
2930 S_ft_return_false(pTHX_ SV *ret) {
2934 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
2938 if (PL_op->op_private & OPpFT_STACKING) {
2939 while (OP_IS_FILETEST(next->op_type)
2940 && next->op_private & OPpFT_STACKED)
2941 next = next->op_next;
2946 PERL_STATIC_INLINE OP *
2947 S_ft_return_true(pTHX_ SV *ret) {
2949 if (PL_op->op_flags & OPf_REF)
2950 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
2951 else if (!(PL_op->op_private & OPpFT_STACKING))
2957 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
2958 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
2959 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
2961 #define tryAMAGICftest_MG(chr) STMT_START { \
2962 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
2963 && PL_op->op_flags & OPf_KIDS) { \
2964 OP *next = S_try_amagic_ftest(aTHX_ chr); \
2965 if (next) return next; \
2970 S_try_amagic_ftest(pTHX_ char chr) {
2971 SV *const arg = *PL_stack_sp;
2974 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
2978 const char tmpchr = chr;
2979 SV * const tmpsv = amagic_call(arg,
2980 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2981 ftest_amg, AMGf_unary);
2986 return SvTRUE(tmpsv)
2987 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
2996 /* Not const, because things tweak this below. Not bool, because there's
2997 no guarantee that OPpFT_ACCESS is <= CHAR_MAX */
2998 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2999 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3000 /* Giving some sort of initial value silences compilers. */
3002 int access_mode = R_OK;
3004 int access_mode = 0;
3007 /* access_mode is never used, but leaving use_access in makes the
3008 conditional compiling below much clearer. */
3011 Mode_t stat_mode = S_IRUSR;
3013 bool effective = FALSE;
3016 switch (PL_op->op_type) {
3017 case OP_FTRREAD: opchar = 'R'; break;
3018 case OP_FTRWRITE: opchar = 'W'; break;
3019 case OP_FTREXEC: opchar = 'X'; break;
3020 case OP_FTEREAD: opchar = 'r'; break;
3021 case OP_FTEWRITE: opchar = 'w'; break;
3022 case OP_FTEEXEC: opchar = 'x'; break;
3024 tryAMAGICftest_MG(opchar);
3026 switch (PL_op->op_type) {
3028 #if !(defined(HAS_ACCESS) && defined(R_OK))
3034 #if defined(HAS_ACCESS) && defined(W_OK)
3039 stat_mode = S_IWUSR;
3043 #if defined(HAS_ACCESS) && defined(X_OK)
3048 stat_mode = S_IXUSR;
3052 #ifdef PERL_EFF_ACCESS
3055 stat_mode = S_IWUSR;
3059 #ifndef PERL_EFF_ACCESS
3066 #ifdef PERL_EFF_ACCESS
3071 stat_mode = S_IXUSR;
3077 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3078 const char *name = SvPV_nolen(*PL_stack_sp);
3080 # ifdef PERL_EFF_ACCESS
3081 result = PERL_EFF_ACCESS(name, access_mode);
3083 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3089 result = access(name, access_mode);
3091 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3102 result = my_stat_flags(0);
3105 if (cando(stat_mode, effective, &PL_statcache))
3113 const int op_type = PL_op->op_type;
3117 case OP_FTIS: opchar = 'e'; break;
3118 case OP_FTSIZE: opchar = 's'; break;
3119 case OP_FTMTIME: opchar = 'M'; break;
3120 case OP_FTCTIME: opchar = 'C'; break;
3121 case OP_FTATIME: opchar = 'A'; break;
3123 tryAMAGICftest_MG(opchar);
3125 result = my_stat_flags(0);
3128 if (op_type == OP_FTIS)
3131 /* You can't dTARGET inside OP_FTIS, because you'll get
3132 "panic: pad_sv po" - the op is not flagged to have a target. */
3136 #if Off_t_size > IVSIZE
3137 sv_setnv(TARG, (NV)PL_statcache.st_size);
3139 sv_setiv(TARG, (IV)PL_statcache.st_size);
3144 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3148 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3152 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3156 return SvTRUE_nomg(TARG)
3157 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3166 switch (PL_op->op_type) {
3167 case OP_FTROWNED: opchar = 'O'; break;
3168 case OP_FTEOWNED: opchar = 'o'; break;
3169 case OP_FTZERO: opchar = 'z'; break;
3170 case OP_FTSOCK: opchar = 'S'; break;
3171 case OP_FTCHR: opchar = 'c'; break;
3172 case OP_FTBLK: opchar = 'b'; break;
3173 case OP_FTFILE: opchar = 'f'; break;
3174 case OP_FTDIR: opchar = 'd'; break;
3175 case OP_FTPIPE: opchar = 'p'; break;
3176 case OP_FTSUID: opchar = 'u'; break;
3177 case OP_FTSGID: opchar = 'g'; break;
3178 case OP_FTSVTX: opchar = 'k'; break;
3180 tryAMAGICftest_MG(opchar);
3182 /* I believe that all these three are likely to be defined on most every
3183 system these days. */
3185 if(PL_op->op_type == OP_FTSUID) {
3190 if(PL_op->op_type == OP_FTSGID) {
3195 if(PL_op->op_type == OP_FTSVTX) {
3200 result = my_stat_flags(0);
3203 switch (PL_op->op_type) {
3205 if (PL_statcache.st_uid == PerlProc_getuid())
3209 if (PL_statcache.st_uid == PerlProc_geteuid())
3213 if (PL_statcache.st_size == 0)
3217 if (S_ISSOCK(PL_statcache.st_mode))
3221 if (S_ISCHR(PL_statcache.st_mode))
3225 if (S_ISBLK(PL_statcache.st_mode))
3229 if (S_ISREG(PL_statcache.st_mode))
3233 if (S_ISDIR(PL_statcache.st_mode))
3237 if (S_ISFIFO(PL_statcache.st_mode))
3242 if (PL_statcache.st_mode & S_ISUID)
3248 if (PL_statcache.st_mode & S_ISGID)
3254 if (PL_statcache.st_mode & S_ISVTX)
3266 tryAMAGICftest_MG('l');
3267 result = my_lstat_flags(0);
3271 if (S_ISLNK(PL_statcache.st_mode))
3283 tryAMAGICftest_MG('t');
3285 if (PL_op->op_flags & OPf_REF)
3288 SV *tmpsv = *PL_stack_sp;
3289 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3290 name = SvPV_nomg(tmpsv, namelen);
3291 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3295 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3296 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3297 else if (name && isDIGIT(*name))
3298 fd = grok_atou(name, NULL);
3302 SETERRNO(EBADF,RMS_IFI);
3305 if (PerlLIO_isatty(fd))
3322 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3324 if (PL_op->op_flags & OPf_REF)
3326 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3331 gv = MAYBE_DEREF_GV_nomg(sv);
3335 if (gv == PL_defgv) {
3337 io = SvTYPE(PL_statgv) == SVt_PVIO
3341 goto really_filename;
3346 sv_setpvs(PL_statname, "");
3347 io = GvIO(PL_statgv);
3349 PL_laststatval = -1;
3350 PL_laststype = OP_STAT;
3351 if (io && IoIFP(io)) {
3353 if (! PerlIO_has_base(IoIFP(io)))
3354 DIE(aTHX_ "-T and -B not implemented on filehandles");
3355 fd = PerlIO_fileno(IoIFP(io));
3357 SETERRNO(EBADF,RMS_IFI);
3360 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3361 if (PL_laststatval < 0)
3363 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3364 if (PL_op->op_type == OP_FTTEXT)
3369 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3370 i = PerlIO_getc(IoIFP(io));
3372 (void)PerlIO_ungetc(IoIFP(io),i);
3374 /* null file is anything */
3377 len = PerlIO_get_bufsiz(IoIFP(io));
3378 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3379 /* sfio can have large buffers - limit to 512 */
3384 SETERRNO(EBADF,RMS_IFI);
3386 SETERRNO(EBADF,RMS_IFI);
3395 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3397 file = SvPVX_const(PL_statname);
3399 if (!(fp = PerlIO_open(file, "r"))) {
3401 PL_laststatval = -1;
3402 PL_laststype = OP_STAT;
3404 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
3405 /* PL_warn_nl is constant */
3406 GCC_DIAG_IGNORE(-Wformat-nonliteral);
3407 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3412 PL_laststype = OP_STAT;
3413 fd = PerlIO_fileno(fp);
3415 (void)PerlIO_close(fp);
3416 SETERRNO(EBADF,RMS_IFI);
3419 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3420 if (PL_laststatval < 0) {
3421 (void)PerlIO_close(fp);
3422 SETERRNO(EBADF,RMS_IFI);
3425 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3426 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3427 (void)PerlIO_close(fp);
3429 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3430 FT_RETURNNO; /* special case NFS directories */
3431 FT_RETURNYES; /* null file is anything */
3436 /* now scan s to look for textiness */
3438 #if defined(DOSISH) || defined(USEMYBINMODE)
3439 /* ignore trailing ^Z on short files */
3440 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3445 if (! is_ascii_string((U8 *) s, len)) {
3448 /* Here contains a non-ASCII. See if the entire string is UTF-8. But
3449 * the buffer may end in a partial character, so consider it UTF-8 if
3450 * the first non-UTF8 char is an ending partial */
3451 if (is_utf8_string_loc((U8 *) s, len, &ep)
3452 || ep + UTF8SKIP(ep) > (U8 *) (s + len))
3454 if (PL_op->op_type == OP_FTTEXT) {
3463 /* Here, is not UTF-8 or is entirely ASCII. Look through the buffer for
3464 * things that wouldn't be in ASCII text or rich ASCII text. Count these
3466 for (i = 0; i < len; i++, s++) {
3467 if (!*s) { /* null never allowed in text */
3471 #ifdef USE_LOCALE_CTYPE
3472 if (IN_LC_RUNTIME(LC_CTYPE)) {
3473 if ( isPRINT_LC(*s) || isSPACE_LC(*s)) {
3480 /* VT occurs so rarely in text, that we consider it odd */
3481 || (isSPACE_A(*s) && *s != VT_NATIVE)
3483 /* But there is a fair amount of backspaces and escapes in
3486 || *s == ESC_NATIVE)
3493 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3504 const char *tmps = NULL;
3508 SV * const sv = POPs;
3509 if (PL_op->op_flags & OPf_SPECIAL) {
3510 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3512 else if (!(gv = MAYBE_DEREF_GV(sv)))
3513 tmps = SvPV_nomg_const_nolen(sv);
3516 if( !gv && (!tmps || !*tmps) ) {
3517 HV * const table = GvHVn(PL_envgv);
3520 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3521 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3523 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3528 deprecate("chdir('') or chdir(undef) as chdir()");
3529 tmps = SvPV_nolen_const(*svp);
3533 TAINT_PROPER("chdir");
3538 TAINT_PROPER("chdir");
3541 IO* const io = GvIO(gv);
3544 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3545 } else if (IoIFP(io)) {
3546 int fd = PerlIO_fileno(IoIFP(io));
3550 PUSHi(fchdir(fd) >= 0);
3560 DIE(aTHX_ PL_no_func, "fchdir");
3564 PUSHi( PerlDir_chdir(tmps) >= 0 );
3566 /* Clear the DEFAULT element of ENV so we'll get the new value
3568 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3574 SETERRNO(EBADF,RMS_IFI);
3581 dSP; dMARK; dTARGET;
3582 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3593 char * const tmps = POPpx;
3594 TAINT_PROPER("chroot");
3595 PUSHi( chroot(tmps) >= 0 );
3598 DIE(aTHX_ PL_no_func, "chroot");
3606 const char * const tmps2 = POPpconstx;
3607 const char * const tmps = SvPV_nolen_const(TOPs);
3608 TAINT_PROPER("rename");
3610 anum = PerlLIO_rename(tmps, tmps2);
3612 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3613 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3616 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3617 (void)UNLINK(tmps2);
3618 if (!(anum = link(tmps, tmps2)))
3619 anum = UNLINK(tmps);
3627 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3631 const int op_type = PL_op->op_type;
3635 if (op_type == OP_LINK)
3636 DIE(aTHX_ PL_no_func, "link");
3638 # ifndef HAS_SYMLINK
3639 if (op_type == OP_SYMLINK)
3640 DIE(aTHX_ PL_no_func, "symlink");
3644 const char * const tmps2 = POPpconstx;
3645 const char * const tmps = SvPV_nolen_const(TOPs);
3646 TAINT_PROPER(PL_op_desc[op_type]);
3648 # if defined(HAS_LINK)
3649 # if defined(HAS_SYMLINK)
3650 /* Both present - need to choose which. */
3651 (op_type == OP_LINK) ?
3652 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3654 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3655 PerlLIO_link(tmps, tmps2);
3658 # if defined(HAS_SYMLINK)
3659 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3660 symlink(tmps, tmps2);
3665 SETi( result >= 0 );
3672 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3682 char buf[MAXPATHLEN];
3687 /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
3688 * it is impossible to know whether the result was truncated. */
3689 len = readlink(tmps, buf, sizeof(buf) - 1);
3698 RETSETUNDEF; /* just pretend it's a normal file */
3702 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3704 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3706 char * const save_filename = filename;
3711 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3713 PERL_ARGS_ASSERT_DOONELINER;
3715 Newx(cmdline, size, char);
3716 my_strlcpy(cmdline, cmd, size);
3717 my_strlcat(cmdline, " ", size);
3718 for (s = cmdline + strlen(cmdline); *filename; ) {
3722 if (s - cmdline < size)
3723 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3724 myfp = PerlProc_popen(cmdline, "r");
3728 SV * const tmpsv = sv_newmortal();
3729 /* Need to save/restore 'PL_rs' ?? */
3730 s = sv_gets(tmpsv, myfp, 0);
3731 (void)PerlProc_pclose(myfp);
3735 #ifdef HAS_SYS_ERRLIST
3740 /* you don't see this */
3741 const char * const errmsg = Strerror(e) ;
3744 if (instr(s, errmsg)) {
3751 #define EACCES EPERM
3753 if (instr(s, "cannot make"))
3754 SETERRNO(EEXIST,RMS_FEX);
3755 else if (instr(s, "existing file"))
3756 SETERRNO(EEXIST,RMS_FEX);
3757 else if (instr(s, "ile exists"))
3758 SETERRNO(EEXIST,RMS_FEX);
3759 else if (instr(s, "non-exist"))
3760 SETERRNO(ENOENT,RMS_FNF);
3761 else if (instr(s, "does not exist"))
3762 SETERRNO(ENOENT,RMS_FNF);
3763 else if (instr(s, "not empty"))
3764 SETERRNO(EBUSY,SS_DEVOFFLINE);
3765 else if (instr(s, "cannot access"))
3766 SETERRNO(EACCES,RMS_PRV);
3768 SETERRNO(EPERM,RMS_PRV);
3771 else { /* some mkdirs return no failure indication */
3772 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3773 if (PL_op->op_type == OP_RMDIR)
3778 SETERRNO(EACCES,RMS_PRV); /* a guess */
3787 /* This macro removes trailing slashes from a directory name.
3788 * Different operating and file systems take differently to
3789 * trailing slashes. According to POSIX 1003.1 1996 Edition
3790 * any number of trailing slashes should be allowed.
3791 * Thusly we snip them away so that even non-conforming
3792 * systems are happy.
3793 * We should probably do this "filtering" for all
3794 * the functions that expect (potentially) directory names:
3795 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3796 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3798 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3799 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3802 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3803 (tmps) = savepvn((tmps), (len)); \
3813 const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3815 TRIMSLASHES(tmps,len,copy);
3817 TAINT_PROPER("mkdir");
3819 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3823 SETi( dooneliner("mkdir", tmps) );
3824 oldumask = PerlLIO_umask(0);
3825 PerlLIO_umask(oldumask);
3826 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3841 TRIMSLASHES(tmps,len,copy);
3842 TAINT_PROPER("rmdir");
3844 SETi( PerlDir_rmdir(tmps) >= 0 );
3846 SETi( dooneliner("rmdir", tmps) );
3853 /* Directory calls. */
3857 #if defined(Direntry_t) && defined(HAS_READDIR)
3859 const char * const dirname = POPpconstx;
3860 GV * const gv = MUTABLE_GV(POPs);
3861 IO * const io = GvIOn(gv);
3863 if ((IoIFP(io) || IoOFP(io)))
3864 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3865 "Opening filehandle %"HEKf" also as a directory",
3866 HEKfARG(GvENAME_HEK(gv)) );
3868 PerlDir_close(IoDIRP(io));
3869 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3875 SETERRNO(EBADF,RMS_DIR);
3878 DIE(aTHX_ PL_no_dir_func, "opendir");
3884 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3885 DIE(aTHX_ PL_no_dir_func, "readdir");
3887 #if !defined(I_DIRENT) && !defined(VMS)
3888 Direntry_t *readdir (DIR *);
3893 const I32 gimme = GIMME;
3894 GV * const gv = MUTABLE_GV(POPs);
3895 const Direntry_t *dp;
3896 IO * const io = GvIOn(gv);
3899 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3900 "readdir() attempted on invalid dirhandle %"HEKf,
3901 HEKfARG(GvENAME_HEK(gv)));
3906 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3910 sv = newSVpvn(dp->d_name, dp->d_namlen);
3912 sv = newSVpv(dp->d_name, 0);
3914 if (!(IoFLAGS(io) & IOf_UNTAINT))
3917 } while (gimme == G_ARRAY);
3919 if (!dp && gimme != G_ARRAY)
3926 SETERRNO(EBADF,RMS_ISI);
3927 if (GIMME == G_ARRAY)
3936 #if defined(HAS_TELLDIR) || defined(telldir)
3938 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3939 /* XXX netbsd still seemed to.
3940 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3941 --JHI 1999-Feb-02 */
3942 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3943 long telldir (DIR *);
3945 GV * const gv = MUTABLE_GV(POPs);
3946 IO * const io = GvIOn(gv);
3949 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3950 "telldir() attempted on invalid dirhandle %"HEKf,
3951 HEKfARG(GvENAME_HEK(gv)));
3955 PUSHi( PerlDir_tell(IoDIRP(io)) );
3959 SETERRNO(EBADF,RMS_ISI);
3962 DIE(aTHX_ PL_no_dir_func, "telldir");
3968 #if defined(HAS_SEEKDIR) || defined(seekdir)
3970 const long along = POPl;
3971 GV * const gv = MUTABLE_GV(POPs);
3972 IO * const io = GvIOn(gv);
3975 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3976 "seekdir() attempted on invalid dirhandle %"HEKf,
3977 HEKfARG(GvENAME_HEK(gv)));
3980 (void)PerlDir_seek(IoDIRP(io), along);
3985 SETERRNO(EBADF,RMS_ISI);
3988 DIE(aTHX_ PL_no_dir_func, "seekdir");
3994 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3996 GV * const gv = MUTABLE_GV(POPs);
3997 IO * const io = GvIOn(gv);
4000 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4001 "rewinddir() attempted on invalid dirhandle %"HEKf,
4002 HEKfARG(GvENAME_HEK(gv)));
4005 (void)PerlDir_rewind(IoDIRP(io));
4009 SETERRNO(EBADF,RMS_ISI);
4012 DIE(aTHX_ PL_no_dir_func, "rewinddir");
4018 #if defined(Direntry_t) && defined(HAS_READDIR)
4020 GV * const gv = MUTABLE_GV(POPs);
4021 IO * const io = GvIOn(gv);
4024 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4025 "closedir() attempted on invalid dirhandle %"HEKf,
4026 HEKfARG(GvENAME_HEK(gv)));
4029 #ifdef VOID_CLOSEDIR
4030 PerlDir_close(IoDIRP(io));
4032 if (PerlDir_close(IoDIRP(io)) < 0) {
4033 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4042 SETERRNO(EBADF,RMS_IFI);
4045 DIE(aTHX_ PL_no_dir_func, "closedir");
4049 /* Process control. */
4056 #ifdef HAS_SIGPROCMASK
4057 sigset_t oldmask, newmask;
4061 PERL_FLUSHALL_FOR_CHILD;
4062 #ifdef HAS_SIGPROCMASK
4063 sigfillset(&newmask);
4064 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4066 childpid = PerlProc_fork();
4067 if (childpid == 0) {
4071 for (sig = 1; sig < SIG_SIZE; sig++)
4072 PL_psig_pend[sig] = 0;
4074 #ifdef HAS_SIGPROCMASK
4077 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4084 #ifdef PERL_USES_PL_PIDSTATUS
4085 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4091 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4096 PERL_FLUSHALL_FOR_CHILD;
4097 childpid = PerlProc_fork();
4103 DIE(aTHX_ PL_no_func, "fork");
4110 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4115 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4116 childpid = wait4pid(-1, &argflags, 0);
4118 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4123 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4124 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4125 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4127 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4132 DIE(aTHX_ PL_no_func, "wait");
4138 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4140 const int optype = POPi;
4141 const Pid_t pid = TOPi;
4145 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4146 result = wait4pid(pid, &argflags, optype);
4148 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4153 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4154 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4155 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4157 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4162 DIE(aTHX_ PL_no_func, "waitpid");
4168 dSP; dMARK; dORIGMARK; dTARGET;
4169 #if defined(__LIBCATAMOUNT__)
4170 PL_statusvalue = -1;
4179 while (++MARK <= SP) {
4180 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4185 TAINT_PROPER("system");
4187 PERL_FLUSHALL_FOR_CHILD;
4188 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4193 #ifdef HAS_SIGPROCMASK
4194 sigset_t newset, oldset;
4197 if (PerlProc_pipe(pp) >= 0)
4199 #ifdef HAS_SIGPROCMASK
4200 sigemptyset(&newset);
4201 sigaddset(&newset, SIGCHLD);
4202 sigprocmask(SIG_BLOCK, &newset, &oldset);
4204 while ((childpid = PerlProc_fork()) == -1) {
4205 if (errno != EAGAIN) {
4210 PerlLIO_close(pp[0]);
4211 PerlLIO_close(pp[1]);
4213 #ifdef HAS_SIGPROCMASK
4214 sigprocmask(SIG_SETMASK, &oldset, NULL);
4221 Sigsave_t ihand,qhand; /* place to save signals during system() */
4225 PerlLIO_close(pp[1]);
4227 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4228 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4231 result = wait4pid(childpid, &status, 0);
4232 } while (result == -1 && errno == EINTR);
4234 #ifdef HAS_SIGPROCMASK
4235 sigprocmask(SIG_SETMASK, &oldset, NULL);
4237 (void)rsignal_restore(SIGINT, &ihand);
4238 (void)rsignal_restore(SIGQUIT, &qhand);
4240 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4241 do_execfree(); /* free any memory child malloced on fork */
4248 while (n < sizeof(int)) {
4249 n1 = PerlLIO_read(pp[0],
4250 (void*)(((char*)&errkid)+n),
4256 PerlLIO_close(pp[0]);
4257 if (n) { /* Error */
4258 if (n != sizeof(int))
4259 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4260 errno = errkid; /* Propagate errno from kid */
4261 STATUS_NATIVE_CHILD_SET(-1);
4264 XPUSHi(STATUS_CURRENT);
4267 #ifdef HAS_SIGPROCMASK
4268 sigprocmask(SIG_SETMASK, &oldset, NULL);
4271 PerlLIO_close(pp[0]);
4272 #if defined(HAS_FCNTL) && defined(F_SETFD)
4273 if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
4277 if (PL_op->op_flags & OPf_STACKED) {
4278 SV * const really = *++MARK;
4279 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4281 else if (SP - MARK != 1)
4282 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4284 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4288 #else /* ! FORK or VMS or OS/2 */
4291 if (PL_op->op_flags & OPf_STACKED) {
4292 SV * const really = *++MARK;
4293 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4294 value = (I32)do_aspawn(really, MARK, SP);
4296 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4299 else if (SP - MARK != 1) {
4300 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4301 value = (I32)do_aspawn(NULL, MARK, SP);
4303 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4307 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4309 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4311 STATUS_NATIVE_CHILD_SET(value);
4314 XPUSHi(result ? value : STATUS_CURRENT);
4315 #endif /* !FORK or VMS or OS/2 */
4322 dSP; dMARK; dORIGMARK; dTARGET;
4327 while (++MARK <= SP) {
4328 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4333 TAINT_PROPER("exec");
4335 PERL_FLUSHALL_FOR_CHILD;
4336 if (PL_op->op_flags & OPf_STACKED) {
4337 SV * const really = *++MARK;
4338 value = (I32)do_aexec(really, MARK, SP);
4340 else if (SP - MARK != 1)
4342 value = (I32)vms_do_aexec(NULL, MARK, SP);
4344 value = (I32)do_aexec(NULL, MARK, SP);
4348 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4350 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4363 XPUSHi( getppid() );
4366 DIE(aTHX_ PL_no_func, "getppid");
4376 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4379 pgrp = (I32)BSD_GETPGRP(pid);
4381 if (pid != 0 && pid != PerlProc_getpid())
4382 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4388 DIE(aTHX_ PL_no_func, "getpgrp");
4398 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4399 if (MAXARG > 0) pid = TOPs && TOPi;
4405 TAINT_PROPER("setpgrp");
4407 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4409 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4410 || (pid != 0 && pid != PerlProc_getpid()))
4412 DIE(aTHX_ "setpgrp can't take arguments");
4414 SETi( setpgrp() >= 0 );
4415 #endif /* USE_BSDPGRP */
4418 DIE(aTHX_ PL_no_func, "setpgrp");
4422 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4423 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4425 # define PRIORITY_WHICH_T(which) which
4430 #ifdef HAS_GETPRIORITY
4432 const int who = POPi;
4433 const int which = TOPi;
4434 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4437 DIE(aTHX_ PL_no_func, "getpriority");
4443 #ifdef HAS_SETPRIORITY
4445 const int niceval = POPi;
4446 const int who = POPi;
4447 const int which = TOPi;
4448 TAINT_PROPER("setpriority");
4449 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4452 DIE(aTHX_ PL_no_func, "setpriority");
4456 #undef PRIORITY_WHICH_T
4464 XPUSHn( time(NULL) );
4466 XPUSHi( time(NULL) );
4475 struct tms timesbuf;
4478 (void)PerlProc_times(×buf);
4480 mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
4481 if (GIMME == G_ARRAY) {
4482 mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
4483 mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
4484 mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
4492 if (GIMME == G_ARRAY) {
4499 DIE(aTHX_ "times not implemented");
4501 #endif /* HAS_TIMES */
4504 /* The 32 bit int year limits the times we can represent to these
4505 boundaries with a few days wiggle room to account for time zone
4508 /* Sat Jan 3 00:00:00 -2147481748 */
4509 #define TIME_LOWER_BOUND -67768100567755200.0
4510 /* Sun Dec 29 12:00:00 2147483647 */
4511 #define TIME_UPPER_BOUND 67767976233316800.0
4519 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4520 static const char * const dayname[] =
4521 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4522 static const char * const monname[] =
4523 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4524 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4526 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4529 when = (Time64_T)now;
4532 NV input = Perl_floor(POPn);
4533 when = (Time64_T)input;
4534 if (when != input) {
4535 /* diag_listed_as: gmtime(%f) too large */
4536 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4537 "%s(%.0" NVff ") too large", opname, input);
4541 if ( TIME_LOWER_BOUND > when ) {
4542 /* diag_listed_as: gmtime(%f) too small */
4543 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4544 "%s(%.0" NVff ") too small", opname, when);
4547 else if( when > TIME_UPPER_BOUND ) {
4548 /* diag_listed_as: gmtime(%f) too small */
4549 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4550 "%s(%.0" NVff ") too large", opname, when);
4554 if (PL_op->op_type == OP_LOCALTIME)
4555 err = S_localtime64_r(&when, &tmbuf);
4557 err = S_gmtime64_r(&when, &tmbuf);
4561 /* diag_listed_as: gmtime(%f) failed */
4562 /* XXX %lld broken for quads */
4563 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4564 "%s(%.0" NVff ") failed", opname, when);
4567 if (GIMME != G_ARRAY) { /* scalar context */
4573 mPUSHs(Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %"IVdf,
4574 dayname[tmbuf.tm_wday],
4575 monname[tmbuf.tm_mon],
4580 (IV)tmbuf.tm_year + 1900));
4583 else { /* list context */
4589 mPUSHi(tmbuf.tm_sec);
4590 mPUSHi(tmbuf.tm_min);
4591 mPUSHi(tmbuf.tm_hour);
4592 mPUSHi(tmbuf.tm_mday);
4593 mPUSHi(tmbuf.tm_mon);
4594 mPUSHn(tmbuf.tm_year);
4595 mPUSHi(tmbuf.tm_wday);
4596 mPUSHi(tmbuf.tm_yday);
4597 mPUSHi(tmbuf.tm_isdst);
4608 anum = alarm((unsigned int)anum);
4614 DIE(aTHX_ PL_no_func, "alarm");
4625 (void)time(&lasttime);
4626 if (MAXARG < 1 || (!TOPs && !POPs))
4630 PerlProc_sleep((unsigned int)duration);
4633 XPUSHi(when - lasttime);
4637 /* Shared memory. */
4638 /* Merged with some message passing. */
4642 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4643 dSP; dMARK; dTARGET;
4644 const int op_type = PL_op->op_type;
4649 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4652 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4655 value = (I32)(do_semop(MARK, SP) >= 0);
4658 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4666 return Perl_pp_semget(aTHX);
4674 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4675 dSP; dMARK; dTARGET;
4676 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4683 DIE(aTHX_ "System V IPC is not implemented on this machine");
4689 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4690 dSP; dMARK; dTARGET;
4691 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4699 PUSHp(zero_but_true, ZBTLEN);
4703 return Perl_pp_semget(aTHX);
4707 /* I can't const this further without getting warnings about the types of
4708 various arrays passed in from structures. */
4710 S_space_join_names_mortal(pTHX_ char *const *array)
4714 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4716 if (array && *array) {
4717 target = newSVpvs_flags("", SVs_TEMP);
4719 sv_catpv(target, *array);
4722 sv_catpvs(target, " ");
4725 target = sv_mortalcopy(&PL_sv_no);
4730 /* Get system info. */
4734 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4736 I32 which = PL_op->op_type;
4739 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4740 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4741 struct hostent *gethostbyname(Netdb_name_t);
4742 struct hostent *gethostent(void);
4744 struct hostent *hent = NULL;
4748 if (which == OP_GHBYNAME) {
4749 #ifdef HAS_GETHOSTBYNAME
4750 const char* const name = POPpbytex;
4751 hent = PerlSock_gethostbyname(name);
4753 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4756 else if (which == OP_GHBYADDR) {
4757 #ifdef HAS_GETHOSTBYADDR
4758 const int addrtype = POPi;
4759 SV * const addrsv = POPs;
4761 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4763 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4765 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4769 #ifdef HAS_GETHOSTENT
4770 hent = PerlSock_gethostent();
4772 DIE(aTHX_ PL_no_sock_func, "gethostent");
4775 #ifdef HOST_NOT_FOUND
4777 #ifdef USE_REENTRANT_API
4778 # ifdef USE_GETHOSTENT_ERRNO
4779 h_errno = PL_reentrant_buffer->_gethostent_errno;
4782 STATUS_UNIX_SET(h_errno);
4786 if (GIMME != G_ARRAY) {
4787 PUSHs(sv = sv_newmortal());
4789 if (which == OP_GHBYNAME) {
4791 sv_setpvn(sv, hent->h_addr, hent->h_length);
4794 sv_setpv(sv, (char*)hent->h_name);
4800 mPUSHs(newSVpv((char*)hent->h_name, 0));
4801 PUSHs(space_join_names_mortal(hent->h_aliases));
4802 mPUSHi(hent->h_addrtype);
4803 len = hent->h_length;
4806 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4807 mXPUSHp(*elem, len);
4811 mPUSHp(hent->h_addr, len);
4813 PUSHs(sv_mortalcopy(&PL_sv_no));
4818 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4824 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4826 I32 which = PL_op->op_type;
4828 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4829 struct netent *getnetbyaddr(Netdb_net_t, int);
4830 struct netent *getnetbyname(Netdb_name_t);
4831 struct netent *getnetent(void);
4833 struct netent *nent;
4835 if (which == OP_GNBYNAME){
4836 #ifdef HAS_GETNETBYNAME
4837 const char * const name = POPpbytex;
4838 nent = PerlSock_getnetbyname(name);
4840 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4843 else if (which == OP_GNBYADDR) {
4844 #ifdef HAS_GETNETBYADDR
4845 const int addrtype = POPi;
4846 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4847 nent = PerlSock_getnetbyaddr(addr, addrtype);
4849 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4853 #ifdef HAS_GETNETENT
4854 nent = PerlSock_getnetent();
4856 DIE(aTHX_ PL_no_sock_func, "getnetent");
4859 #ifdef HOST_NOT_FOUND
4861 #ifdef USE_REENTRANT_API
4862 # ifdef USE_GETNETENT_ERRNO
4863 h_errno = PL_reentrant_buffer->_getnetent_errno;
4866 STATUS_UNIX_SET(h_errno);
4871 if (GIMME != G_ARRAY) {
4872 PUSHs(sv = sv_newmortal());
4874 if (which == OP_GNBYNAME)
4875 sv_setiv(sv, (IV)nent->n_net);
4877 sv_setpv(sv, nent->n_name);
4883 mPUSHs(newSVpv(nent->n_name, 0));
4884 PUSHs(space_join_names_mortal(nent->n_aliases));
4885 mPUSHi(nent->n_addrtype);
4886 mPUSHi(nent->n_net);
4891 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4897 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4899 I32 which = PL_op->op_type;
4901 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4902 struct protoent *getprotobyname(Netdb_name_t);
4903 struct protoent *getprotobynumber(int);
4904 struct protoent *getprotoent(void);
4906 struct protoent *pent;
4908 if (which == OP_GPBYNAME) {
4909 #ifdef HAS_GETPROTOBYNAME
4910 const char* const name = POPpbytex;
4911 pent = PerlSock_getprotobyname(name);
4913 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4916 else if (which == OP_GPBYNUMBER) {
4917 #ifdef HAS_GETPROTOBYNUMBER
4918 const int number = POPi;
4919 pent = PerlSock_getprotobynumber(number);
4921 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4925 #ifdef HAS_GETPROTOENT
4926 pent = PerlSock_getprotoent();
4928 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4932 if (GIMME != G_ARRAY) {
4933 PUSHs(sv = sv_newmortal());
4935 if (which == OP_GPBYNAME)
4936 sv_setiv(sv, (IV)pent->p_proto);
4938 sv_setpv(sv, pent->p_name);
4944 mPUSHs(newSVpv(pent->p_name, 0));
4945 PUSHs(space_join_names_mortal(pent->p_aliases));
4946 mPUSHi(pent->p_proto);
4951 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4957 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4959 I32 which = PL_op->op_type;
4961 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4962 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4963 struct servent *getservbyport(int, Netdb_name_t);
4964 struct servent *getservent(void);
4966 struct servent *sent;
4968 if (which == OP_GSBYNAME) {
4969 #ifdef HAS_GETSERVBYNAME
4970 const char * const proto = POPpbytex;
4971 const char * const name = POPpbytex;
4972 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4974 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4977 else if (which == OP_GSBYPORT) {
4978 #ifdef HAS_GETSERVBYPORT
4979 const char * const proto = POPpbytex;
4980 unsigned short port = (unsigned short)POPu;
4981 port = PerlSock_htons(port);
4982 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4984 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4988 #ifdef HAS_GETSERVENT
4989 sent = PerlSock_getservent();
4991 DIE(aTHX_ PL_no_sock_func, "getservent");
4995 if (GIMME != G_ARRAY) {
4996 PUSHs(sv = sv_newmortal());
4998 if (which == OP_GSBYNAME) {
4999 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5002 sv_setpv(sv, sent->s_name);
5008 mPUSHs(newSVpv(sent->s_name, 0));
5009 PUSHs(space_join_names_mortal(sent->s_aliases));
5010 mPUSHi(PerlSock_ntohs(sent->s_port));
5011 mPUSHs(newSVpv(sent->s_proto, 0));
5016 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5023 const int stayopen = TOPi;
5024 switch(PL_op->op_type) {
5026 #ifdef HAS_SETHOSTENT
5027 PerlSock_sethostent(stayopen);
5029 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5032 #ifdef HAS_SETNETENT
5034 PerlSock_setnetent(stayopen);
5036 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5040 #ifdef HAS_SETPROTOENT
5041 PerlSock_setprotoent(stayopen);
5043 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5047 #ifdef HAS_SETSERVENT
5048 PerlSock_setservent(stayopen);
5050 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5060 switch(PL_op->op_type) {
5062 #ifdef HAS_ENDHOSTENT
5063 PerlSock_endhostent();
5065 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5069 #ifdef HAS_ENDNETENT
5070 PerlSock_endnetent();
5072 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5076 #ifdef HAS_ENDPROTOENT
5077 PerlSock_endprotoent();
5079 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5083 #ifdef HAS_ENDSERVENT
5084 PerlSock_endservent();
5086 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5090 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5093 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5097 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5100 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5104 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5107 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5111 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5114 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5126 I32 which = PL_op->op_type;
5128 struct passwd *pwent = NULL;
5130 * We currently support only the SysV getsp* shadow password interface.
5131 * The interface is declared in <shadow.h> and often one needs to link
5132 * with -lsecurity or some such.
5133 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5136 * AIX getpwnam() is clever enough to return the encrypted password
5137 * only if the caller (euid?) is root.
5139 * There are at least three other shadow password APIs. Many platforms
5140 * seem to contain more than one interface for accessing the shadow
5141 * password databases, possibly for compatibility reasons.
5142 * The getsp*() is by far he simplest one, the other two interfaces
5143 * are much more complicated, but also very similar to each other.
5148 * struct pr_passwd *getprpw*();
5149 * The password is in
5150 * char getprpw*(...).ufld.fd_encrypt[]
5151 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5156 * struct es_passwd *getespw*();
5157 * The password is in
5158 * char *(getespw*(...).ufld.fd_encrypt)
5159 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5162 * struct userpw *getuserpw();
5163 * The password is in
5164 * char *(getuserpw(...)).spw_upw_passwd
5165 * (but the de facto standard getpwnam() should work okay)
5167 * Mention I_PROT here so that Configure probes for it.
5169 * In HP-UX for getprpw*() the manual page claims that one should include
5170 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5171 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5172 * and pp_sys.c already includes <shadow.h> if there is such.
5174 * Note that <sys/security.h> is already probed for, but currently
5175 * it is only included in special cases.
5177 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5178 * be preferred interface, even though also the getprpw*() interface
5179 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5180 * One also needs to call set_auth_parameters() in main() before
5181 * doing anything else, whether one is using getespw*() or getprpw*().
5183 * Note that accessing the shadow databases can be magnitudes
5184 * slower than accessing the standard databases.
5189 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5190 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5191 * the pw_comment is left uninitialized. */
5192 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5198 const char* const name = POPpbytex;
5199 pwent = getpwnam(name);
5205 pwent = getpwuid(uid);
5209 # ifdef HAS_GETPWENT
5211 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5212 if (pwent) pwent = getpwnam(pwent->pw_name);
5215 DIE(aTHX_ PL_no_func, "getpwent");
5221 if (GIMME != G_ARRAY) {
5222 PUSHs(sv = sv_newmortal());
5224 if (which == OP_GPWNAM)
5225 sv_setuid(sv, pwent->pw_uid);
5227 sv_setpv(sv, pwent->pw_name);
5233 mPUSHs(newSVpv(pwent->pw_name, 0));
5237 /* If we have getspnam(), we try to dig up the shadow
5238 * password. If we are underprivileged, the shadow
5239 * interface will set the errno to EACCES or similar,
5240 * and return a null pointer. If this happens, we will
5241 * use the dummy password (usually "*" or "x") from the
5242 * standard password database.
5244 * In theory we could skip the shadow call completely
5245 * if euid != 0 but in practice we cannot know which
5246 * security measures are guarding the shadow databases
5247 * on a random platform.
5249 * Resist the urge to use additional shadow interfaces.
5250 * Divert the urge to writing an extension instead.
5253 /* Some AIX setups falsely(?) detect some getspnam(), which
5254 * has a different API than the Solaris/IRIX one. */
5255 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5258 const struct spwd * const spwent = getspnam(pwent->pw_name);
5259 /* Save and restore errno so that
5260 * underprivileged attempts seem
5261 * to have never made the unsuccessful
5262 * attempt to retrieve the shadow password. */
5264 if (spwent && spwent->sp_pwdp)
5265 sv_setpv(sv, spwent->sp_pwdp);
5269 if (!SvPOK(sv)) /* Use the standard password, then. */
5270 sv_setpv(sv, pwent->pw_passwd);
5273 /* passwd is tainted because user himself can diddle with it.
5274 * admittedly not much and in a very limited way, but nevertheless. */
5277 sv_setuid(PUSHmortal, pwent->pw_uid);
5278 sv_setgid(PUSHmortal, pwent->pw_gid);
5280 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5281 * because of the poor interface of the Perl getpw*(),
5282 * not because there's some standard/convention saying so.
5283 * A better interface would have been to return a hash,
5284 * but we are accursed by our history, alas. --jhi. */
5286 mPUSHi(pwent->pw_change);
5289 mPUSHi(pwent->pw_quota);
5292 mPUSHs(newSVpv(pwent->pw_age, 0));
5294 /* I think that you can never get this compiled, but just in case. */
5295 PUSHs(sv_mortalcopy(&PL_sv_no));
5300 /* pw_class and pw_comment are mutually exclusive--.
5301 * see the above note for pw_change, pw_quota, and pw_age. */
5303 mPUSHs(newSVpv(pwent->pw_class, 0));
5306 mPUSHs(newSVpv(pwent->pw_comment, 0));
5308 /* I think that you can never get this compiled, but just in case. */
5309 PUSHs(sv_mortalcopy(&PL_sv_no));
5314 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5316 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5318 /* pw_gecos is tainted because user himself can diddle with it. */
5321 mPUSHs(newSVpv(pwent->pw_dir, 0));
5323 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5324 /* pw_shell is tainted because user himself can diddle with it. */
5328 mPUSHi(pwent->pw_expire);
5333 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5341 const I32 which = PL_op->op_type;
5342 const struct group *grent;
5344 if (which == OP_GGRNAM) {
5345 const char* const name = POPpbytex;
5346 grent = (const struct group *)getgrnam(name);
5348 else if (which == OP_GGRGID) {
5349 const Gid_t gid = POPi;
5350 grent = (const struct group *)getgrgid(gid);
5354 grent = (struct group *)getgrent();
5356 DIE(aTHX_ PL_no_func, "getgrent");
5360 if (GIMME != G_ARRAY) {
5361 SV * const sv = sv_newmortal();
5365 if (which == OP_GGRNAM)
5366 sv_setgid(sv, grent->gr_gid);
5368 sv_setpv(sv, grent->gr_name);
5374 mPUSHs(newSVpv(grent->gr_name, 0));
5377 mPUSHs(newSVpv(grent->gr_passwd, 0));
5379 PUSHs(sv_mortalcopy(&PL_sv_no));
5382 sv_setgid(PUSHmortal, grent->gr_gid);
5384 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5385 /* In UNICOS/mk (_CRAYMPP) the multithreading
5386 * versions (getgrnam_r, getgrgid_r)
5387 * seem to return an illegal pointer
5388 * as the group members list, gr_mem.
5389 * getgrent() doesn't even have a _r version
5390 * but the gr_mem is poisonous anyway.
5391 * So yes, you cannot get the list of group
5392 * members if building multithreaded in UNICOS/mk. */
5393 PUSHs(space_join_names_mortal(grent->gr_mem));
5399 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5409 if (!(tmps = PerlProc_getlogin()))
5411 sv_setpv_mg(TARG, tmps);
5415 DIE(aTHX_ PL_no_func, "getlogin");
5419 /* Miscellaneous. */
5424 dSP; dMARK; dORIGMARK; dTARGET;
5425 I32 items = SP - MARK;
5426 unsigned long a[20];
5431 while (++MARK <= SP) {
5432 if (SvTAINTED(*MARK)) {
5438 TAINT_PROPER("syscall");
5441 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5442 * or where sizeof(long) != sizeof(char*). But such machines will
5443 * not likely have syscall implemented either, so who cares?
5445 while (++MARK <= SP) {
5446 if (SvNIOK(*MARK) || !i)
5447 a[i++] = SvIV(*MARK);
5448 else if (*MARK == &PL_sv_undef)
5451 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5457 DIE(aTHX_ "Too many args to syscall");
5459 DIE(aTHX_ "Too few args to syscall");
5461 retval = syscall(a[0]);
5464 retval = syscall(a[0],a[1]);
5467 retval = syscall(a[0],a[1],a[2]);
5470 retval = syscall(a[0],a[1],a[2],a[3]);
5473 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5476 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5479 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5482 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5489 DIE(aTHX_ PL_no_func, "syscall");
5493 #ifdef FCNTL_EMULATE_FLOCK
5495 /* XXX Emulate flock() with fcntl().
5496 What's really needed is a good file locking module.
5500 fcntl_emulate_flock(int fd, int operation)
5505 switch (operation & ~LOCK_NB) {
5507 flock.l_type = F_RDLCK;
5510 flock.l_type = F_WRLCK;
5513 flock.l_type = F_UNLCK;
5519 flock.l_whence = SEEK_SET;
5520 flock.l_start = flock.l_len = (Off_t)0;
5522 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5523 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5524 errno = EWOULDBLOCK;
5528 #endif /* FCNTL_EMULATE_FLOCK */
5530 #ifdef LOCKF_EMULATE_FLOCK
5532 /* XXX Emulate flock() with lockf(). This is just to increase
5533 portability of scripts. The calls are not completely
5534 interchangeable. What's really needed is a good file
5538 /* The lockf() constants might have been defined in <unistd.h>.
5539 Unfortunately, <unistd.h> causes troubles on some mixed
5540 (BSD/POSIX) systems, such as SunOS 4.1.3.
5542 Further, the lockf() constants aren't POSIX, so they might not be
5543 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5544 just stick in the SVID values and be done with it. Sigh.
5548 # define F_ULOCK 0 /* Unlock a previously locked region */
5551 # define F_LOCK 1 /* Lock a region for exclusive use */
5554 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5557 # define F_TEST 3 /* Test a region for other processes locks */
5561 lockf_emulate_flock(int fd, int operation)
5567 /* flock locks entire file so for lockf we need to do the same */
5568 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5569 if (pos > 0) /* is seekable and needs to be repositioned */
5570 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5571 pos = -1; /* seek failed, so don't seek back afterwards */
5574 switch (operation) {
5576 /* LOCK_SH - get a shared lock */
5578 /* LOCK_EX - get an exclusive lock */
5580 i = lockf (fd, F_LOCK, 0);
5583 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5584 case LOCK_SH|LOCK_NB:
5585 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5586 case LOCK_EX|LOCK_NB:
5587 i = lockf (fd, F_TLOCK, 0);
5589 if ((errno == EAGAIN) || (errno == EACCES))
5590 errno = EWOULDBLOCK;
5593 /* LOCK_UN - unlock (non-blocking is a no-op) */
5595 case LOCK_UN|LOCK_NB:
5596 i = lockf (fd, F_ULOCK, 0);
5599 /* Default - can't decipher operation */
5606 if (pos > 0) /* need to restore position of the handle */
5607 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5612 #endif /* LOCKF_EMULATE_FLOCK */
5616 * c-indentation-style: bsd
5618 * indent-tabs-mode: nil
5621 * ex: set ts=8 sts=4 sw=4 et: