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;
958 /* also used for: pp_dbmclose() */
965 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
966 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
968 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
971 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
972 !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
974 if ((mg = SvTIED_mg(sv, how))) {
975 SV * const obj = SvRV(SvTIED_obj(sv, mg));
977 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
979 if (gv && isGV(gv) && (cv = GvCV(gv))) {
981 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
982 mXPUSHi(SvREFCNT(obj) - 1);
984 ENTER_with_name("call_UNTIE");
985 call_sv(MUTABLE_SV(cv), G_VOID);
986 LEAVE_with_name("call_UNTIE");
989 else if (mg && SvREFCNT(obj) > 1) {
990 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
991 "untie attempted while %"UVuf" inner references still exist",
992 (UV)SvREFCNT(obj) - 1 ) ;
996 sv_unmagic(sv, how) ;
1005 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1006 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1008 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1011 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1012 !(sv = defelem_target(sv, NULL))) goto ret_undef;
1014 if ((mg = SvTIED_mg(sv, how))) {
1015 SETs(SvTIED_obj(sv, mg));
1016 return NORMAL; /* PUTBACK not needed, pp_tied never moves SP */
1030 HV * const hv = MUTABLE_HV(POPs);
1031 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1032 stash = gv_stashsv(sv, 0);
1033 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1035 require_pv("AnyDBM_File.pm");
1037 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1038 DIE(aTHX_ "No dbm on this machine");
1048 mPUSHu(O_RDWR|O_CREAT);
1052 if (!SvOK(right)) right = &PL_sv_no;
1056 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1059 if (!sv_isobject(TOPs)) {
1067 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1071 if (sv_isobject(TOPs)) {
1072 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1073 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1090 struct timeval timebuf;
1091 struct timeval *tbuf = &timebuf;
1094 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1099 # if BYTEORDER & 0xf0000
1100 # define ORDERBYTE (0x88888888 - BYTEORDER)
1102 # define ORDERBYTE (0x4444 - BYTEORDER)
1108 for (i = 1; i <= 3; i++) {
1109 SV * const sv = SP[i];
1113 if (SvREADONLY(sv)) {
1114 if (!(SvPOK(sv) && SvCUR(sv) == 0))
1115 Perl_croak_no_modify();
1117 else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
1120 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1121 "Non-string passed as bitmask");
1122 SvPV_force_nomg_nolen(sv); /* force string conversion */
1129 /* little endians can use vecs directly */
1130 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1137 masksize = NFDBITS / NBBY;
1139 masksize = sizeof(long); /* documented int, everyone seems to use long */
1141 Zero(&fd_sets[0], 4, char*);
1144 # if SELECT_MIN_BITS == 1
1145 growsize = sizeof(fd_set);
1147 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1148 # undef SELECT_MIN_BITS
1149 # define SELECT_MIN_BITS __FD_SETSIZE
1151 /* If SELECT_MIN_BITS is greater than one we most probably will want
1152 * to align the sizes with SELECT_MIN_BITS/8 because for example
1153 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1154 * UNIX, Solaris, Darwin) the smallest quantum select() operates
1155 * on (sets/tests/clears bits) is 32 bits. */
1156 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1162 value = SvNV_nomg(sv);
1165 timebuf.tv_sec = (long)value;
1166 value -= (NV)timebuf.tv_sec;
1167 timebuf.tv_usec = (long)(value * 1000000.0);
1172 for (i = 1; i <= 3; i++) {
1174 if (!SvOK(sv) || SvCUR(sv) == 0) {
1181 Sv_Grow(sv, growsize);
1185 while (++j <= growsize) {
1189 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1191 Newx(fd_sets[i], growsize, char);
1192 for (offset = 0; offset < growsize; offset += masksize) {
1193 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1194 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1197 fd_sets[i] = SvPVX(sv);
1201 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1202 /* Can't make just the (void*) conditional because that would be
1203 * cpp #if within cpp macro, and not all compilers like that. */
1204 nfound = PerlSock_select(
1206 (Select_fd_set_t) fd_sets[1],
1207 (Select_fd_set_t) fd_sets[2],
1208 (Select_fd_set_t) fd_sets[3],
1209 (void*) tbuf); /* Workaround for compiler bug. */
1211 nfound = PerlSock_select(
1213 (Select_fd_set_t) fd_sets[1],
1214 (Select_fd_set_t) fd_sets[2],
1215 (Select_fd_set_t) fd_sets[3],
1218 for (i = 1; i <= 3; i++) {
1221 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1223 for (offset = 0; offset < growsize; offset += masksize) {
1224 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1225 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1227 Safefree(fd_sets[i]);
1234 if (GIMME == G_ARRAY && tbuf) {
1235 value = (NV)(timebuf.tv_sec) +
1236 (NV)(timebuf.tv_usec) / 1000000.0;
1241 DIE(aTHX_ "select not implemented");
1249 =for apidoc setdefout
1251 Sets PL_defoutgv, the default file handle for output, to the passed in
1252 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1253 count of the passed in typeglob is increased by one, and the reference count
1254 of the typeglob that PL_defoutgv points to is decreased by one.
1260 Perl_setdefout(pTHX_ GV *gv)
1262 PERL_ARGS_ASSERT_SETDEFOUT;
1263 SvREFCNT_inc_simple_void_NN(gv);
1264 SvREFCNT_dec(PL_defoutgv);
1272 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1273 GV * egv = GvEGVx(PL_defoutgv);
1278 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1279 gvp = hv && HvENAME(hv)
1280 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1282 if (gvp && *gvp == egv) {
1283 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1287 mXPUSHs(newRV(MUTABLE_SV(egv)));
1291 if (!GvIO(newdefout))
1292 gv_IOadd(newdefout);
1293 setdefout(newdefout);
1303 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1304 IO *const io = GvIO(gv);
1310 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1312 const U32 gimme = GIMME_V;
1313 Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1314 if (gimme == G_SCALAR) {
1316 SvSetMagicSV_nosteal(TARG, TOPs);
1321 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1322 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1324 SETERRNO(EBADF,RMS_IFI);
1328 sv_setpvs(TARG, " ");
1329 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1330 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1331 /* Find out how many bytes the char needs */
1332 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1335 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1336 SvCUR_set(TARG,1+len);
1340 else SvUTF8_off(TARG);
1346 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1349 const I32 gimme = GIMME_V;
1351 PERL_ARGS_ASSERT_DOFORM;
1354 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1359 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1360 PUSHFORMAT(cx, retop);
1361 if (CvDEPTH(cv) >= 2) {
1362 PERL_STACK_OVERFLOW_CHECK();
1363 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1366 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1368 setdefout(gv); /* locally select filehandle so $% et al work */
1386 gv = MUTABLE_GV(POPs);
1403 tmpsv = sv_newmortal();
1404 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1405 DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
1407 IoFLAGS(io) &= ~IOf_DIDTOP;
1408 RETURNOP(doform(cv,gv,PL_op->op_next));
1414 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1415 IO * const io = GvIOp(gv);
1423 if (!io || !(ofp = IoOFP(io)))
1426 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1427 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1429 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1430 PL_formtarget != PL_toptarget)
1434 if (!IoTOP_GV(io)) {
1437 if (!IoTOP_NAME(io)) {
1439 if (!IoFMT_NAME(io))
1440 IoFMT_NAME(io) = savepv(GvNAME(gv));
1441 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1442 HEKfARG(GvNAME_HEK(gv))));
1443 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1444 if ((topgv && GvFORM(topgv)) ||
1445 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1446 IoTOP_NAME(io) = savesvpv(topname);
1448 IoTOP_NAME(io) = savepvs("top");
1450 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1451 if (!topgv || !GvFORM(topgv)) {
1452 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1455 IoTOP_GV(io) = topgv;
1457 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1458 I32 lines = IoLINES_LEFT(io);
1459 const char *s = SvPVX_const(PL_formtarget);
1460 if (lines <= 0) /* Yow, header didn't even fit!!! */
1462 while (lines-- > 0) {
1463 s = strchr(s, '\n');
1469 const STRLEN save = SvCUR(PL_formtarget);
1470 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1471 do_print(PL_formtarget, ofp);
1472 SvCUR_set(PL_formtarget, save);
1473 sv_chop(PL_formtarget, s);
1474 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1477 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1478 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1479 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1481 PL_formtarget = PL_toptarget;
1482 IoFLAGS(io) |= IOf_DIDTOP;
1484 assert(fgv); /* IoTOP_GV(io) should have been set above */
1487 SV * const sv = sv_newmortal();
1488 gv_efullname4(sv, fgv, NULL, FALSE);
1489 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1491 return doform(cv, gv, PL_op);
1495 POPBLOCK(cx,PL_curpm);
1496 retop = cx->blk_sub.retop;
1498 SP = newsp; /* ignore retval of formline */
1501 if (!io || !(fp = IoOFP(io))) {
1502 if (io && IoIFP(io))
1503 report_wrongway_fh(gv, '<');
1509 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1510 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1512 if (!do_print(PL_formtarget, fp))
1515 FmLINES(PL_formtarget) = 0;
1516 SvCUR_set(PL_formtarget, 0);
1517 *SvEND(PL_formtarget) = '\0';
1518 if (IoFLAGS(io) & IOf_FLUSH)
1519 (void)PerlIO_flush(fp);
1523 PL_formtarget = PL_bodytarget;
1524 PERL_UNUSED_VAR(gimme);
1530 dSP; dMARK; dORIGMARK;
1534 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1535 IO *const io = GvIO(gv);
1537 /* Treat empty list as "" */
1538 if (MARK == SP) XPUSHs(&PL_sv_no);
1541 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1543 if (MARK == ORIGMARK) {
1546 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1549 return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1551 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1558 SETERRNO(EBADF,RMS_IFI);
1561 else if (!(fp = IoOFP(io))) {
1563 report_wrongway_fh(gv, '<');
1564 else if (ckWARN(WARN_CLOSED))
1566 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1570 SV *sv = sv_newmortal();
1571 do_sprintf(sv, SP - MARK, MARK + 1);
1572 if (!do_print(sv, fp))
1575 if (IoFLAGS(io) & IOf_FLUSH)
1576 if (PerlIO_flush(fp) == EOF)
1585 PUSHs(&PL_sv_undef);
1592 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1593 const int mode = POPi;
1594 SV * const sv = POPs;
1595 GV * const gv = MUTABLE_GV(POPs);
1598 /* Need TIEHANDLE method ? */
1599 const char * const tmps = SvPV_const(sv, len);
1600 if (do_open_raw(gv, tmps, len, mode, perm)) {
1601 IoLINES(GvIOp(gv)) = 0;
1605 PUSHs(&PL_sv_undef);
1611 /* also used for: pp_read() and pp_recv() (where supported) */
1615 dSP; dMARK; dORIGMARK; dTARGET;
1629 bool charstart = FALSE;
1630 STRLEN charskip = 0;
1632 GV * const gv = MUTABLE_GV(*++MARK);
1635 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1636 && gv && (io = GvIO(gv)) )
1638 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1640 return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1641 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1650 sv_setpvs(bufsv, "");
1651 length = SvIVx(*++MARK);
1653 DIE(aTHX_ "Negative length");
1656 offset = SvIVx(*++MARK);
1660 if (!io || !IoIFP(io)) {
1662 SETERRNO(EBADF,RMS_IFI);
1666 /* Note that fd can here validly be -1, don't check it yet. */
1667 fd = PerlIO_fileno(IoIFP(io));
1669 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1670 buffer = SvPVutf8_force(bufsv, blen);
1671 /* UTF-8 may not have been set if they are all low bytes */
1676 buffer = SvPV_force(bufsv, blen);
1677 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1679 if (DO_UTF8(bufsv)) {
1680 blen = sv_len_utf8_nomg(bufsv);
1689 if (PL_op->op_type == OP_RECV) {
1690 Sock_size_t bufsize;
1691 char namebuf[MAXPATHLEN];
1693 SETERRNO(EBADF,SS_IVCHAN);
1696 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1697 bufsize = sizeof (struct sockaddr_in);
1699 bufsize = sizeof namebuf;
1701 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1705 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1706 /* 'offset' means 'flags' here */
1707 count = PerlSock_recvfrom(fd, buffer, length, offset,
1708 (struct sockaddr *)namebuf, &bufsize);
1711 /* MSG_TRUNC can give oversized count; quietly lose it */
1714 SvCUR_set(bufsv, count);
1715 *SvEND(bufsv) = '\0';
1716 (void)SvPOK_only(bufsv);
1720 /* This should not be marked tainted if the fp is marked clean */
1721 if (!(IoFLAGS(io) & IOf_UNTAINT))
1722 SvTAINTED_on(bufsv);
1724 #if defined(__CYGWIN__)
1725 /* recvfrom() on cygwin doesn't set bufsize at all for
1726 connected sockets, leaving us with trash in the returned
1727 name, so use the same test as the Win32 code to check if it
1728 wasn't set, and set it [perl #118843] */
1729 if (bufsize == sizeof namebuf)
1732 sv_setpvn(TARG, namebuf, bufsize);
1738 if (-offset > (SSize_t)blen)
1739 DIE(aTHX_ "Offset outside string");
1742 if (DO_UTF8(bufsv)) {
1743 /* convert offset-as-chars to offset-as-bytes */
1744 if (offset >= (SSize_t)blen)
1745 offset += SvCUR(bufsv) - blen;
1747 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1751 /* Reestablish the fd in case it shifted from underneath us. */
1752 fd = PerlIO_fileno(IoIFP(io));
1754 orig_size = SvCUR(bufsv);
1755 /* Allocating length + offset + 1 isn't perfect in the case of reading
1756 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1758 (should be 2 * length + offset + 1, or possibly something longer if
1759 PL_encoding is true) */
1760 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1761 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1762 Zero(buffer+orig_size, offset-orig_size, char);
1764 buffer = buffer + offset;
1766 read_target = bufsv;
1768 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1769 concatenate it to the current buffer. */
1771 /* Truncate the existing buffer to the start of where we will be
1773 SvCUR_set(bufsv, offset);
1775 read_target = sv_newmortal();
1776 SvUPGRADE(read_target, SVt_PV);
1777 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1780 if (PL_op->op_type == OP_SYSREAD) {
1781 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1782 if (IoTYPE(io) == IoTYPE_SOCKET) {
1784 SETERRNO(EBADF,SS_IVCHAN);
1788 count = PerlSock_recv(fd, buffer, length, 0);
1794 SETERRNO(EBADF,RMS_IFI);
1798 count = PerlLIO_read(fd, buffer, length);
1803 count = PerlIO_read(IoIFP(io), buffer, length);
1804 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1805 if (count == 0 && PerlIO_error(IoIFP(io)))
1809 if (IoTYPE(io) == IoTYPE_WRONLY)
1810 report_wrongway_fh(gv, '>');
1813 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1814 *SvEND(read_target) = '\0';
1815 (void)SvPOK_only(read_target);
1816 if (fp_utf8 && !IN_BYTES) {
1817 /* Look at utf8 we got back and count the characters */
1818 const char *bend = buffer + count;
1819 while (buffer < bend) {
1821 skip = UTF8SKIP(buffer);
1824 if (buffer - charskip + skip > bend) {
1825 /* partial character - try for rest of it */
1826 length = skip - (bend-buffer);
1827 offset = bend - SvPVX_const(bufsv);
1839 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1840 provided amount read (count) was what was requested (length)
1842 if (got < wanted && count == length) {
1843 length = wanted - got;
1844 offset = bend - SvPVX_const(bufsv);
1847 /* return value is character count */
1851 else if (buffer_utf8) {
1852 /* Let svcatsv upgrade the bytes we read in to utf8.
1853 The buffer is a mortal so will be freed soon. */
1854 sv_catsv_nomg(bufsv, read_target);
1857 /* This should not be marked tainted if the fp is marked clean */
1858 if (!(IoFLAGS(io) & IOf_UNTAINT))
1859 SvTAINTED_on(bufsv);
1870 /* also used for: pp_send() where defined */
1874 dSP; dMARK; dORIGMARK; dTARGET;
1879 STRLEN orig_blen_bytes;
1880 const int op_type = PL_op->op_type;
1883 GV *const gv = MUTABLE_GV(*++MARK);
1884 IO *const io = GvIO(gv);
1887 if (op_type == OP_SYSWRITE && io) {
1888 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1890 if (MARK == SP - 1) {
1892 mXPUSHi(sv_len(sv));
1896 return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1897 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1907 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1909 if (io && IoIFP(io))
1910 report_wrongway_fh(gv, '<');
1913 SETERRNO(EBADF,RMS_IFI);
1916 fd = PerlIO_fileno(IoIFP(io));
1918 SETERRNO(EBADF,SS_IVCHAN);
1923 /* Do this first to trigger any overloading. */
1924 buffer = SvPV_const(bufsv, blen);
1925 orig_blen_bytes = blen;
1926 doing_utf8 = DO_UTF8(bufsv);
1928 if (PerlIO_isutf8(IoIFP(io))) {
1929 if (!SvUTF8(bufsv)) {
1930 /* We don't modify the original scalar. */
1931 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1932 buffer = (char *) tmpbuf;
1936 else if (doing_utf8) {
1937 STRLEN tmplen = blen;
1938 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1941 buffer = (char *) tmpbuf;
1945 assert((char *)result == buffer);
1946 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1951 if (op_type == OP_SEND) {
1952 const int flags = SvIVx(*++MARK);
1955 char * const sockbuf = SvPVx(*++MARK, mlen);
1956 retval = PerlSock_sendto(fd, buffer, blen,
1957 flags, (struct sockaddr *)sockbuf, mlen);
1960 retval = PerlSock_send(fd, buffer, blen, flags);
1966 Size_t length = 0; /* This length is in characters. */
1972 /* The SV is bytes, and we've had to upgrade it. */
1973 blen_chars = orig_blen_bytes;
1975 /* The SV really is UTF-8. */
1976 /* Don't call sv_len_utf8 on a magical or overloaded
1977 scalar, as we might get back a different result. */
1978 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
1985 length = blen_chars;
1987 #if Size_t_size > IVSIZE
1988 length = (Size_t)SvNVx(*++MARK);
1990 length = (Size_t)SvIVx(*++MARK);
1992 if ((SSize_t)length < 0) {
1994 DIE(aTHX_ "Negative length");
1999 offset = SvIVx(*++MARK);
2001 if (-offset > (IV)blen_chars) {
2003 DIE(aTHX_ "Offset outside string");
2005 offset += blen_chars;
2006 } else if (offset > (IV)blen_chars) {
2008 DIE(aTHX_ "Offset outside string");
2012 if (length > blen_chars - offset)
2013 length = blen_chars - offset;
2015 /* Here we convert length from characters to bytes. */
2016 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
2017 /* Either we had to convert the SV, or the SV is magical, or
2018 the SV has overloading, in which case we can't or mustn't
2019 or mustn't call it again. */
2021 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
2022 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
2024 /* It's a real UTF-8 SV, and it's not going to change under
2025 us. Take advantage of any cache. */
2027 I32 len_I32 = length;
2029 /* Convert the start and end character positions to bytes.
2030 Remember that the second argument to sv_pos_u2b is relative
2032 sv_pos_u2b(bufsv, &start, &len_I32);
2039 buffer = buffer+offset;
2041 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2042 if (IoTYPE(io) == IoTYPE_SOCKET) {
2043 retval = PerlSock_send(fd, buffer, length, 0);
2048 /* See the note at doio.c:do_print about filesize limits. --jhi */
2049 retval = PerlLIO_write(fd, buffer, length);
2057 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2060 #if Size_t_size > IVSIZE
2080 * in Perl 5.12 and later, the additional parameter is a bitmask:
2083 * 2 = eof() <- ARGV magic
2085 * I'll rely on the compiler's trace flow analysis to decide whether to
2086 * actually assign this out here, or punt it into the only block where it is
2087 * used. Doing it out here is DRY on the condition logic.
2092 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2098 if (PL_op->op_flags & OPf_SPECIAL) {
2099 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2103 gv = PL_last_in_gv; /* eof */
2111 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2112 return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2115 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2116 if (io && !IoIFP(io)) {
2117 if ((IoFLAGS(io) & IOf_START) && av_tindex(GvAVn(gv)) < 0) {
2119 IoFLAGS(io) &= ~IOf_START;
2120 do_open6(gv, "-", 1, NULL, NULL, 0);
2122 sv_setpvs(GvSV(gv), "-");
2124 GvSV(gv) = newSVpvs("-");
2125 SvSETMAGIC(GvSV(gv));
2127 else if (!nextargv(gv, FALSE))
2132 PUSHs(boolSV(do_eof(gv)));
2142 if (MAXARG != 0 && (TOPs || POPs))
2143 PL_last_in_gv = MUTABLE_GV(POPs);
2150 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2152 return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2157 SETERRNO(EBADF,RMS_IFI);
2162 #if LSEEKSIZE > IVSIZE
2163 PUSHn( do_tell(gv) );
2165 PUSHi( do_tell(gv) );
2171 /* also used for: pp_seek() */
2176 const int whence = POPi;
2177 #if LSEEKSIZE > IVSIZE
2178 const Off_t offset = (Off_t)SvNVx(POPs);
2180 const Off_t offset = (Off_t)SvIVx(POPs);
2183 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2184 IO *const io = GvIO(gv);
2187 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2189 #if LSEEKSIZE > IVSIZE
2190 SV *const offset_sv = newSVnv((NV) offset);
2192 SV *const offset_sv = newSViv(offset);
2195 return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2200 if (PL_op->op_type == OP_SEEK)
2201 PUSHs(boolSV(do_seek(gv, offset, whence)));
2203 const Off_t sought = do_sysseek(gv, offset, whence);
2205 PUSHs(&PL_sv_undef);
2207 SV* const sv = sought ?
2208 #if LSEEKSIZE > IVSIZE
2213 : newSVpvn(zero_but_true, ZBTLEN);
2223 /* There seems to be no consensus on the length type of truncate()
2224 * and ftruncate(), both off_t and size_t have supporters. In
2225 * general one would think that when using large files, off_t is
2226 * at least as wide as size_t, so using an off_t should be okay. */
2227 /* XXX Configure probe for the length type of *truncate() needed XXX */
2230 #if Off_t_size > IVSIZE
2235 /* Checking for length < 0 is problematic as the type might or
2236 * might not be signed: if it is not, clever compilers will moan. */
2237 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2240 SV * const sv = POPs;
2245 if (PL_op->op_flags & OPf_SPECIAL
2246 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2247 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2254 TAINT_PROPER("truncate");
2255 if (!(fp = IoIFP(io))) {
2259 int fd = PerlIO_fileno(fp);
2261 SETERRNO(EBADF,RMS_IFI);
2266 if (ftruncate(fd, len) < 0)
2268 if (my_chsize(fd, len) < 0)
2275 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2276 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2277 goto do_ftruncate_io;
2280 const char * const name = SvPV_nomg_const_nolen(sv);
2281 TAINT_PROPER("truncate");
2283 if (truncate(name, len) < 0)
2287 const int tmpfd = PerlLIO_open(name, O_RDWR);
2290 SETERRNO(EBADF,RMS_IFI);
2293 if (my_chsize(tmpfd, len) < 0)
2295 PerlLIO_close(tmpfd);
2304 SETERRNO(EBADF,RMS_IFI);
2310 /* also used for: pp_fcntl() */
2315 SV * const argsv = POPs;
2316 const unsigned int func = POPu;
2318 GV * const gv = MUTABLE_GV(POPs);
2319 IO * const io = GvIOn(gv);
2325 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2329 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2332 s = SvPV_force(argsv, len);
2333 need = IOCPARM_LEN(func);
2335 s = Sv_Grow(argsv, need + 1);
2336 SvCUR_set(argsv, need);
2339 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2342 retval = SvIV(argsv);
2343 s = INT2PTR(char*,retval); /* ouch */
2346 optype = PL_op->op_type;
2347 TAINT_PROPER(PL_op_desc[optype]);
2349 if (optype == OP_IOCTL)
2351 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2353 DIE(aTHX_ "ioctl is not implemented");
2357 DIE(aTHX_ "fcntl is not implemented");
2359 #if defined(OS2) && defined(__EMX__)
2360 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2362 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2366 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2368 if (s[SvCUR(argsv)] != 17)
2369 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2371 s[SvCUR(argsv)] = 0; /* put our null back */
2372 SvSETMAGIC(argsv); /* Assume it has changed */
2381 PUSHp(zero_but_true, ZBTLEN);
2392 const int argtype = POPi;
2393 GV * const gv = MUTABLE_GV(POPs);
2394 IO *const io = GvIO(gv);
2395 PerlIO *const fp = io ? IoIFP(io) : NULL;
2397 /* XXX Looks to me like io is always NULL at this point */
2399 (void)PerlIO_flush(fp);
2400 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2405 SETERRNO(EBADF,RMS_IFI);
2410 DIE(aTHX_ PL_no_func, "flock");
2421 const int protocol = POPi;
2422 const int type = POPi;
2423 const int domain = POPi;
2424 GV * const gv = MUTABLE_GV(POPs);
2425 IO * const io = GvIOn(gv);
2429 do_close(gv, FALSE);
2431 TAINT_PROPER("socket");
2432 fd = PerlSock_socket(domain, type, protocol);
2434 SETERRNO(EBADF,RMS_IFI);
2437 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2438 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2439 IoTYPE(io) = IoTYPE_SOCKET;
2440 if (!IoIFP(io) || !IoOFP(io)) {
2441 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2442 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2443 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2446 #if defined(HAS_FCNTL) && defined(F_SETFD)
2447 if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) /* ensure close-on-exec */
2457 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2460 const int protocol = POPi;
2461 const int type = POPi;
2462 const int domain = POPi;
2464 GV * const gv2 = MUTABLE_GV(POPs);
2465 IO * const io2 = GvIOn(gv2);
2466 GV * const gv1 = MUTABLE_GV(POPs);
2467 IO * const io1 = GvIOn(gv1);
2470 do_close(gv1, FALSE);
2472 do_close(gv2, FALSE);
2474 TAINT_PROPER("socketpair");
2475 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2477 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2478 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2479 IoTYPE(io1) = IoTYPE_SOCKET;
2480 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2481 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2482 IoTYPE(io2) = IoTYPE_SOCKET;
2483 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2484 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2485 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2486 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2487 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2488 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2489 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2492 #if defined(HAS_FCNTL) && defined(F_SETFD)
2493 /* ensure close-on-exec */
2494 if ((fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
2495 (fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd) < 0))
2501 DIE(aTHX_ PL_no_sock_func, "socketpair");
2507 /* also used for: pp_connect() */
2512 SV * const addrsv = POPs;
2513 /* OK, so on what platform does bind modify addr? */
2515 GV * const gv = MUTABLE_GV(POPs);
2516 IO * const io = GvIOn(gv);
2523 fd = PerlIO_fileno(IoIFP(io));
2527 addr = SvPV_const(addrsv, len);
2528 op_type = PL_op->op_type;
2529 TAINT_PROPER(PL_op_desc[op_type]);
2530 if ((op_type == OP_BIND
2531 ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
2532 : PerlSock_connect(fd, (struct sockaddr *)addr, len))
2540 SETERRNO(EBADF,SS_IVCHAN);
2547 const int backlog = POPi;
2548 GV * const gv = MUTABLE_GV(POPs);
2549 IO * const io = GvIOn(gv);
2554 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2561 SETERRNO(EBADF,SS_IVCHAN);
2569 char namebuf[MAXPATHLEN];
2570 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2571 Sock_size_t len = sizeof (struct sockaddr_in);
2573 Sock_size_t len = sizeof namebuf;
2575 GV * const ggv = MUTABLE_GV(POPs);
2576 GV * const ngv = MUTABLE_GV(POPs);
2579 IO * const gstio = GvIO(ggv);
2580 if (!gstio || !IoIFP(gstio))
2584 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2587 /* Some platforms indicate zero length when an AF_UNIX client is
2588 * not bound. Simulate a non-zero-length sockaddr structure in
2590 namebuf[0] = 0; /* sun_len */
2591 namebuf[1] = AF_UNIX; /* sun_family */
2599 do_close(ngv, FALSE);
2600 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2601 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2602 IoTYPE(nstio) = IoTYPE_SOCKET;
2603 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2604 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2605 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2606 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2609 #if defined(HAS_FCNTL) && defined(F_SETFD)
2610 if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) /* ensure close-on-exec */
2614 #ifdef __SCO_VERSION__
2615 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2618 PUSHp(namebuf, len);
2622 report_evil_fh(ggv);
2623 SETERRNO(EBADF,SS_IVCHAN);
2633 const int how = POPi;
2634 GV * const gv = MUTABLE_GV(POPs);
2635 IO * const io = GvIOn(gv);
2640 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2645 SETERRNO(EBADF,SS_IVCHAN);
2650 /* also used for: pp_gsockopt() */
2655 const int optype = PL_op->op_type;
2656 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2657 const unsigned int optname = (unsigned int) POPi;
2658 const unsigned int lvl = (unsigned int) POPi;
2659 GV * const gv = MUTABLE_GV(POPs);
2660 IO * const io = GvIOn(gv);
2667 fd = PerlIO_fileno(IoIFP(io));
2673 (void)SvPOK_only(sv);
2677 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2680 /* XXX Configure test: does getsockopt set the length properly? */
2689 #if defined(__SYMBIAN32__)
2690 # define SETSOCKOPT_OPTION_VALUE_T void *
2692 # define SETSOCKOPT_OPTION_VALUE_T const char *
2694 /* XXX TODO: We need to have a proper type (a Configure probe,
2695 * etc.) for what the C headers think of the third argument of
2696 * setsockopt(), the option_value read-only buffer: is it
2697 * a "char *", or a "void *", const or not. Some compilers
2698 * don't take kindly to e.g. assuming that "char *" implicitly
2699 * promotes to a "void *", or to explicitly promoting/demoting
2700 * consts to non/vice versa. The "const void *" is the SUS
2701 * definition, but that does not fly everywhere for the above
2703 SETSOCKOPT_OPTION_VALUE_T buf;
2707 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2711 aint = (int)SvIV(sv);
2712 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2715 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2725 SETERRNO(EBADF,SS_IVCHAN);
2732 /* also used for: pp_getsockname() */
2737 const int optype = PL_op->op_type;
2738 GV * const gv = MUTABLE_GV(POPs);
2739 IO * const io = GvIOn(gv);
2747 sv = sv_2mortal(newSV(257));
2748 (void)SvPOK_only(sv);
2752 fd = PerlIO_fileno(IoIFP(io));
2756 case OP_GETSOCKNAME:
2757 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2760 case OP_GETPEERNAME:
2761 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2763 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2765 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";
2766 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2767 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2768 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2769 sizeof(u_short) + sizeof(struct in_addr))) {
2776 #ifdef BOGUS_GETNAME_RETURN
2777 /* Interactive Unix, getpeername() and getsockname()
2778 does not return valid namelen */
2779 if (len == BOGUS_GETNAME_RETURN)
2780 len = sizeof(struct sockaddr);
2789 SETERRNO(EBADF,SS_IVCHAN);
2798 /* also used for: pp_lstat() */
2809 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2810 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2811 if (PL_op->op_type == OP_LSTAT) {
2812 if (gv != PL_defgv) {
2813 do_fstat_warning_check:
2814 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2815 "lstat() on filehandle%s%"SVf,
2818 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2820 } else if (PL_laststype != OP_LSTAT)
2821 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2822 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2825 if (gv != PL_defgv) {
2829 PL_laststype = OP_STAT;
2830 PL_statgv = gv ? gv : (GV *)io;
2831 sv_setpvs(PL_statname, "");
2837 int fd = PerlIO_fileno(IoIFP(io));
2839 PL_laststatval = -1;
2840 SETERRNO(EBADF,RMS_IFI);
2842 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
2845 } else if (IoDIRP(io)) {
2847 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2850 PL_laststatval = -1;
2853 else PL_laststatval = -1;
2854 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2857 if (PL_laststatval < 0) {
2863 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2864 io = MUTABLE_IO(SvRV(sv));
2865 if (PL_op->op_type == OP_LSTAT)
2866 goto do_fstat_warning_check;
2867 goto do_fstat_have_io;
2870 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2871 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2873 PL_laststype = PL_op->op_type;
2874 file = SvPV_nolen_const(PL_statname);
2875 if (PL_op->op_type == OP_LSTAT)
2876 PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
2878 PL_laststatval = PerlLIO_stat(file, &PL_statcache);
2879 if (PL_laststatval < 0) {
2880 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
2881 /* PL_warn_nl is constant */
2882 GCC_DIAG_IGNORE(-Wformat-nonliteral);
2883 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2891 if (gimme != G_ARRAY) {
2892 if (gimme != G_VOID)
2893 XPUSHs(boolSV(max));
2899 mPUSHi(PL_statcache.st_dev);
2900 #if ST_INO_SIZE > IVSIZE
2901 mPUSHn(PL_statcache.st_ino);
2903 # if ST_INO_SIGN <= 0
2904 mPUSHi(PL_statcache.st_ino);
2906 mPUSHu(PL_statcache.st_ino);
2909 mPUSHu(PL_statcache.st_mode);
2910 mPUSHu(PL_statcache.st_nlink);
2912 sv_setuid(PUSHmortal, PL_statcache.st_uid);
2913 sv_setgid(PUSHmortal, PL_statcache.st_gid);
2915 #ifdef USE_STAT_RDEV
2916 mPUSHi(PL_statcache.st_rdev);
2918 PUSHs(newSVpvs_flags("", SVs_TEMP));
2920 #if Off_t_size > IVSIZE
2921 mPUSHn(PL_statcache.st_size);
2923 mPUSHi(PL_statcache.st_size);
2926 mPUSHn(PL_statcache.st_atime);
2927 mPUSHn(PL_statcache.st_mtime);
2928 mPUSHn(PL_statcache.st_ctime);
2930 mPUSHi(PL_statcache.st_atime);
2931 mPUSHi(PL_statcache.st_mtime);
2932 mPUSHi(PL_statcache.st_ctime);
2934 #ifdef USE_STAT_BLOCKS
2935 mPUSHu(PL_statcache.st_blksize);
2936 mPUSHu(PL_statcache.st_blocks);
2938 PUSHs(newSVpvs_flags("", SVs_TEMP));
2939 PUSHs(newSVpvs_flags("", SVs_TEMP));
2945 /* All filetest ops avoid manipulating the perl stack pointer in their main
2946 bodies (since commit d2c4d2d1e22d3125), and return using either
2947 S_ft_return_false() or S_ft_return_true(). These two helper functions are
2948 the only two which manipulate the perl stack. To ensure that no stack
2949 manipulation macros are used, the filetest ops avoid defining a local copy
2950 of the stack pointer with dSP. */
2952 /* If the next filetest is stacked up with this one
2953 (PL_op->op_private & OPpFT_STACKING), we leave
2954 the original argument on the stack for success,
2955 and skip the stacked operators on failure.
2956 The next few macros/functions take care of this.
2960 S_ft_return_false(pTHX_ SV *ret) {
2964 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
2968 if (PL_op->op_private & OPpFT_STACKING) {
2969 while (OP_IS_FILETEST(next->op_type)
2970 && next->op_private & OPpFT_STACKED)
2971 next = next->op_next;
2976 PERL_STATIC_INLINE OP *
2977 S_ft_return_true(pTHX_ SV *ret) {
2979 if (PL_op->op_flags & OPf_REF)
2980 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
2981 else if (!(PL_op->op_private & OPpFT_STACKING))
2987 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
2988 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
2989 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
2991 #define tryAMAGICftest_MG(chr) STMT_START { \
2992 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
2993 && PL_op->op_flags & OPf_KIDS) { \
2994 OP *next = S_try_amagic_ftest(aTHX_ chr); \
2995 if (next) return next; \
3000 S_try_amagic_ftest(pTHX_ char chr) {
3001 SV *const arg = *PL_stack_sp;
3004 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
3008 const char tmpchr = chr;
3009 SV * const tmpsv = amagic_call(arg,
3010 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
3011 ftest_amg, AMGf_unary);
3016 return SvTRUE(tmpsv)
3017 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
3023 /* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec()
3029 /* Not const, because things tweak this below. Not bool, because there's
3030 no guarantee that OPpFT_ACCESS is <= CHAR_MAX */
3031 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3032 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3033 /* Giving some sort of initial value silences compilers. */
3035 int access_mode = R_OK;
3037 int access_mode = 0;
3040 /* access_mode is never used, but leaving use_access in makes the
3041 conditional compiling below much clearer. */
3044 Mode_t stat_mode = S_IRUSR;
3046 bool effective = FALSE;
3049 switch (PL_op->op_type) {
3050 case OP_FTRREAD: opchar = 'R'; break;
3051 case OP_FTRWRITE: opchar = 'W'; break;
3052 case OP_FTREXEC: opchar = 'X'; break;
3053 case OP_FTEREAD: opchar = 'r'; break;
3054 case OP_FTEWRITE: opchar = 'w'; break;
3055 case OP_FTEEXEC: opchar = 'x'; break;
3057 tryAMAGICftest_MG(opchar);
3059 switch (PL_op->op_type) {
3061 #if !(defined(HAS_ACCESS) && defined(R_OK))
3067 #if defined(HAS_ACCESS) && defined(W_OK)
3072 stat_mode = S_IWUSR;
3076 #if defined(HAS_ACCESS) && defined(X_OK)
3081 stat_mode = S_IXUSR;
3085 #ifdef PERL_EFF_ACCESS
3088 stat_mode = S_IWUSR;
3092 #ifndef PERL_EFF_ACCESS
3099 #ifdef PERL_EFF_ACCESS
3104 stat_mode = S_IXUSR;
3110 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3111 const char *name = SvPV_nolen(*PL_stack_sp);
3113 # ifdef PERL_EFF_ACCESS
3114 result = PERL_EFF_ACCESS(name, access_mode);
3116 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3122 result = access(name, access_mode);
3124 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3135 result = my_stat_flags(0);
3138 if (cando(stat_mode, effective, &PL_statcache))
3144 /* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */
3149 const int op_type = PL_op->op_type;
3153 case OP_FTIS: opchar = 'e'; break;
3154 case OP_FTSIZE: opchar = 's'; break;
3155 case OP_FTMTIME: opchar = 'M'; break;
3156 case OP_FTCTIME: opchar = 'C'; break;
3157 case OP_FTATIME: opchar = 'A'; break;
3159 tryAMAGICftest_MG(opchar);
3161 result = my_stat_flags(0);
3164 if (op_type == OP_FTIS)
3167 /* You can't dTARGET inside OP_FTIS, because you'll get
3168 "panic: pad_sv po" - the op is not flagged to have a target. */
3172 #if Off_t_size > IVSIZE
3173 sv_setnv(TARG, (NV)PL_statcache.st_size);
3175 sv_setiv(TARG, (IV)PL_statcache.st_size);
3180 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3184 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3188 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3192 return SvTRUE_nomg(TARG)
3193 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3198 /* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned()
3199 * pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock()
3200 * pp_ftsuid() pp_ftsvtx() pp_ftzero() */
3207 switch (PL_op->op_type) {
3208 case OP_FTROWNED: opchar = 'O'; break;
3209 case OP_FTEOWNED: opchar = 'o'; break;
3210 case OP_FTZERO: opchar = 'z'; break;
3211 case OP_FTSOCK: opchar = 'S'; break;
3212 case OP_FTCHR: opchar = 'c'; break;
3213 case OP_FTBLK: opchar = 'b'; break;
3214 case OP_FTFILE: opchar = 'f'; break;
3215 case OP_FTDIR: opchar = 'd'; break;
3216 case OP_FTPIPE: opchar = 'p'; break;
3217 case OP_FTSUID: opchar = 'u'; break;
3218 case OP_FTSGID: opchar = 'g'; break;
3219 case OP_FTSVTX: opchar = 'k'; break;
3221 tryAMAGICftest_MG(opchar);
3223 /* I believe that all these three are likely to be defined on most every
3224 system these days. */
3226 if(PL_op->op_type == OP_FTSUID) {
3231 if(PL_op->op_type == OP_FTSGID) {
3236 if(PL_op->op_type == OP_FTSVTX) {
3241 result = my_stat_flags(0);
3244 switch (PL_op->op_type) {
3246 if (PL_statcache.st_uid == PerlProc_getuid())
3250 if (PL_statcache.st_uid == PerlProc_geteuid())
3254 if (PL_statcache.st_size == 0)
3258 if (S_ISSOCK(PL_statcache.st_mode))
3262 if (S_ISCHR(PL_statcache.st_mode))
3266 if (S_ISBLK(PL_statcache.st_mode))
3270 if (S_ISREG(PL_statcache.st_mode))
3274 if (S_ISDIR(PL_statcache.st_mode))
3278 if (S_ISFIFO(PL_statcache.st_mode))
3283 if (PL_statcache.st_mode & S_ISUID)
3289 if (PL_statcache.st_mode & S_ISGID)
3295 if (PL_statcache.st_mode & S_ISVTX)
3307 tryAMAGICftest_MG('l');
3308 result = my_lstat_flags(0);
3312 if (S_ISLNK(PL_statcache.st_mode))
3324 tryAMAGICftest_MG('t');
3326 if (PL_op->op_flags & OPf_REF)
3329 SV *tmpsv = *PL_stack_sp;
3330 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3331 name = SvPV_nomg(tmpsv, namelen);
3332 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3336 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3337 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3338 else if (name && isDIGIT(*name))
3339 fd = grok_atou(name, NULL);
3343 SETERRNO(EBADF,RMS_IFI);
3346 if (PerlLIO_isatty(fd))
3352 /* also used for: pp_ftbinary() */
3366 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3368 if (PL_op->op_flags & OPf_REF)
3370 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3375 gv = MAYBE_DEREF_GV_nomg(sv);
3379 if (gv == PL_defgv) {
3381 io = SvTYPE(PL_statgv) == SVt_PVIO
3385 goto really_filename;
3390 sv_setpvs(PL_statname, "");
3391 io = GvIO(PL_statgv);
3393 PL_laststatval = -1;
3394 PL_laststype = OP_STAT;
3395 if (io && IoIFP(io)) {
3397 if (! PerlIO_has_base(IoIFP(io)))
3398 DIE(aTHX_ "-T and -B not implemented on filehandles");
3399 fd = PerlIO_fileno(IoIFP(io));
3401 SETERRNO(EBADF,RMS_IFI);
3404 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3405 if (PL_laststatval < 0)
3407 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3408 if (PL_op->op_type == OP_FTTEXT)
3413 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3414 i = PerlIO_getc(IoIFP(io));
3416 (void)PerlIO_ungetc(IoIFP(io),i);
3418 /* null file is anything */
3421 len = PerlIO_get_bufsiz(IoIFP(io));
3422 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3423 /* sfio can have large buffers - limit to 512 */
3428 SETERRNO(EBADF,RMS_IFI);
3430 SETERRNO(EBADF,RMS_IFI);
3439 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3441 file = SvPVX_const(PL_statname);
3443 if (!(fp = PerlIO_open(file, "r"))) {
3445 PL_laststatval = -1;
3446 PL_laststype = OP_STAT;
3448 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
3449 /* PL_warn_nl is constant */
3450 GCC_DIAG_IGNORE(-Wformat-nonliteral);
3451 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3456 PL_laststype = OP_STAT;
3457 fd = PerlIO_fileno(fp);
3459 (void)PerlIO_close(fp);
3460 SETERRNO(EBADF,RMS_IFI);
3463 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3464 if (PL_laststatval < 0) {
3465 (void)PerlIO_close(fp);
3466 SETERRNO(EBADF,RMS_IFI);
3469 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3470 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3471 (void)PerlIO_close(fp);
3473 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3474 FT_RETURNNO; /* special case NFS directories */
3475 FT_RETURNYES; /* null file is anything */
3480 /* now scan s to look for textiness */
3482 #if defined(DOSISH) || defined(USEMYBINMODE)
3483 /* ignore trailing ^Z on short files */
3484 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3489 if (! is_ascii_string((U8 *) s, len)) {
3492 /* Here contains a non-ASCII. See if the entire string is UTF-8. But
3493 * the buffer may end in a partial character, so consider it UTF-8 if
3494 * the first non-UTF8 char is an ending partial */
3495 if (is_utf8_string_loc((U8 *) s, len, &ep)
3496 || ep + UTF8SKIP(ep) > (U8 *) (s + len))
3498 if (PL_op->op_type == OP_FTTEXT) {
3507 /* Here, is not UTF-8 or is entirely ASCII. Look through the buffer for
3508 * things that wouldn't be in ASCII text or rich ASCII text. Count these
3510 for (i = 0; i < len; i++, s++) {
3511 if (!*s) { /* null never allowed in text */
3515 #ifdef USE_LOCALE_CTYPE
3516 if (IN_LC_RUNTIME(LC_CTYPE)) {
3517 if ( isPRINT_LC(*s) || isSPACE_LC(*s)) {
3524 /* VT occurs so rarely in text, that we consider it odd */
3525 || (isSPACE_A(*s) && *s != VT_NATIVE)
3527 /* But there is a fair amount of backspaces and escapes in
3530 || *s == ESC_NATIVE)
3537 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3548 const char *tmps = NULL;
3552 SV * const sv = POPs;
3553 if (PL_op->op_flags & OPf_SPECIAL) {
3554 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3556 else if (!(gv = MAYBE_DEREF_GV(sv)))
3557 tmps = SvPV_nomg_const_nolen(sv);
3560 if( !gv && (!tmps || !*tmps) ) {
3561 HV * const table = GvHVn(PL_envgv);
3564 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3565 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3567 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3572 deprecate("chdir('') or chdir(undef) as chdir()");
3573 tmps = SvPV_nolen_const(*svp);
3577 TAINT_PROPER("chdir");
3582 TAINT_PROPER("chdir");
3585 IO* const io = GvIO(gv);
3588 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3589 } else if (IoIFP(io)) {
3590 int fd = PerlIO_fileno(IoIFP(io));
3594 PUSHi(fchdir(fd) >= 0);
3604 DIE(aTHX_ PL_no_func, "fchdir");
3608 PUSHi( PerlDir_chdir(tmps) >= 0 );
3610 /* Clear the DEFAULT element of ENV so we'll get the new value
3612 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3618 SETERRNO(EBADF,RMS_IFI);
3624 /* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */
3628 dSP; dMARK; dTARGET;
3629 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3640 char * const tmps = POPpx;
3641 TAINT_PROPER("chroot");
3642 PUSHi( chroot(tmps) >= 0 );
3645 DIE(aTHX_ PL_no_func, "chroot");
3653 const char * const tmps2 = POPpconstx;
3654 const char * const tmps = SvPV_nolen_const(TOPs);
3655 TAINT_PROPER("rename");
3657 anum = PerlLIO_rename(tmps, tmps2);
3659 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3660 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3663 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3664 (void)UNLINK(tmps2);
3665 if (!(anum = link(tmps, tmps2)))
3666 anum = UNLINK(tmps);
3675 /* also used for: pp_symlink() */
3677 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3681 const int op_type = PL_op->op_type;
3685 if (op_type == OP_LINK)
3686 DIE(aTHX_ PL_no_func, "link");
3688 # ifndef HAS_SYMLINK
3689 if (op_type == OP_SYMLINK)
3690 DIE(aTHX_ PL_no_func, "symlink");
3694 const char * const tmps2 = POPpconstx;
3695 const char * const tmps = SvPV_nolen_const(TOPs);
3696 TAINT_PROPER(PL_op_desc[op_type]);
3698 # if defined(HAS_LINK)
3699 # if defined(HAS_SYMLINK)
3700 /* Both present - need to choose which. */
3701 (op_type == OP_LINK) ?
3702 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3704 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3705 PerlLIO_link(tmps, tmps2);
3708 # if defined(HAS_SYMLINK)
3709 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3710 symlink(tmps, tmps2);
3715 SETi( result >= 0 );
3720 /* also used for: pp_symlink() */
3725 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3735 char buf[MAXPATHLEN];
3740 /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
3741 * it is impossible to know whether the result was truncated. */
3742 len = readlink(tmps, buf, sizeof(buf) - 1);
3751 RETSETUNDEF; /* just pretend it's a normal file */
3755 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3757 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3759 char * const save_filename = filename;
3764 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3766 PERL_ARGS_ASSERT_DOONELINER;
3768 Newx(cmdline, size, char);
3769 my_strlcpy(cmdline, cmd, size);
3770 my_strlcat(cmdline, " ", size);
3771 for (s = cmdline + strlen(cmdline); *filename; ) {
3775 if (s - cmdline < size)
3776 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3777 myfp = PerlProc_popen(cmdline, "r");
3781 SV * const tmpsv = sv_newmortal();
3782 /* Need to save/restore 'PL_rs' ?? */
3783 s = sv_gets(tmpsv, myfp, 0);
3784 (void)PerlProc_pclose(myfp);
3788 #ifdef HAS_SYS_ERRLIST
3793 /* you don't see this */
3794 const char * const errmsg = Strerror(e) ;
3797 if (instr(s, errmsg)) {
3804 #define EACCES EPERM
3806 if (instr(s, "cannot make"))
3807 SETERRNO(EEXIST,RMS_FEX);
3808 else if (instr(s, "existing file"))
3809 SETERRNO(EEXIST,RMS_FEX);
3810 else if (instr(s, "ile exists"))
3811 SETERRNO(EEXIST,RMS_FEX);
3812 else if (instr(s, "non-exist"))
3813 SETERRNO(ENOENT,RMS_FNF);
3814 else if (instr(s, "does not exist"))
3815 SETERRNO(ENOENT,RMS_FNF);
3816 else if (instr(s, "not empty"))
3817 SETERRNO(EBUSY,SS_DEVOFFLINE);
3818 else if (instr(s, "cannot access"))
3819 SETERRNO(EACCES,RMS_PRV);
3821 SETERRNO(EPERM,RMS_PRV);
3824 else { /* some mkdirs return no failure indication */
3825 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3826 if (PL_op->op_type == OP_RMDIR)
3831 SETERRNO(EACCES,RMS_PRV); /* a guess */
3840 /* This macro removes trailing slashes from a directory name.
3841 * Different operating and file systems take differently to
3842 * trailing slashes. According to POSIX 1003.1 1996 Edition
3843 * any number of trailing slashes should be allowed.
3844 * Thusly we snip them away so that even non-conforming
3845 * systems are happy.
3846 * We should probably do this "filtering" for all
3847 * the functions that expect (potentially) directory names:
3848 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3849 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3851 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3852 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3855 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3856 (tmps) = savepvn((tmps), (len)); \
3866 const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3868 TRIMSLASHES(tmps,len,copy);
3870 TAINT_PROPER("mkdir");
3872 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3876 SETi( dooneliner("mkdir", tmps) );
3877 oldumask = PerlLIO_umask(0);
3878 PerlLIO_umask(oldumask);
3879 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3894 TRIMSLASHES(tmps,len,copy);
3895 TAINT_PROPER("rmdir");
3897 SETi( PerlDir_rmdir(tmps) >= 0 );
3899 SETi( dooneliner("rmdir", tmps) );
3906 /* Directory calls. */
3910 #if defined(Direntry_t) && defined(HAS_READDIR)
3912 const char * const dirname = POPpconstx;
3913 GV * const gv = MUTABLE_GV(POPs);
3914 IO * const io = GvIOn(gv);
3916 if ((IoIFP(io) || IoOFP(io)))
3917 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3918 "Opening filehandle %"HEKf" also as a directory",
3919 HEKfARG(GvENAME_HEK(gv)) );
3921 PerlDir_close(IoDIRP(io));
3922 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3928 SETERRNO(EBADF,RMS_DIR);
3931 DIE(aTHX_ PL_no_dir_func, "opendir");
3937 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3938 DIE(aTHX_ PL_no_dir_func, "readdir");
3940 #if !defined(I_DIRENT) && !defined(VMS)
3941 Direntry_t *readdir (DIR *);
3946 const I32 gimme = GIMME;
3947 GV * const gv = MUTABLE_GV(POPs);
3948 const Direntry_t *dp;
3949 IO * const io = GvIOn(gv);
3952 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3953 "readdir() attempted on invalid dirhandle %"HEKf,
3954 HEKfARG(GvENAME_HEK(gv)));
3959 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3963 sv = newSVpvn(dp->d_name, dp->d_namlen);
3965 sv = newSVpv(dp->d_name, 0);
3967 if (!(IoFLAGS(io) & IOf_UNTAINT))
3970 } while (gimme == G_ARRAY);
3972 if (!dp && gimme != G_ARRAY)
3979 SETERRNO(EBADF,RMS_ISI);
3980 if (GIMME == G_ARRAY)
3989 #if defined(HAS_TELLDIR) || defined(telldir)
3991 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3992 /* XXX netbsd still seemed to.
3993 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3994 --JHI 1999-Feb-02 */
3995 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3996 long telldir (DIR *);
3998 GV * const gv = MUTABLE_GV(POPs);
3999 IO * const io = GvIOn(gv);
4002 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4003 "telldir() attempted on invalid dirhandle %"HEKf,
4004 HEKfARG(GvENAME_HEK(gv)));
4008 PUSHi( PerlDir_tell(IoDIRP(io)) );
4012 SETERRNO(EBADF,RMS_ISI);
4015 DIE(aTHX_ PL_no_dir_func, "telldir");
4021 #if defined(HAS_SEEKDIR) || defined(seekdir)
4023 const long along = POPl;
4024 GV * const gv = MUTABLE_GV(POPs);
4025 IO * const io = GvIOn(gv);
4028 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4029 "seekdir() attempted on invalid dirhandle %"HEKf,
4030 HEKfARG(GvENAME_HEK(gv)));
4033 (void)PerlDir_seek(IoDIRP(io), along);
4038 SETERRNO(EBADF,RMS_ISI);
4041 DIE(aTHX_ PL_no_dir_func, "seekdir");
4047 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4049 GV * const gv = MUTABLE_GV(POPs);
4050 IO * const io = GvIOn(gv);
4053 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4054 "rewinddir() attempted on invalid dirhandle %"HEKf,
4055 HEKfARG(GvENAME_HEK(gv)));
4058 (void)PerlDir_rewind(IoDIRP(io));
4062 SETERRNO(EBADF,RMS_ISI);
4065 DIE(aTHX_ PL_no_dir_func, "rewinddir");
4071 #if defined(Direntry_t) && defined(HAS_READDIR)
4073 GV * const gv = MUTABLE_GV(POPs);
4074 IO * const io = GvIOn(gv);
4077 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4078 "closedir() attempted on invalid dirhandle %"HEKf,
4079 HEKfARG(GvENAME_HEK(gv)));
4082 #ifdef VOID_CLOSEDIR
4083 PerlDir_close(IoDIRP(io));
4085 if (PerlDir_close(IoDIRP(io)) < 0) {
4086 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4095 SETERRNO(EBADF,RMS_IFI);
4098 DIE(aTHX_ PL_no_dir_func, "closedir");
4102 /* Process control. */
4109 #ifdef HAS_SIGPROCMASK
4110 sigset_t oldmask, newmask;
4114 PERL_FLUSHALL_FOR_CHILD;
4115 #ifdef HAS_SIGPROCMASK
4116 sigfillset(&newmask);
4117 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4119 childpid = PerlProc_fork();
4120 if (childpid == 0) {
4124 for (sig = 1; sig < SIG_SIZE; sig++)
4125 PL_psig_pend[sig] = 0;
4127 #ifdef HAS_SIGPROCMASK
4130 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4137 #ifdef PERL_USES_PL_PIDSTATUS
4138 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4144 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4149 PERL_FLUSHALL_FOR_CHILD;
4150 childpid = PerlProc_fork();
4156 DIE(aTHX_ PL_no_func, "fork");
4163 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4168 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4169 childpid = wait4pid(-1, &argflags, 0);
4171 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4176 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4177 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4178 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4180 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4185 DIE(aTHX_ PL_no_func, "wait");
4191 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4193 const int optype = POPi;
4194 const Pid_t pid = TOPi;
4198 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4199 result = wait4pid(pid, &argflags, optype);
4201 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4206 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4207 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4208 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4210 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4215 DIE(aTHX_ PL_no_func, "waitpid");
4221 dSP; dMARK; dORIGMARK; dTARGET;
4222 #if defined(__LIBCATAMOUNT__)
4223 PL_statusvalue = -1;
4232 while (++MARK <= SP) {
4233 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4238 TAINT_PROPER("system");
4240 PERL_FLUSHALL_FOR_CHILD;
4241 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4246 #ifdef HAS_SIGPROCMASK
4247 sigset_t newset, oldset;
4250 if (PerlProc_pipe(pp) >= 0)
4252 #ifdef HAS_SIGPROCMASK
4253 sigemptyset(&newset);
4254 sigaddset(&newset, SIGCHLD);
4255 sigprocmask(SIG_BLOCK, &newset, &oldset);
4257 while ((childpid = PerlProc_fork()) == -1) {
4258 if (errno != EAGAIN) {
4263 PerlLIO_close(pp[0]);
4264 PerlLIO_close(pp[1]);
4266 #ifdef HAS_SIGPROCMASK
4267 sigprocmask(SIG_SETMASK, &oldset, NULL);
4274 Sigsave_t ihand,qhand; /* place to save signals during system() */
4278 PerlLIO_close(pp[1]);
4280 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4281 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4284 result = wait4pid(childpid, &status, 0);
4285 } while (result == -1 && errno == EINTR);
4287 #ifdef HAS_SIGPROCMASK
4288 sigprocmask(SIG_SETMASK, &oldset, NULL);
4290 (void)rsignal_restore(SIGINT, &ihand);
4291 (void)rsignal_restore(SIGQUIT, &qhand);
4293 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4294 do_execfree(); /* free any memory child malloced on fork */
4301 while (n < sizeof(int)) {
4302 n1 = PerlLIO_read(pp[0],
4303 (void*)(((char*)&errkid)+n),
4309 PerlLIO_close(pp[0]);
4310 if (n) { /* Error */
4311 if (n != sizeof(int))
4312 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4313 errno = errkid; /* Propagate errno from kid */
4314 STATUS_NATIVE_CHILD_SET(-1);
4317 XPUSHi(STATUS_CURRENT);
4320 #ifdef HAS_SIGPROCMASK
4321 sigprocmask(SIG_SETMASK, &oldset, NULL);
4324 PerlLIO_close(pp[0]);
4325 #if defined(HAS_FCNTL) && defined(F_SETFD)
4326 if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
4330 if (PL_op->op_flags & OPf_STACKED) {
4331 SV * const really = *++MARK;
4332 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4334 else if (SP - MARK != 1)
4335 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4337 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4341 #else /* ! FORK or VMS or OS/2 */
4344 if (PL_op->op_flags & OPf_STACKED) {
4345 SV * const really = *++MARK;
4346 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4347 value = (I32)do_aspawn(really, MARK, SP);
4349 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4352 else if (SP - MARK != 1) {
4353 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4354 value = (I32)do_aspawn(NULL, MARK, SP);
4356 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4360 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4362 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4364 STATUS_NATIVE_CHILD_SET(value);
4367 XPUSHi(result ? value : STATUS_CURRENT);
4368 #endif /* !FORK or VMS or OS/2 */
4375 dSP; dMARK; dORIGMARK; dTARGET;
4380 while (++MARK <= SP) {
4381 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4386 TAINT_PROPER("exec");
4388 PERL_FLUSHALL_FOR_CHILD;
4389 if (PL_op->op_flags & OPf_STACKED) {
4390 SV * const really = *++MARK;
4391 value = (I32)do_aexec(really, MARK, SP);
4393 else if (SP - MARK != 1)
4395 value = (I32)vms_do_aexec(NULL, MARK, SP);
4397 value = (I32)do_aexec(NULL, MARK, SP);
4401 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4403 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4416 XPUSHi( getppid() );
4419 DIE(aTHX_ PL_no_func, "getppid");
4429 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4432 pgrp = (I32)BSD_GETPGRP(pid);
4434 if (pid != 0 && pid != PerlProc_getpid())
4435 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4441 DIE(aTHX_ PL_no_func, "getpgrp");
4451 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4452 if (MAXARG > 0) pid = TOPs && TOPi;
4458 TAINT_PROPER("setpgrp");
4460 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4462 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4463 || (pid != 0 && pid != PerlProc_getpid()))
4465 DIE(aTHX_ "setpgrp can't take arguments");
4467 SETi( setpgrp() >= 0 );
4468 #endif /* USE_BSDPGRP */
4471 DIE(aTHX_ PL_no_func, "setpgrp");
4475 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4476 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4478 # define PRIORITY_WHICH_T(which) which
4483 #ifdef HAS_GETPRIORITY
4485 const int who = POPi;
4486 const int which = TOPi;
4487 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4490 DIE(aTHX_ PL_no_func, "getpriority");
4496 #ifdef HAS_SETPRIORITY
4498 const int niceval = POPi;
4499 const int who = POPi;
4500 const int which = TOPi;
4501 TAINT_PROPER("setpriority");
4502 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4505 DIE(aTHX_ PL_no_func, "setpriority");
4509 #undef PRIORITY_WHICH_T
4517 XPUSHn( time(NULL) );
4519 XPUSHi( time(NULL) );
4528 struct tms timesbuf;
4531 (void)PerlProc_times(×buf);
4533 mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
4534 if (GIMME == G_ARRAY) {
4535 mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
4536 mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
4537 mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
4545 if (GIMME == G_ARRAY) {
4552 DIE(aTHX_ "times not implemented");
4554 #endif /* HAS_TIMES */
4557 /* The 32 bit int year limits the times we can represent to these
4558 boundaries with a few days wiggle room to account for time zone
4561 /* Sat Jan 3 00:00:00 -2147481748 */
4562 #define TIME_LOWER_BOUND -67768100567755200.0
4563 /* Sun Dec 29 12:00:00 2147483647 */
4564 #define TIME_UPPER_BOUND 67767976233316800.0
4567 /* also used for: pp_localtime() */
4575 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4576 static const char * const dayname[] =
4577 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4578 static const char * const monname[] =
4579 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4580 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4582 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4585 when = (Time64_T)now;
4588 NV input = Perl_floor(POPn);
4589 when = (Time64_T)input;
4590 if (when != input) {
4591 /* diag_listed_as: gmtime(%f) too large */
4592 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4593 "%s(%.0" NVff ") too large", opname, input);
4597 if ( TIME_LOWER_BOUND > when ) {
4598 /* diag_listed_as: gmtime(%f) too small */
4599 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4600 "%s(%.0" NVff ") too small", opname, when);
4603 else if( when > TIME_UPPER_BOUND ) {
4604 /* diag_listed_as: gmtime(%f) too small */
4605 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4606 "%s(%.0" NVff ") too large", opname, when);
4610 if (PL_op->op_type == OP_LOCALTIME)
4611 err = S_localtime64_r(&when, &tmbuf);
4613 err = S_gmtime64_r(&when, &tmbuf);
4617 /* diag_listed_as: gmtime(%f) failed */
4618 /* XXX %lld broken for quads */
4619 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4620 "%s(%.0" NVff ") failed", opname, when);
4623 if (GIMME != G_ARRAY) { /* scalar context */
4629 mPUSHs(Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %"IVdf,
4630 dayname[tmbuf.tm_wday],
4631 monname[tmbuf.tm_mon],
4636 (IV)tmbuf.tm_year + 1900));
4639 else { /* list context */
4645 mPUSHi(tmbuf.tm_sec);
4646 mPUSHi(tmbuf.tm_min);
4647 mPUSHi(tmbuf.tm_hour);
4648 mPUSHi(tmbuf.tm_mday);
4649 mPUSHi(tmbuf.tm_mon);
4650 mPUSHn(tmbuf.tm_year);
4651 mPUSHi(tmbuf.tm_wday);
4652 mPUSHi(tmbuf.tm_yday);
4653 mPUSHi(tmbuf.tm_isdst);
4664 anum = alarm((unsigned int)anum);
4670 DIE(aTHX_ PL_no_func, "alarm");
4681 (void)time(&lasttime);
4682 if (MAXARG < 1 || (!TOPs && !POPs))
4686 PerlProc_sleep((unsigned int)duration);
4689 XPUSHi(when - lasttime);
4693 /* Shared memory. */
4694 /* Merged with some message passing. */
4696 /* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */
4700 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4701 dSP; dMARK; dTARGET;
4702 const int op_type = PL_op->op_type;
4707 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4710 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4713 value = (I32)(do_semop(MARK, SP) >= 0);
4716 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4724 return Perl_pp_semget(aTHX);
4730 /* also used for: pp_msgget() pp_shmget() */
4734 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4735 dSP; dMARK; dTARGET;
4736 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4743 DIE(aTHX_ "System V IPC is not implemented on this machine");
4747 /* also used for: pp_msgctl() pp_shmctl() */
4751 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4752 dSP; dMARK; dTARGET;
4753 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4761 PUSHp(zero_but_true, ZBTLEN);
4765 return Perl_pp_semget(aTHX);
4769 /* I can't const this further without getting warnings about the types of
4770 various arrays passed in from structures. */
4772 S_space_join_names_mortal(pTHX_ char *const *array)
4776 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4778 if (array && *array) {
4779 target = newSVpvs_flags("", SVs_TEMP);
4781 sv_catpv(target, *array);
4784 sv_catpvs(target, " ");
4787 target = sv_mortalcopy(&PL_sv_no);
4792 /* Get system info. */
4794 /* also used for: pp_ghbyaddr() pp_ghbyname() */
4798 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4800 I32 which = PL_op->op_type;
4803 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4804 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4805 struct hostent *gethostbyname(Netdb_name_t);
4806 struct hostent *gethostent(void);
4808 struct hostent *hent = NULL;
4812 if (which == OP_GHBYNAME) {
4813 #ifdef HAS_GETHOSTBYNAME
4814 const char* const name = POPpbytex;
4815 hent = PerlSock_gethostbyname(name);
4817 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4820 else if (which == OP_GHBYADDR) {
4821 #ifdef HAS_GETHOSTBYADDR
4822 const int addrtype = POPi;
4823 SV * const addrsv = POPs;
4825 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4827 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4829 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4833 #ifdef HAS_GETHOSTENT
4834 hent = PerlSock_gethostent();
4836 DIE(aTHX_ PL_no_sock_func, "gethostent");
4839 #ifdef HOST_NOT_FOUND
4841 #ifdef USE_REENTRANT_API
4842 # ifdef USE_GETHOSTENT_ERRNO
4843 h_errno = PL_reentrant_buffer->_gethostent_errno;
4846 STATUS_UNIX_SET(h_errno);
4850 if (GIMME != G_ARRAY) {
4851 PUSHs(sv = sv_newmortal());
4853 if (which == OP_GHBYNAME) {
4855 sv_setpvn(sv, hent->h_addr, hent->h_length);
4858 sv_setpv(sv, (char*)hent->h_name);
4864 mPUSHs(newSVpv((char*)hent->h_name, 0));
4865 PUSHs(space_join_names_mortal(hent->h_aliases));
4866 mPUSHi(hent->h_addrtype);
4867 len = hent->h_length;
4870 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4871 mXPUSHp(*elem, len);
4875 mPUSHp(hent->h_addr, len);
4877 PUSHs(sv_mortalcopy(&PL_sv_no));
4882 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4886 /* also used for: pp_gnbyaddr() pp_gnbyname() */
4890 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4892 I32 which = PL_op->op_type;
4894 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4895 struct netent *getnetbyaddr(Netdb_net_t, int);
4896 struct netent *getnetbyname(Netdb_name_t);
4897 struct netent *getnetent(void);
4899 struct netent *nent;
4901 if (which == OP_GNBYNAME){
4902 #ifdef HAS_GETNETBYNAME
4903 const char * const name = POPpbytex;
4904 nent = PerlSock_getnetbyname(name);
4906 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4909 else if (which == OP_GNBYADDR) {
4910 #ifdef HAS_GETNETBYADDR
4911 const int addrtype = POPi;
4912 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4913 nent = PerlSock_getnetbyaddr(addr, addrtype);
4915 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4919 #ifdef HAS_GETNETENT
4920 nent = PerlSock_getnetent();
4922 DIE(aTHX_ PL_no_sock_func, "getnetent");
4925 #ifdef HOST_NOT_FOUND
4927 #ifdef USE_REENTRANT_API
4928 # ifdef USE_GETNETENT_ERRNO
4929 h_errno = PL_reentrant_buffer->_getnetent_errno;
4932 STATUS_UNIX_SET(h_errno);
4937 if (GIMME != G_ARRAY) {
4938 PUSHs(sv = sv_newmortal());
4940 if (which == OP_GNBYNAME)
4941 sv_setiv(sv, (IV)nent->n_net);
4943 sv_setpv(sv, nent->n_name);
4949 mPUSHs(newSVpv(nent->n_name, 0));
4950 PUSHs(space_join_names_mortal(nent->n_aliases));
4951 mPUSHi(nent->n_addrtype);
4952 mPUSHi(nent->n_net);
4957 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4962 /* also used for: pp_gpbyname() pp_gpbynumber() */
4966 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4968 I32 which = PL_op->op_type;
4970 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4971 struct protoent *getprotobyname(Netdb_name_t);
4972 struct protoent *getprotobynumber(int);
4973 struct protoent *getprotoent(void);
4975 struct protoent *pent;
4977 if (which == OP_GPBYNAME) {
4978 #ifdef HAS_GETPROTOBYNAME
4979 const char* const name = POPpbytex;
4980 pent = PerlSock_getprotobyname(name);
4982 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4985 else if (which == OP_GPBYNUMBER) {
4986 #ifdef HAS_GETPROTOBYNUMBER
4987 const int number = POPi;
4988 pent = PerlSock_getprotobynumber(number);
4990 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4994 #ifdef HAS_GETPROTOENT
4995 pent = PerlSock_getprotoent();
4997 DIE(aTHX_ PL_no_sock_func, "getprotoent");
5001 if (GIMME != G_ARRAY) {
5002 PUSHs(sv = sv_newmortal());
5004 if (which == OP_GPBYNAME)
5005 sv_setiv(sv, (IV)pent->p_proto);
5007 sv_setpv(sv, pent->p_name);
5013 mPUSHs(newSVpv(pent->p_name, 0));
5014 PUSHs(space_join_names_mortal(pent->p_aliases));
5015 mPUSHi(pent->p_proto);
5020 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5025 /* also used for: pp_gsbyname() pp_gsbyport() */
5029 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
5031 I32 which = PL_op->op_type;
5033 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
5034 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
5035 struct servent *getservbyport(int, Netdb_name_t);
5036 struct servent *getservent(void);
5038 struct servent *sent;
5040 if (which == OP_GSBYNAME) {
5041 #ifdef HAS_GETSERVBYNAME
5042 const char * const proto = POPpbytex;
5043 const char * const name = POPpbytex;
5044 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5046 DIE(aTHX_ PL_no_sock_func, "getservbyname");
5049 else if (which == OP_GSBYPORT) {
5050 #ifdef HAS_GETSERVBYPORT
5051 const char * const proto = POPpbytex;
5052 unsigned short port = (unsigned short)POPu;
5053 port = PerlSock_htons(port);
5054 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5056 DIE(aTHX_ PL_no_sock_func, "getservbyport");
5060 #ifdef HAS_GETSERVENT
5061 sent = PerlSock_getservent();
5063 DIE(aTHX_ PL_no_sock_func, "getservent");
5067 if (GIMME != G_ARRAY) {
5068 PUSHs(sv = sv_newmortal());
5070 if (which == OP_GSBYNAME) {
5071 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5074 sv_setpv(sv, sent->s_name);
5080 mPUSHs(newSVpv(sent->s_name, 0));
5081 PUSHs(space_join_names_mortal(sent->s_aliases));
5082 mPUSHi(PerlSock_ntohs(sent->s_port));
5083 mPUSHs(newSVpv(sent->s_proto, 0));
5088 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5093 /* also used for: pp_snetent() pp_sprotoent() pp_sservent() */
5098 const int stayopen = TOPi;
5099 switch(PL_op->op_type) {
5101 #ifdef HAS_SETHOSTENT
5102 PerlSock_sethostent(stayopen);
5104 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5107 #ifdef HAS_SETNETENT
5109 PerlSock_setnetent(stayopen);
5111 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5115 #ifdef HAS_SETPROTOENT
5116 PerlSock_setprotoent(stayopen);
5118 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5122 #ifdef HAS_SETSERVENT
5123 PerlSock_setservent(stayopen);
5125 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5133 /* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent()
5134 * pp_eservent() pp_sgrent() pp_spwent() */
5139 switch(PL_op->op_type) {
5141 #ifdef HAS_ENDHOSTENT
5142 PerlSock_endhostent();
5144 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5148 #ifdef HAS_ENDNETENT
5149 PerlSock_endnetent();
5151 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5155 #ifdef HAS_ENDPROTOENT
5156 PerlSock_endprotoent();
5158 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5162 #ifdef HAS_ENDSERVENT
5163 PerlSock_endservent();
5165 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5169 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5172 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5176 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5179 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5183 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5186 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5190 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5193 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5202 /* also used for: pp_gpwnam() pp_gpwuid() */
5208 I32 which = PL_op->op_type;
5210 struct passwd *pwent = NULL;
5212 * We currently support only the SysV getsp* shadow password interface.
5213 * The interface is declared in <shadow.h> and often one needs to link
5214 * with -lsecurity or some such.
5215 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5218 * AIX getpwnam() is clever enough to return the encrypted password
5219 * only if the caller (euid?) is root.
5221 * There are at least three other shadow password APIs. Many platforms
5222 * seem to contain more than one interface for accessing the shadow
5223 * password databases, possibly for compatibility reasons.
5224 * The getsp*() is by far he simplest one, the other two interfaces
5225 * are much more complicated, but also very similar to each other.
5230 * struct pr_passwd *getprpw*();
5231 * The password is in
5232 * char getprpw*(...).ufld.fd_encrypt[]
5233 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5238 * struct es_passwd *getespw*();
5239 * The password is in
5240 * char *(getespw*(...).ufld.fd_encrypt)
5241 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5244 * struct userpw *getuserpw();
5245 * The password is in
5246 * char *(getuserpw(...)).spw_upw_passwd
5247 * (but the de facto standard getpwnam() should work okay)
5249 * Mention I_PROT here so that Configure probes for it.
5251 * In HP-UX for getprpw*() the manual page claims that one should include
5252 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5253 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5254 * and pp_sys.c already includes <shadow.h> if there is such.
5256 * Note that <sys/security.h> is already probed for, but currently
5257 * it is only included in special cases.
5259 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5260 * be preferred interface, even though also the getprpw*() interface
5261 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5262 * One also needs to call set_auth_parameters() in main() before
5263 * doing anything else, whether one is using getespw*() or getprpw*().
5265 * Note that accessing the shadow databases can be magnitudes
5266 * slower than accessing the standard databases.
5271 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5272 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5273 * the pw_comment is left uninitialized. */
5274 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5280 const char* const name = POPpbytex;
5281 pwent = getpwnam(name);
5287 pwent = getpwuid(uid);
5291 # ifdef HAS_GETPWENT
5293 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5294 if (pwent) pwent = getpwnam(pwent->pw_name);
5297 DIE(aTHX_ PL_no_func, "getpwent");
5303 if (GIMME != G_ARRAY) {
5304 PUSHs(sv = sv_newmortal());
5306 if (which == OP_GPWNAM)
5307 sv_setuid(sv, pwent->pw_uid);
5309 sv_setpv(sv, pwent->pw_name);
5315 mPUSHs(newSVpv(pwent->pw_name, 0));
5319 /* If we have getspnam(), we try to dig up the shadow
5320 * password. If we are underprivileged, the shadow
5321 * interface will set the errno to EACCES or similar,
5322 * and return a null pointer. If this happens, we will
5323 * use the dummy password (usually "*" or "x") from the
5324 * standard password database.
5326 * In theory we could skip the shadow call completely
5327 * if euid != 0 but in practice we cannot know which
5328 * security measures are guarding the shadow databases
5329 * on a random platform.
5331 * Resist the urge to use additional shadow interfaces.
5332 * Divert the urge to writing an extension instead.
5335 /* Some AIX setups falsely(?) detect some getspnam(), which
5336 * has a different API than the Solaris/IRIX one. */
5337 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5340 const struct spwd * const spwent = getspnam(pwent->pw_name);
5341 /* Save and restore errno so that
5342 * underprivileged attempts seem
5343 * to have never made the unsuccessful
5344 * attempt to retrieve the shadow password. */
5346 if (spwent && spwent->sp_pwdp)
5347 sv_setpv(sv, spwent->sp_pwdp);
5351 if (!SvPOK(sv)) /* Use the standard password, then. */
5352 sv_setpv(sv, pwent->pw_passwd);
5355 /* passwd is tainted because user himself can diddle with it.
5356 * admittedly not much and in a very limited way, but nevertheless. */
5359 sv_setuid(PUSHmortal, pwent->pw_uid);
5360 sv_setgid(PUSHmortal, pwent->pw_gid);
5362 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5363 * because of the poor interface of the Perl getpw*(),
5364 * not because there's some standard/convention saying so.
5365 * A better interface would have been to return a hash,
5366 * but we are accursed by our history, alas. --jhi. */
5368 mPUSHi(pwent->pw_change);
5371 mPUSHi(pwent->pw_quota);
5374 mPUSHs(newSVpv(pwent->pw_age, 0));
5376 /* I think that you can never get this compiled, but just in case. */
5377 PUSHs(sv_mortalcopy(&PL_sv_no));
5382 /* pw_class and pw_comment are mutually exclusive--.
5383 * see the above note for pw_change, pw_quota, and pw_age. */
5385 mPUSHs(newSVpv(pwent->pw_class, 0));
5388 mPUSHs(newSVpv(pwent->pw_comment, 0));
5390 /* I think that you can never get this compiled, but just in case. */
5391 PUSHs(sv_mortalcopy(&PL_sv_no));
5396 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5398 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5400 /* pw_gecos is tainted because user himself can diddle with it. */
5403 mPUSHs(newSVpv(pwent->pw_dir, 0));
5405 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5406 /* pw_shell is tainted because user himself can diddle with it. */
5410 mPUSHi(pwent->pw_expire);
5415 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5420 /* also used for: pp_ggrgid() pp_ggrnam() */
5426 const I32 which = PL_op->op_type;
5427 const struct group *grent;
5429 if (which == OP_GGRNAM) {
5430 const char* const name = POPpbytex;
5431 grent = (const struct group *)getgrnam(name);
5433 else if (which == OP_GGRGID) {
5434 const Gid_t gid = POPi;
5435 grent = (const struct group *)getgrgid(gid);
5439 grent = (struct group *)getgrent();
5441 DIE(aTHX_ PL_no_func, "getgrent");
5445 if (GIMME != G_ARRAY) {
5446 SV * const sv = sv_newmortal();
5450 if (which == OP_GGRNAM)
5451 sv_setgid(sv, grent->gr_gid);
5453 sv_setpv(sv, grent->gr_name);
5459 mPUSHs(newSVpv(grent->gr_name, 0));
5462 mPUSHs(newSVpv(grent->gr_passwd, 0));
5464 PUSHs(sv_mortalcopy(&PL_sv_no));
5467 sv_setgid(PUSHmortal, grent->gr_gid);
5469 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5470 /* In UNICOS/mk (_CRAYMPP) the multithreading
5471 * versions (getgrnam_r, getgrgid_r)
5472 * seem to return an illegal pointer
5473 * as the group members list, gr_mem.
5474 * getgrent() doesn't even have a _r version
5475 * but the gr_mem is poisonous anyway.
5476 * So yes, you cannot get the list of group
5477 * members if building multithreaded in UNICOS/mk. */
5478 PUSHs(space_join_names_mortal(grent->gr_mem));
5484 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5494 if (!(tmps = PerlProc_getlogin()))
5496 sv_setpv_mg(TARG, tmps);
5500 DIE(aTHX_ PL_no_func, "getlogin");
5504 /* Miscellaneous. */
5509 dSP; dMARK; dORIGMARK; dTARGET;
5510 I32 items = SP - MARK;
5511 unsigned long a[20];
5516 while (++MARK <= SP) {
5517 if (SvTAINTED(*MARK)) {
5523 TAINT_PROPER("syscall");
5526 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5527 * or where sizeof(long) != sizeof(char*). But such machines will
5528 * not likely have syscall implemented either, so who cares?
5530 while (++MARK <= SP) {
5531 if (SvNIOK(*MARK) || !i)
5532 a[i++] = SvIV(*MARK);
5533 else if (*MARK == &PL_sv_undef)
5536 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5542 DIE(aTHX_ "Too many args to syscall");
5544 DIE(aTHX_ "Too few args to syscall");
5546 retval = syscall(a[0]);
5549 retval = syscall(a[0],a[1]);
5552 retval = syscall(a[0],a[1],a[2]);
5555 retval = syscall(a[0],a[1],a[2],a[3]);
5558 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5561 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5564 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5567 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5574 DIE(aTHX_ PL_no_func, "syscall");
5578 #ifdef FCNTL_EMULATE_FLOCK
5580 /* XXX Emulate flock() with fcntl().
5581 What's really needed is a good file locking module.
5585 fcntl_emulate_flock(int fd, int operation)
5590 switch (operation & ~LOCK_NB) {
5592 flock.l_type = F_RDLCK;
5595 flock.l_type = F_WRLCK;
5598 flock.l_type = F_UNLCK;
5604 flock.l_whence = SEEK_SET;
5605 flock.l_start = flock.l_len = (Off_t)0;
5607 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5608 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5609 errno = EWOULDBLOCK;
5613 #endif /* FCNTL_EMULATE_FLOCK */
5615 #ifdef LOCKF_EMULATE_FLOCK
5617 /* XXX Emulate flock() with lockf(). This is just to increase
5618 portability of scripts. The calls are not completely
5619 interchangeable. What's really needed is a good file
5623 /* The lockf() constants might have been defined in <unistd.h>.
5624 Unfortunately, <unistd.h> causes troubles on some mixed
5625 (BSD/POSIX) systems, such as SunOS 4.1.3.
5627 Further, the lockf() constants aren't POSIX, so they might not be
5628 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5629 just stick in the SVID values and be done with it. Sigh.
5633 # define F_ULOCK 0 /* Unlock a previously locked region */
5636 # define F_LOCK 1 /* Lock a region for exclusive use */
5639 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5642 # define F_TEST 3 /* Test a region for other processes locks */
5646 lockf_emulate_flock(int fd, int operation)
5652 /* flock locks entire file so for lockf we need to do the same */
5653 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5654 if (pos > 0) /* is seekable and needs to be repositioned */
5655 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5656 pos = -1; /* seek failed, so don't seek back afterwards */
5659 switch (operation) {
5661 /* LOCK_SH - get a shared lock */
5663 /* LOCK_EX - get an exclusive lock */
5665 i = lockf (fd, F_LOCK, 0);
5668 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5669 case LOCK_SH|LOCK_NB:
5670 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5671 case LOCK_EX|LOCK_NB:
5672 i = lockf (fd, F_TLOCK, 0);
5674 if ((errno == EAGAIN) || (errno == EACCES))
5675 errno = EWOULDBLOCK;
5678 /* LOCK_UN - unlock (non-blocking is a no-op) */
5680 case LOCK_UN|LOCK_NB:
5681 i = lockf (fd, F_ULOCK, 0);
5684 /* Default - can't decipher operation */
5691 if (pos > 0) /* need to restore position of the handle */
5692 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5697 #endif /* LOCKF_EMULATE_FLOCK */
5701 * c-indentation-style: bsd
5703 * indent-tabs-mode: nil
5706 * ex: set ts=8 sts=4 sw=4 et: