3 * Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 * 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * But only a short way ahead its floor and the walls on either side were
13 * cloven by a great fissure, out of which the red glare came, now leaping
14 * up, now dying down into darkness; and all the while far below there was
15 * a rumour and a trouble as of great engines throbbing and labouring.
17 * [p.945 of _The Lord of the Rings_, VI/iii: "Mount Doom"]
20 /* This file contains system pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
26 * By 'system', we mean ops which interact with the OS, such as pp_open().
30 #define PERL_IN_PP_SYS_C
36 /* Shadow password support for solaris - pdo@cs.umd.edu
37 * Not just Solaris: at least HP-UX, IRIX, Linux.
38 * The API is from SysV.
40 * There are at least two more shadow interfaces,
41 * see the comments in pp_gpwent().
45 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
46 * and another MAXINT from "perl.h" <- <sys/param.h>. */
53 # include <sys/resource.h>
62 # include <sys/select.h>
66 /* XXX Configure test needed.
67 h_errno might not be a simple 'int', especially for multi-threaded
68 applications, see "extern int errno in perl.h". Creating such
69 a test requires taking into account the differences between
70 compiling multithreaded and singlethreaded ($ccflags et al).
71 HOST_NOT_FOUND is typically defined in <netdb.h>.
73 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
82 struct passwd *getpwnam (char *);
83 struct passwd *getpwuid (Uid_t);
88 struct passwd *getpwent (void);
89 #elif defined (VMS) && defined (my_getpwent)
90 struct passwd *Perl_my_getpwent (pTHX);
99 struct group *getgrnam (char *);
100 struct group *getgrgid (Gid_t);
104 struct group *getgrent (void);
110 # if defined(_MSC_VER) || defined(__MINGW32__)
111 # include <sys/utime.h>
118 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
121 # define my_chsize PerlLIO_chsize
124 # define my_chsize PerlLIO_chsize
126 I32 my_chsize(int fd, Off_t length);
132 #else /* no flock() */
134 /* fcntl.h might not have been included, even if it exists, because
135 the current Configure only sets I_FCNTL if it's needed to pick up
136 the *_OK constants. Make sure it has been included before testing
137 the fcntl() locking constants. */
138 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
142 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
143 # define FLOCK fcntl_emulate_flock
144 # define FCNTL_EMULATE_FLOCK
145 # else /* no flock() or fcntl(F_SETLK,...) */
147 # define FLOCK lockf_emulate_flock
148 # define LOCKF_EMULATE_FLOCK
150 # endif /* no flock() or fcntl(F_SETLK,...) */
153 static int FLOCK (int, int);
156 * These are the flock() constants. Since this sytems doesn't have
157 * flock(), the values of the constants are probably not available.
171 # endif /* emulating flock() */
173 #endif /* no flock() */
176 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
178 #if defined(I_SYS_ACCESS) && !defined(R_OK)
179 # include <sys/access.h>
182 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
183 # define FD_CLOEXEC 1 /* NeXT needs this */
189 /* Missing protos on LynxOS */
190 void sethostent(int);
191 void endhostent(void);
193 void endnetent(void);
194 void setprotoent(int);
195 void endprotoent(void);
196 void setservent(int);
197 void endservent(void);
200 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
202 /* F_OK unused: if stat() cannot find it... */
204 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
205 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
206 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
209 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
210 # ifdef I_SYS_SECURITY
211 # include <sys/security.h>
215 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
218 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
222 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
224 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
228 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
229 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
230 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
233 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
235 const Uid_t ruid = getuid();
236 const Uid_t euid = geteuid();
237 const Gid_t rgid = getgid();
238 const Gid_t egid = getegid();
241 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
242 Perl_croak(aTHX_ "switching effective uid is not implemented");
245 if (setreuid(euid, ruid))
248 if (setresuid(euid, ruid, (Uid_t)-1))
251 /* diag_listed_as: entering effective %s failed */
252 Perl_croak(aTHX_ "entering effective uid failed");
255 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
256 Perl_croak(aTHX_ "switching effective gid is not implemented");
259 if (setregid(egid, rgid))
262 if (setresgid(egid, rgid, (Gid_t)-1))
265 /* diag_listed_as: entering effective %s failed */
266 Perl_croak(aTHX_ "entering effective gid failed");
269 res = access(path, mode);
272 if (setreuid(ruid, euid))
275 if (setresuid(ruid, euid, (Uid_t)-1))
278 /* diag_listed_as: leaving effective %s failed */
279 Perl_croak(aTHX_ "leaving effective uid failed");
282 if (setregid(rgid, egid))
285 if (setresgid(rgid, egid, (Gid_t)-1))
288 /* diag_listed_as: leaving effective %s failed */
289 Perl_croak(aTHX_ "leaving effective gid failed");
293 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
300 const char * const tmps = POPpconstx;
301 const I32 gimme = GIMME_V;
302 const char *mode = "r";
305 if (PL_op->op_private & OPpOPEN_IN_RAW)
307 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
309 fp = PerlProc_popen(tmps, mode);
311 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
313 PerlIO_apply_layers(aTHX_ fp,mode,type);
315 if (gimme == G_VOID) {
317 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
320 else if (gimme == G_SCALAR) {
321 ENTER_with_name("backtick");
323 PL_rs = &PL_sv_undef;
324 sv_setpvs(TARG, ""); /* note that this preserves previous buffer */
325 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
327 LEAVE_with_name("backtick");
333 SV * const sv = newSV(79);
334 if (sv_gets(sv, fp, 0) == NULL) {
339 if (SvLEN(sv) - SvCUR(sv) > 20) {
340 SvPV_shrink_to_cur(sv);
345 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
346 TAINT; /* "I believe that this is not gratuitous!" */
349 STATUS_NATIVE_CHILD_SET(-1);
350 if (gimme == G_SCALAR)
362 /* make a copy of the pattern if it is gmagical, to ensure that magic
363 * is called once and only once */
364 if (SvGMAGICAL(TOPm1s)) TOPm1s = sv_2mortal(newSVsv(TOPm1s));
366 tryAMAGICunTARGETlist(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL));
368 if (PL_op->op_flags & OPf_SPECIAL) {
369 /* call Perl-level glob function instead. Stack args are:
370 * MARK, wildcard, csh_glob context index
371 * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
375 /* stack args are: wildcard, gv(_GEN_n) */
383 /* Note that we only ever get here if File::Glob fails to load
384 * without at the same time croaking, for some reason, or if
385 * perl was built with PERL_EXTERNAL_GLOB */
387 ENTER_with_name("glob");
392 * The external globbing program may use things we can't control,
393 * so for security reasons we must assume the worst.
396 taint_proper(PL_no_security, "glob");
400 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
401 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
403 SAVESPTR(PL_rs); /* This is not permanent, either. */
404 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
407 *SvPVX(PL_rs) = '\n';
411 result = do_readline();
412 LEAVE_with_name("glob");
419 PL_last_in_gv = cGVOP_gv;
420 return do_readline();
430 do_join(TARG, &PL_sv_no, MARK, SP);
434 else if (SP == MARK) {
441 if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
444 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
445 /* well-formed exception supplied */
450 if (SvGMAGICAL(ERRSV)) {
451 exsv = sv_newmortal();
452 sv_setsv_nomg(exsv, ERRSV);
456 else if (SvPOKp(ERRSV) ? SvCUR(ERRSV) : SvNIOKp(ERRSV)) {
457 exsv = sv_newmortal();
458 sv_setsv_nomg(exsv, ERRSV);
459 sv_catpvs(exsv, "\t...caught");
462 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
465 if (SvROK(exsv) && !PL_warnhook)
466 Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
477 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
479 if (SP - MARK != 1) {
481 do_join(TARG, &PL_sv_no, MARK, SP);
489 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
490 /* well-formed exception supplied */
492 else if (SvROK(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 (SvPV_const(ERRSV, len), len) {
513 exsv = sv_mortalcopy(ERRSV);
514 sv_catpvs(exsv, "\t...propagated");
517 exsv = newSVpvs_flags("Died", SVs_TEMP);
525 Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv,
526 const MAGIC *const mg, const U32 flags, U32 argc, ...)
531 PERL_ARGS_ASSERT_TIED_METHOD;
533 /* Ensure that our flag bits do not overlap. */
534 assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
535 assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
536 assert((TIED_METHOD_SAY & G_WANT) == 0);
538 PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
539 PUSHSTACKi(PERLSI_MAGIC);
540 EXTEND(SP, argc+1); /* object + args */
542 PUSHs(SvTIED_obj(sv, mg));
543 if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
544 Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
548 const U32 mortalize_not_needed
549 = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
551 va_start(args, argc);
553 SV *const arg = va_arg(args, SV *);
554 if(mortalize_not_needed)
563 ENTER_with_name("call_tied_method");
564 if (flags & TIED_METHOD_SAY) {
565 /* local $\ = "\n" */
566 SAVEGENERICSV(PL_ors_sv);
567 PL_ors_sv = newSVpvs("\n");
569 ret_args = call_method(methname, flags & G_WANT);
574 if (ret_args) { /* copy results back to original stack */
575 EXTEND(sp, ret_args);
576 Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
580 LEAVE_with_name("call_tied_method");
584 #define tied_method0(a,b,c,d) \
585 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
586 #define tied_method1(a,b,c,d,e) \
587 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
588 #define tied_method2(a,b,c,d,e,f) \
589 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
602 GV * const gv = MUTABLE_GV(*++MARK);
604 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
605 DIE(aTHX_ PL_no_usym, "filehandle");
607 if ((io = GvIOp(gv))) {
609 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
612 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
613 "Opening dirhandle %"HEKf" also as a file",
614 HEKfARG(GvENAME_HEK(gv)));
616 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
618 /* Method's args are same as ours ... */
619 /* ... except handle is replaced by the object */
620 return Perl_tied_method(aTHX_ "OPEN", mark - 1, MUTABLE_SV(io), mg,
621 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
633 tmps = SvPV_const(sv, len);
634 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
637 PUSHi( (I32)PL_forkprocess );
638 else if (PL_forkprocess == 0) /* we are a new child */
649 MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
655 IO * const io = GvIO(gv);
657 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
659 return tied_method0("CLOSE", SP, MUTABLE_SV(io), mg);
663 PUSHs(boolSV(do_close(gv, TRUE)));
676 GV * const wgv = MUTABLE_GV(POPs);
677 GV * const rgv = MUTABLE_GV(POPs);
682 if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
683 DIE(aTHX_ PL_no_usym, "filehandle");
688 do_close(rgv, FALSE);
690 do_close(wgv, FALSE);
692 if (PerlProc_pipe(fd) < 0)
695 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
696 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
697 IoOFP(rstio) = IoIFP(rstio);
698 IoIFP(wstio) = IoOFP(wstio);
699 IoTYPE(rstio) = IoTYPE_RDONLY;
700 IoTYPE(wstio) = IoTYPE_WRONLY;
702 if (!IoIFP(rstio) || !IoOFP(wstio)) {
704 PerlIO_close(IoIFP(rstio));
706 PerlLIO_close(fd[0]);
708 PerlIO_close(IoOFP(wstio));
710 PerlLIO_close(fd[1]);
713 #if defined(HAS_FCNTL) && defined(F_SETFD)
714 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
715 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
722 DIE(aTHX_ PL_no_func, "pipe");
736 gv = MUTABLE_GV(POPs);
740 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
742 return tied_method0("FILENO", SP, MUTABLE_SV(io), mg);
745 if (!io || !(fp = IoIFP(io))) {
746 /* Can't do this because people seem to do things like
747 defined(fileno($foo)) to check whether $foo is a valid fh.
754 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_ "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)) {
864 methname = "TIEHASH";
865 HvEITER_set(MUTABLE_HV(varsv), 0);
868 methname = "TIEARRAY";
869 if (!AvREAL(varsv)) {
871 Perl_croak(aTHX_ "Cannot tie unreifiable array");
872 av_clear((AV *)varsv);
879 if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
880 methname = "TIEHANDLE";
881 how = PERL_MAGIC_tiedscalar;
882 /* For tied filehandles, we apply tiedscalar magic to the IO
883 slot of the GP rather than the GV itself. AMS 20010812 */
885 GvIOp(varsv) = newIO();
886 varsv = MUTABLE_SV(GvIOp(varsv));
891 methname = "TIESCALAR";
892 how = PERL_MAGIC_tiedscalar;
896 if (sv_isobject(*MARK)) { /* Calls GET magic. */
897 ENTER_with_name("call_TIE");
898 PUSHSTACKi(PERLSI_MAGIC);
900 EXTEND(SP,(I32)items);
904 call_method(methname, G_SCALAR);
907 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
908 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
909 * wrong error message, and worse case, supreme action at a distance.
910 * (Sorry obfuscation writers. You're not going to be given this one.)
912 stash = gv_stashsv(*MARK, 0);
913 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
914 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
915 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
917 ENTER_with_name("call_TIE");
918 PUSHSTACKi(PERLSI_MAGIC);
920 EXTEND(SP,(I32)items);
924 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
930 if (sv_isobject(sv)) {
931 sv_unmagic(varsv, how);
932 /* Croak if a self-tie on an aggregate is attempted. */
933 if (varsv == SvRV(sv) &&
934 (SvTYPE(varsv) == SVt_PVAV ||
935 SvTYPE(varsv) == SVt_PVHV))
937 "Self-ties of arrays and hashes are not supported");
938 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
940 LEAVE_with_name("call_TIE");
941 SP = PL_stack_base + markoff;
951 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
952 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
954 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
957 if ((mg = SvTIED_mg(sv, how))) {
958 SV * const obj = SvRV(SvTIED_obj(sv, mg));
960 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
962 if (gv && isGV(gv) && (cv = GvCV(gv))) {
964 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
965 mXPUSHi(SvREFCNT(obj) - 1);
967 ENTER_with_name("call_UNTIE");
968 call_sv(MUTABLE_SV(cv), G_VOID);
969 LEAVE_with_name("call_UNTIE");
972 else if (mg && SvREFCNT(obj) > 1) {
973 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
974 "untie attempted while %"UVuf" inner references still exist",
975 (UV)SvREFCNT(obj) - 1 ) ;
979 sv_unmagic(sv, how) ;
989 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
990 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
992 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
995 if ((mg = SvTIED_mg(sv, how))) {
996 PUSHs(SvTIED_obj(sv, mg));
1009 HV * const hv = MUTABLE_HV(POPs);
1010 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1011 stash = gv_stashsv(sv, 0);
1012 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1014 require_pv("AnyDBM_File.pm");
1016 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1017 DIE(aTHX_ "No dbm on this machine");
1027 mPUSHu(O_RDWR|O_CREAT);
1031 if (!SvOK(right)) right = &PL_sv_no;
1035 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1038 if (!sv_isobject(TOPs)) {
1046 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1050 if (sv_isobject(TOPs)) {
1051 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1052 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1069 struct timeval timebuf;
1070 struct timeval *tbuf = &timebuf;
1073 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1078 # if BYTEORDER & 0xf0000
1079 # define ORDERBYTE (0x88888888 - BYTEORDER)
1081 # define ORDERBYTE (0x4444 - BYTEORDER)
1087 for (i = 1; i <= 3; i++) {
1088 SV * const sv = SP[i];
1092 if (SvREADONLY(sv)) {
1094 sv_force_normal_flags(sv, 0);
1095 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1096 Perl_croak_no_modify(aTHX);
1100 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1101 "Non-string passed as bitmask");
1102 SvPV_force_nomg_nolen(sv); /* force string conversion */
1109 /* little endians can use vecs directly */
1110 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1117 masksize = NFDBITS / NBBY;
1119 masksize = sizeof(long); /* documented int, everyone seems to use long */
1121 Zero(&fd_sets[0], 4, char*);
1124 # if SELECT_MIN_BITS == 1
1125 growsize = sizeof(fd_set);
1127 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1128 # undef SELECT_MIN_BITS
1129 # define SELECT_MIN_BITS __FD_SETSIZE
1131 /* If SELECT_MIN_BITS is greater than one we most probably will want
1132 * to align the sizes with SELECT_MIN_BITS/8 because for example
1133 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1134 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1135 * on (sets/tests/clears bits) is 32 bits. */
1136 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1144 timebuf.tv_sec = (long)value;
1145 value -= (NV)timebuf.tv_sec;
1146 timebuf.tv_usec = (long)(value * 1000000.0);
1151 for (i = 1; i <= 3; i++) {
1153 if (!SvOK(sv) || SvCUR(sv) == 0) {
1160 Sv_Grow(sv, growsize);
1164 while (++j <= growsize) {
1168 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1170 Newx(fd_sets[i], growsize, char);
1171 for (offset = 0; offset < growsize; offset += masksize) {
1172 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1173 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1176 fd_sets[i] = SvPVX(sv);
1180 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1181 /* Can't make just the (void*) conditional because that would be
1182 * cpp #if within cpp macro, and not all compilers like that. */
1183 nfound = PerlSock_select(
1185 (Select_fd_set_t) fd_sets[1],
1186 (Select_fd_set_t) fd_sets[2],
1187 (Select_fd_set_t) fd_sets[3],
1188 (void*) tbuf); /* Workaround for compiler bug. */
1190 nfound = PerlSock_select(
1192 (Select_fd_set_t) fd_sets[1],
1193 (Select_fd_set_t) fd_sets[2],
1194 (Select_fd_set_t) fd_sets[3],
1197 for (i = 1; i <= 3; i++) {
1200 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1202 for (offset = 0; offset < growsize; offset += masksize) {
1203 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1204 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1206 Safefree(fd_sets[i]);
1213 if (GIMME == G_ARRAY && tbuf) {
1214 value = (NV)(timebuf.tv_sec) +
1215 (NV)(timebuf.tv_usec) / 1000000.0;
1220 DIE(aTHX_ "select not implemented");
1225 =for apidoc setdefout
1227 Sets PL_defoutgv, the default file handle for output, to the passed in
1228 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1229 count of the passed in typeglob is increased by one, and the reference count
1230 of the typeglob that PL_defoutgv points to is decreased by one.
1236 Perl_setdefout(pTHX_ GV *gv)
1239 PERL_ARGS_ASSERT_SETDEFOUT;
1240 SvREFCNT_inc_simple_void_NN(gv);
1241 SvREFCNT_dec(PL_defoutgv);
1249 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1250 GV * egv = GvEGVx(PL_defoutgv);
1255 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1256 gvp = hv && HvENAME(hv)
1257 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1259 if (gvp && *gvp == egv) {
1260 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1264 mXPUSHs(newRV(MUTABLE_SV(egv)));
1268 if (!GvIO(newdefout))
1269 gv_IOadd(newdefout);
1270 setdefout(newdefout);
1280 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1281 IO *const io = GvIO(gv);
1287 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1289 const U32 gimme = GIMME_V;
1290 Perl_tied_method(aTHX_ "GETC", SP, MUTABLE_SV(io), mg, gimme, 0);
1291 if (gimme == G_SCALAR) {
1293 SvSetMagicSV_nosteal(TARG, TOPs);
1298 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1299 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1301 SETERRNO(EBADF,RMS_IFI);
1305 sv_setpvs(TARG, " ");
1306 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1307 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1308 /* Find out how many bytes the char needs */
1309 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1312 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1313 SvCUR_set(TARG,1+len);
1322 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1325 register PERL_CONTEXT *cx;
1326 const I32 gimme = GIMME_V;
1328 PERL_ARGS_ASSERT_DOFORM;
1330 if (cv && CvCLONE(cv))
1331 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1336 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1337 PUSHFORMAT(cx, retop);
1339 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1341 setdefout(gv); /* locally select filehandle so $% et al work */
1360 gv = MUTABLE_GV(POPs);
1377 tmpsv = sv_newmortal();
1378 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1379 DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
1381 IoFLAGS(io) &= ~IOf_DIDTOP;
1382 RETURNOP(doform(cv,gv,PL_op->op_next));
1388 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1389 register IO * const io = GvIOp(gv);
1394 register PERL_CONTEXT *cx;
1397 /* I'm not sure why, but executing the format leaves an extra value on the
1398 * stack. There's probably a better place to be handling this (probably
1399 * by avoiding pushing it in the first place!) but I don't quite know
1400 * where to look. -doy */
1403 if (!io || !(ofp = IoOFP(io)))
1406 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1407 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1409 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1410 PL_formtarget != PL_toptarget)
1414 if (!IoTOP_GV(io)) {
1417 if (!IoTOP_NAME(io)) {
1419 if (!IoFMT_NAME(io))
1420 IoFMT_NAME(io) = savepv(GvNAME(gv));
1421 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1422 HEKfARG(GvNAME_HEK(gv))));
1423 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1424 if ((topgv && GvFORM(topgv)) ||
1425 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1426 IoTOP_NAME(io) = savesvpv(topname);
1428 IoTOP_NAME(io) = savepvs("top");
1430 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1431 if (!topgv || !GvFORM(topgv)) {
1432 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1435 IoTOP_GV(io) = topgv;
1437 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1438 I32 lines = IoLINES_LEFT(io);
1439 const char *s = SvPVX_const(PL_formtarget);
1440 if (lines <= 0) /* Yow, header didn't even fit!!! */
1442 while (lines-- > 0) {
1443 s = strchr(s, '\n');
1449 const STRLEN save = SvCUR(PL_formtarget);
1450 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1451 do_print(PL_formtarget, ofp);
1452 SvCUR_set(PL_formtarget, save);
1453 sv_chop(PL_formtarget, s);
1454 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1457 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1458 do_print(PL_formfeed, ofp);
1459 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1461 PL_formtarget = PL_toptarget;
1462 IoFLAGS(io) |= IOf_DIDTOP;
1465 DIE(aTHX_ "bad top format reference");
1468 SV * const sv = sv_newmortal();
1469 gv_efullname4(sv, fgv, NULL, FALSE);
1470 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1472 RETURNOP(doform(cv, gv, PL_op));
1476 POPBLOCK(cx,PL_curpm);
1478 retop = cx->blk_sub.retop;
1484 report_wrongway_fh(gv, '<');
1490 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1491 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1493 if (!do_print(PL_formtarget, fp))
1496 FmLINES(PL_formtarget) = 0;
1497 SvCUR_set(PL_formtarget, 0);
1498 *SvEND(PL_formtarget) = '\0';
1499 if (IoFLAGS(io) & IOf_FLUSH)
1500 (void)PerlIO_flush(fp);
1505 PL_formtarget = PL_bodytarget;
1506 PERL_UNUSED_VAR(newsp);
1507 PERL_UNUSED_VAR(gimme);
1513 dVAR; dSP; dMARK; dORIGMARK;
1518 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1519 IO *const io = GvIO(gv);
1522 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1524 if (MARK == ORIGMARK) {
1527 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1530 return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io),
1532 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1540 SETERRNO(EBADF,RMS_IFI);
1543 else if (!(fp = IoOFP(io))) {
1545 report_wrongway_fh(gv, '<');
1546 else if (ckWARN(WARN_CLOSED))
1548 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1552 do_sprintf(sv, SP - MARK, MARK + 1);
1553 if (!do_print(sv, fp))
1556 if (IoFLAGS(io) & IOf_FLUSH)
1557 if (PerlIO_flush(fp) == EOF)
1568 PUSHs(&PL_sv_undef);
1576 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1577 const int mode = POPi;
1578 SV * const sv = POPs;
1579 GV * const gv = MUTABLE_GV(POPs);
1582 /* Need TIEHANDLE method ? */
1583 const char * const tmps = SvPV_const(sv, len);
1584 /* FIXME? do_open should do const */
1585 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1586 IoLINES(GvIOp(gv)) = 0;
1590 PUSHs(&PL_sv_undef);
1597 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1611 bool charstart = FALSE;
1612 STRLEN charskip = 0;
1615 GV * const gv = MUTABLE_GV(*++MARK);
1616 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1617 && gv && (io = GvIO(gv)) )
1619 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1621 return Perl_tied_method(aTHX_ "READ", mark - 1, MUTABLE_SV(io), mg,
1622 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1631 sv_setpvs(bufsv, "");
1632 length = SvIVx(*++MARK);
1634 DIE(aTHX_ "Negative length");
1637 offset = SvIVx(*++MARK);
1641 if (!io || !IoIFP(io)) {
1643 SETERRNO(EBADF,RMS_IFI);
1646 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1647 buffer = SvPVutf8_force(bufsv, blen);
1648 /* UTF-8 may not have been set if they are all low bytes */
1653 buffer = SvPV_force(bufsv, blen);
1654 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1656 if (DO_UTF8(bufsv)) {
1657 /* offset adjust in characters not bytes */
1658 /* SV's length cache is only safe for non-magical values */
1659 if (SvGMAGICAL(bufsv))
1660 blen = utf8_length((const U8 *)buffer, (const U8 *)buffer + blen);
1662 blen = sv_len_utf8(bufsv);
1671 if (PL_op->op_type == OP_RECV) {
1672 Sock_size_t bufsize;
1673 char namebuf[MAXPATHLEN];
1674 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1675 bufsize = sizeof (struct sockaddr_in);
1677 bufsize = sizeof namebuf;
1679 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1683 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1684 /* 'offset' means 'flags' here */
1685 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1686 (struct sockaddr *)namebuf, &bufsize);
1689 /* MSG_TRUNC can give oversized count; quietly lose it */
1693 /* Bogus return without padding */
1694 bufsize = sizeof (struct sockaddr_in);
1696 SvCUR_set(bufsv, count);
1697 *SvEND(bufsv) = '\0';
1698 (void)SvPOK_only(bufsv);
1702 /* This should not be marked tainted if the fp is marked clean */
1703 if (!(IoFLAGS(io) & IOf_UNTAINT))
1704 SvTAINTED_on(bufsv);
1706 sv_setpvn(TARG, namebuf, bufsize);
1712 if (-offset > (SSize_t)blen)
1713 DIE(aTHX_ "Offset outside string");
1716 if (DO_UTF8(bufsv)) {
1717 /* convert offset-as-chars to offset-as-bytes */
1718 if (offset >= (SSize_t)blen)
1719 offset += SvCUR(bufsv) - blen;
1721 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1724 orig_size = SvCUR(bufsv);
1725 /* Allocating length + offset + 1 isn't perfect in the case of reading
1726 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1728 (should be 2 * length + offset + 1, or possibly something longer if
1729 PL_encoding is true) */
1730 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1731 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1732 Zero(buffer+orig_size, offset-orig_size, char);
1734 buffer = buffer + offset;
1736 read_target = bufsv;
1738 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1739 concatenate it to the current buffer. */
1741 /* Truncate the existing buffer to the start of where we will be
1743 SvCUR_set(bufsv, offset);
1745 read_target = sv_newmortal();
1746 SvUPGRADE(read_target, SVt_PV);
1747 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1750 if (PL_op->op_type == OP_SYSREAD) {
1751 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1752 if (IoTYPE(io) == IoTYPE_SOCKET) {
1753 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1759 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1764 #ifdef HAS_SOCKET__bad_code_maybe
1765 if (IoTYPE(io) == IoTYPE_SOCKET) {
1766 Sock_size_t bufsize;
1767 char namebuf[MAXPATHLEN];
1768 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1769 bufsize = sizeof (struct sockaddr_in);
1771 bufsize = sizeof namebuf;
1773 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1774 (struct sockaddr *)namebuf, &bufsize);
1779 count = PerlIO_read(IoIFP(io), buffer, length);
1780 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1781 if (count == 0 && PerlIO_error(IoIFP(io)))
1785 if (IoTYPE(io) == IoTYPE_WRONLY)
1786 report_wrongway_fh(gv, '>');
1789 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1790 *SvEND(read_target) = '\0';
1791 (void)SvPOK_only(read_target);
1792 if (fp_utf8 && !IN_BYTES) {
1793 /* Look at utf8 we got back and count the characters */
1794 const char *bend = buffer + count;
1795 while (buffer < bend) {
1797 skip = UTF8SKIP(buffer);
1800 if (buffer - charskip + skip > bend) {
1801 /* partial character - try for rest of it */
1802 length = skip - (bend-buffer);
1803 offset = bend - SvPVX_const(bufsv);
1815 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1816 provided amount read (count) was what was requested (length)
1818 if (got < wanted && count == length) {
1819 length = wanted - got;
1820 offset = bend - SvPVX_const(bufsv);
1823 /* return value is character count */
1827 else if (buffer_utf8) {
1828 /* Let svcatsv upgrade the bytes we read in to utf8.
1829 The buffer is a mortal so will be freed soon. */
1830 sv_catsv_nomg(bufsv, read_target);
1833 /* This should not be marked tainted if the fp is marked clean */
1834 if (!(IoFLAGS(io) & IOf_UNTAINT))
1835 SvTAINTED_on(bufsv);
1847 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1852 STRLEN orig_blen_bytes;
1853 const int op_type = PL_op->op_type;
1856 GV *const gv = MUTABLE_GV(*++MARK);
1857 IO *const io = GvIO(gv);
1859 if (op_type == OP_SYSWRITE && io) {
1860 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1862 if (MARK == SP - 1) {
1864 mXPUSHi(sv_len(sv));
1868 return Perl_tied_method(aTHX_ "WRITE", mark - 1, MUTABLE_SV(io), mg,
1869 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1879 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1881 if (io && IoIFP(io))
1882 report_wrongway_fh(gv, '<');
1885 SETERRNO(EBADF,RMS_IFI);
1889 /* Do this first to trigger any overloading. */
1890 buffer = SvPV_const(bufsv, blen);
1891 orig_blen_bytes = blen;
1892 doing_utf8 = DO_UTF8(bufsv);
1894 if (PerlIO_isutf8(IoIFP(io))) {
1895 if (!SvUTF8(bufsv)) {
1896 /* We don't modify the original scalar. */
1897 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1898 buffer = (char *) tmpbuf;
1902 else if (doing_utf8) {
1903 STRLEN tmplen = blen;
1904 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1907 buffer = (char *) tmpbuf;
1911 assert((char *)result == buffer);
1912 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1917 if (op_type == OP_SEND) {
1918 const int flags = SvIVx(*++MARK);
1921 char * const sockbuf = SvPVx(*++MARK, mlen);
1922 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1923 flags, (struct sockaddr *)sockbuf, mlen);
1927 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1933 Size_t length = 0; /* This length is in characters. */
1939 /* The SV is bytes, and we've had to upgrade it. */
1940 blen_chars = orig_blen_bytes;
1942 /* The SV really is UTF-8. */
1943 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1944 /* Don't call sv_len_utf8 again because it will call magic
1945 or overloading a second time, and we might get back a
1946 different result. */
1947 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1949 /* It's safe, and it may well be cached. */
1950 blen_chars = sv_len_utf8(bufsv);
1958 length = blen_chars;
1960 #if Size_t_size > IVSIZE
1961 length = (Size_t)SvNVx(*++MARK);
1963 length = (Size_t)SvIVx(*++MARK);
1965 if ((SSize_t)length < 0) {
1967 DIE(aTHX_ "Negative length");
1972 offset = SvIVx(*++MARK);
1974 if (-offset > (IV)blen_chars) {
1976 DIE(aTHX_ "Offset outside string");
1978 offset += blen_chars;
1979 } else if (offset > (IV)blen_chars) {
1981 DIE(aTHX_ "Offset outside string");
1985 if (length > blen_chars - offset)
1986 length = blen_chars - offset;
1988 /* Here we convert length from characters to bytes. */
1989 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1990 /* Either we had to convert the SV, or the SV is magical, or
1991 the SV has overloading, in which case we can't or mustn't
1992 or mustn't call it again. */
1994 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1995 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1997 /* It's a real UTF-8 SV, and it's not going to change under
1998 us. Take advantage of any cache. */
2000 I32 len_I32 = length;
2002 /* Convert the start and end character positions to bytes.
2003 Remember that the second argument to sv_pos_u2b is relative
2005 sv_pos_u2b(bufsv, &start, &len_I32);
2012 buffer = buffer+offset;
2014 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2015 if (IoTYPE(io) == IoTYPE_SOCKET) {
2016 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
2022 /* See the note at doio.c:do_print about filesize limits. --jhi */
2023 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2032 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2035 #if Size_t_size > IVSIZE
2055 * in Perl 5.12 and later, the additional parameter is a bitmask:
2058 * 2 = eof() <- ARGV magic
2060 * I'll rely on the compiler's trace flow analysis to decide whether to
2061 * actually assign this out here, or punt it into the only block where it is
2062 * used. Doing it out here is DRY on the condition logic.
2067 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2073 if (PL_op->op_flags & OPf_SPECIAL) {
2074 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2078 gv = PL_last_in_gv; /* eof */
2086 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2087 return tied_method1("EOF", SP, MUTABLE_SV(io), mg, newSVuv(which));
2090 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2091 if (io && !IoIFP(io)) {
2092 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2094 IoFLAGS(io) &= ~IOf_START;
2095 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2097 sv_setpvs(GvSV(gv), "-");
2099 GvSV(gv) = newSVpvs("-");
2100 SvSETMAGIC(GvSV(gv));
2102 else if (!nextargv(gv))
2107 PUSHs(boolSV(do_eof(gv)));
2117 if (MAXARG != 0 && (TOPs || POPs))
2118 PL_last_in_gv = MUTABLE_GV(POPs);
2125 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2127 return tied_method0("TELL", SP, MUTABLE_SV(io), mg);
2132 SETERRNO(EBADF,RMS_IFI);
2137 #if LSEEKSIZE > IVSIZE
2138 PUSHn( do_tell(gv) );
2140 PUSHi( do_tell(gv) );
2148 const int whence = POPi;
2149 #if LSEEKSIZE > IVSIZE
2150 const Off_t offset = (Off_t)SvNVx(POPs);
2152 const Off_t offset = (Off_t)SvIVx(POPs);
2155 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2156 IO *const io = GvIO(gv);
2159 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2161 #if LSEEKSIZE > IVSIZE
2162 SV *const offset_sv = newSVnv((NV) offset);
2164 SV *const offset_sv = newSViv(offset);
2167 return tied_method2("SEEK", SP, MUTABLE_SV(io), mg, offset_sv,
2172 if (PL_op->op_type == OP_SEEK)
2173 PUSHs(boolSV(do_seek(gv, offset, whence)));
2175 const Off_t sought = do_sysseek(gv, offset, whence);
2177 PUSHs(&PL_sv_undef);
2179 SV* const sv = sought ?
2180 #if LSEEKSIZE > IVSIZE
2185 : newSVpvn(zero_but_true, ZBTLEN);
2196 /* There seems to be no consensus on the length type of truncate()
2197 * and ftruncate(), both off_t and size_t have supporters. In
2198 * general one would think that when using large files, off_t is
2199 * at least as wide as size_t, so using an off_t should be okay. */
2200 /* XXX Configure probe for the length type of *truncate() needed XXX */
2203 #if Off_t_size > IVSIZE
2208 /* Checking for length < 0 is problematic as the type might or
2209 * might not be signed: if it is not, clever compilers will moan. */
2210 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2213 SV * const sv = POPs;
2218 if (PL_op->op_flags & OPf_SPECIAL
2219 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2220 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2227 TAINT_PROPER("truncate");
2228 if (!(fp = IoIFP(io))) {
2234 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2236 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2242 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2243 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2244 goto do_ftruncate_io;
2247 const char * const name = SvPV_nomg_const_nolen(sv);
2248 TAINT_PROPER("truncate");
2250 if (truncate(name, len) < 0)
2254 const int tmpfd = PerlLIO_open(name, O_RDWR);
2259 if (my_chsize(tmpfd, len) < 0)
2261 PerlLIO_close(tmpfd);
2270 SETERRNO(EBADF,RMS_IFI);
2278 SV * const argsv = POPs;
2279 const unsigned int func = POPu;
2280 const int optype = PL_op->op_type;
2281 GV * const gv = MUTABLE_GV(POPs);
2282 IO * const io = gv ? GvIOn(gv) : NULL;
2286 if (!io || !argsv || !IoIFP(io)) {
2288 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2292 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2295 s = SvPV_force(argsv, len);
2296 need = IOCPARM_LEN(func);
2298 s = Sv_Grow(argsv, need + 1);
2299 SvCUR_set(argsv, need);
2302 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2305 retval = SvIV(argsv);
2306 s = INT2PTR(char*,retval); /* ouch */
2309 TAINT_PROPER(PL_op_desc[optype]);
2311 if (optype == OP_IOCTL)
2313 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2315 DIE(aTHX_ "ioctl is not implemented");
2319 DIE(aTHX_ "fcntl is not implemented");
2321 #if defined(OS2) && defined(__EMX__)
2322 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2324 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2328 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2330 if (s[SvCUR(argsv)] != 17)
2331 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2333 s[SvCUR(argsv)] = 0; /* put our null back */
2334 SvSETMAGIC(argsv); /* Assume it has changed */
2343 PUSHp(zero_but_true, ZBTLEN);
2354 const int argtype = POPi;
2355 GV * const gv = MUTABLE_GV(POPs);
2356 IO *const io = GvIO(gv);
2357 PerlIO *const fp = io ? IoIFP(io) : NULL;
2359 /* XXX Looks to me like io is always NULL at this point */
2361 (void)PerlIO_flush(fp);
2362 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2367 SETERRNO(EBADF,RMS_IFI);
2372 DIE(aTHX_ PL_no_func, "flock()");
2383 const int protocol = POPi;
2384 const int type = POPi;
2385 const int domain = POPi;
2386 GV * const gv = MUTABLE_GV(POPs);
2387 register IO * const io = gv ? GvIOn(gv) : NULL;
2392 if (io && IoIFP(io))
2393 do_close(gv, FALSE);
2394 SETERRNO(EBADF,LIB_INVARG);
2399 do_close(gv, FALSE);
2401 TAINT_PROPER("socket");
2402 fd = PerlSock_socket(domain, type, protocol);
2405 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2406 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2407 IoTYPE(io) = IoTYPE_SOCKET;
2408 if (!IoIFP(io) || !IoOFP(io)) {
2409 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2410 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2411 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2414 #if defined(HAS_FCNTL) && defined(F_SETFD)
2415 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2419 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2428 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2430 const int protocol = POPi;
2431 const int type = POPi;
2432 const int domain = POPi;
2433 GV * const gv2 = MUTABLE_GV(POPs);
2434 GV * const gv1 = MUTABLE_GV(POPs);
2435 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2436 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2440 report_evil_fh(gv1);
2442 report_evil_fh(gv2);
2444 if (io1 && IoIFP(io1))
2445 do_close(gv1, FALSE);
2446 if (io2 && IoIFP(io2))
2447 do_close(gv2, FALSE);
2452 TAINT_PROPER("socketpair");
2453 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2455 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2456 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2457 IoTYPE(io1) = IoTYPE_SOCKET;
2458 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2459 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2460 IoTYPE(io2) = IoTYPE_SOCKET;
2461 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2462 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2463 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2464 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2465 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2466 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2467 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2470 #if defined(HAS_FCNTL) && defined(F_SETFD)
2471 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2472 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2477 DIE(aTHX_ PL_no_sock_func, "socketpair");
2486 SV * const addrsv = POPs;
2487 /* OK, so on what platform does bind modify addr? */
2489 GV * const gv = MUTABLE_GV(POPs);
2490 register IO * const io = GvIOn(gv);
2492 const int op_type = PL_op->op_type;
2494 if (!io || !IoIFP(io))
2497 addr = SvPV_const(addrsv, len);
2498 TAINT_PROPER(PL_op_desc[op_type]);
2499 if ((op_type == OP_BIND
2500 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2501 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2509 SETERRNO(EBADF,SS_IVCHAN);
2516 const int backlog = POPi;
2517 GV * const gv = MUTABLE_GV(POPs);
2518 register IO * const io = gv ? GvIOn(gv) : NULL;
2520 if (!io || !IoIFP(io))
2523 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2530 SETERRNO(EBADF,SS_IVCHAN);
2539 char namebuf[MAXPATHLEN];
2540 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2541 Sock_size_t len = sizeof (struct sockaddr_in);
2543 Sock_size_t len = sizeof namebuf;
2545 GV * const ggv = MUTABLE_GV(POPs);
2546 GV * const ngv = MUTABLE_GV(POPs);
2555 if (!gstio || !IoIFP(gstio))
2559 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2562 /* Some platforms indicate zero length when an AF_UNIX client is
2563 * not bound. Simulate a non-zero-length sockaddr structure in
2565 namebuf[0] = 0; /* sun_len */
2566 namebuf[1] = AF_UNIX; /* sun_family */
2574 do_close(ngv, FALSE);
2575 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2576 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2577 IoTYPE(nstio) = IoTYPE_SOCKET;
2578 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2579 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2580 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2581 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2584 #if defined(HAS_FCNTL) && defined(F_SETFD)
2585 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2589 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2590 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2592 #ifdef __SCO_VERSION__
2593 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2596 PUSHp(namebuf, len);
2600 report_evil_fh(ggv);
2601 SETERRNO(EBADF,SS_IVCHAN);
2611 const int how = POPi;
2612 GV * const gv = MUTABLE_GV(POPs);
2613 register IO * const io = GvIOn(gv);
2615 if (!io || !IoIFP(io))
2618 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2623 SETERRNO(EBADF,SS_IVCHAN);
2630 const int optype = PL_op->op_type;
2631 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2632 const unsigned int optname = (unsigned int) POPi;
2633 const unsigned int lvl = (unsigned int) POPi;
2634 GV * const gv = MUTABLE_GV(POPs);
2635 register IO * const io = GvIOn(gv);
2639 if (!io || !IoIFP(io))
2642 fd = PerlIO_fileno(IoIFP(io));
2646 (void)SvPOK_only(sv);
2650 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2657 #if defined(__SYMBIAN32__)
2658 # define SETSOCKOPT_OPTION_VALUE_T void *
2660 # define SETSOCKOPT_OPTION_VALUE_T const char *
2662 /* XXX TODO: We need to have a proper type (a Configure probe,
2663 * etc.) for what the C headers think of the third argument of
2664 * setsockopt(), the option_value read-only buffer: is it
2665 * a "char *", or a "void *", const or not. Some compilers
2666 * don't take kindly to e.g. assuming that "char *" implicitly
2667 * promotes to a "void *", or to explicitly promoting/demoting
2668 * consts to non/vice versa. The "const void *" is the SUS
2669 * definition, but that does not fly everywhere for the above
2671 SETSOCKOPT_OPTION_VALUE_T buf;
2675 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2679 aint = (int)SvIV(sv);
2680 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2683 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2693 SETERRNO(EBADF,SS_IVCHAN);
2702 const int optype = PL_op->op_type;
2703 GV * const gv = MUTABLE_GV(POPs);
2704 register IO * const io = GvIOn(gv);
2709 if (!io || !IoIFP(io))
2712 sv = sv_2mortal(newSV(257));
2713 (void)SvPOK_only(sv);
2717 fd = PerlIO_fileno(IoIFP(io));
2719 case OP_GETSOCKNAME:
2720 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2723 case OP_GETPEERNAME:
2724 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2726 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2728 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";
2729 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2730 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2731 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2732 sizeof(u_short) + sizeof(struct in_addr))) {
2739 #ifdef BOGUS_GETNAME_RETURN
2740 /* Interactive Unix, getpeername() and getsockname()
2741 does not return valid namelen */
2742 if (len == BOGUS_GETNAME_RETURN)
2743 len = sizeof(struct sockaddr);
2752 SETERRNO(EBADF,SS_IVCHAN);
2771 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2772 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2773 if (PL_op->op_type == OP_LSTAT) {
2774 if (gv != PL_defgv) {
2775 do_fstat_warning_check:
2776 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2777 "lstat() on filehandle%s%"SVf,
2780 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2782 } else if (PL_laststype != OP_LSTAT)
2783 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2784 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2787 if (gv != PL_defgv) {
2791 PL_laststype = OP_STAT;
2792 PL_statgv = gv ? gv : (GV *)io;
2793 sv_setpvs(PL_statname, "");
2800 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2802 } else if (IoDIRP(io)) {
2804 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2807 PL_laststatval = -1;
2810 else PL_laststatval = -1;
2811 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2814 if (PL_laststatval < 0) {
2819 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2820 io = MUTABLE_IO(SvRV(sv));
2821 if (PL_op->op_type == OP_LSTAT)
2822 goto do_fstat_warning_check;
2823 goto do_fstat_have_io;
2826 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2827 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2829 PL_laststype = PL_op->op_type;
2830 if (PL_op->op_type == OP_LSTAT)
2831 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2833 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2834 if (PL_laststatval < 0) {
2835 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2836 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2842 if (gimme != G_ARRAY) {
2843 if (gimme != G_VOID)
2844 XPUSHs(boolSV(max));
2850 mPUSHi(PL_statcache.st_dev);
2851 #if ST_INO_SIZE > IVSIZE
2852 mPUSHn(PL_statcache.st_ino);
2854 # if ST_INO_SIGN <= 0
2855 mPUSHi(PL_statcache.st_ino);
2857 mPUSHu(PL_statcache.st_ino);
2860 mPUSHu(PL_statcache.st_mode);
2861 mPUSHu(PL_statcache.st_nlink);
2862 #if Uid_t_size > IVSIZE
2863 mPUSHn(PL_statcache.st_uid);
2865 # if Uid_t_sign <= 0
2866 mPUSHi(PL_statcache.st_uid);
2868 mPUSHu(PL_statcache.st_uid);
2871 #if Gid_t_size > IVSIZE
2872 mPUSHn(PL_statcache.st_gid);
2874 # if Gid_t_sign <= 0
2875 mPUSHi(PL_statcache.st_gid);
2877 mPUSHu(PL_statcache.st_gid);
2880 #ifdef USE_STAT_RDEV
2881 mPUSHi(PL_statcache.st_rdev);
2883 PUSHs(newSVpvs_flags("", SVs_TEMP));
2885 #if Off_t_size > IVSIZE
2886 mPUSHn(PL_statcache.st_size);
2888 mPUSHi(PL_statcache.st_size);
2891 mPUSHn(PL_statcache.st_atime);
2892 mPUSHn(PL_statcache.st_mtime);
2893 mPUSHn(PL_statcache.st_ctime);
2895 mPUSHi(PL_statcache.st_atime);
2896 mPUSHi(PL_statcache.st_mtime);
2897 mPUSHi(PL_statcache.st_ctime);
2899 #ifdef USE_STAT_BLOCKS
2900 mPUSHu(PL_statcache.st_blksize);
2901 mPUSHu(PL_statcache.st_blocks);
2903 PUSHs(newSVpvs_flags("", SVs_TEMP));
2904 PUSHs(newSVpvs_flags("", SVs_TEMP));
2910 /* If the next filetest is stacked up with this one
2911 (PL_op->op_private & OPpFT_STACKING), we leave
2912 the original argument on the stack for success,
2913 and skip the stacked operators on failure.
2914 The next few macros/functions take care of this.
2918 S_ft_stacking_return_false(pTHX_ SV *ret) {
2921 while (OP_IS_FILETEST(next->op_type)
2922 && next->op_private & OPpFT_STACKED)
2923 next = next->op_next;
2924 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
2930 #define FT_RETURN_FALSE(X) \
2932 if (PL_op->op_private & OPpFT_STACKING) \
2933 return S_ft_stacking_return_false(aTHX_ X); \
2934 RETURNX(PL_op->op_flags & OPf_REF ? XPUSHs(X) : SETs(X)); \
2936 #define FT_RETURN_TRUE(X) \
2938 PL_op->op_flags & OPf_REF \
2940 PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (X) \
2942 : (PL_op->op_private & OPpFT_STACKING || SETs(X)) \
2945 #define FT_RETURNNO FT_RETURN_FALSE(&PL_sv_no)
2946 #define FT_RETURNUNDEF FT_RETURN_FALSE(&PL_sv_undef)
2947 #define FT_RETURNYES FT_RETURN_TRUE(&PL_sv_yes)
2949 #define tryAMAGICftest_MG(chr) STMT_START { \
2950 if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
2951 && PL_op->op_flags & OPf_KIDS) { \
2952 OP *next = S_try_amagic_ftest(aTHX_ chr); \
2953 if (next) return next; \
2958 S_try_amagic_ftest(pTHX_ char chr) {
2961 SV* const arg = TOPs;
2964 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
2968 const char tmpchr = chr;
2969 SV * const tmpsv = amagic_call(arg,
2970 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2971 ftest_amg, AMGf_unary);
2976 if (SvTRUE(tmpsv)) FT_RETURN_TRUE(tmpsv);
2977 FT_RETURN_FALSE(tmpsv);
2987 /* Not const, because things tweak this below. Not bool, because there's
2988 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2989 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2990 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2991 /* Giving some sort of initial value silences compilers. */
2993 int access_mode = R_OK;
2995 int access_mode = 0;
2998 /* access_mode is never used, but leaving use_access in makes the
2999 conditional compiling below much clearer. */
3002 Mode_t stat_mode = S_IRUSR;
3004 bool effective = FALSE;
3008 switch (PL_op->op_type) {
3009 case OP_FTRREAD: opchar = 'R'; break;
3010 case OP_FTRWRITE: opchar = 'W'; break;
3011 case OP_FTREXEC: opchar = 'X'; break;
3012 case OP_FTEREAD: opchar = 'r'; break;
3013 case OP_FTEWRITE: opchar = 'w'; break;
3014 case OP_FTEEXEC: opchar = 'x'; break;
3016 tryAMAGICftest_MG(opchar);
3018 switch (PL_op->op_type) {
3020 #if !(defined(HAS_ACCESS) && defined(R_OK))
3026 #if defined(HAS_ACCESS) && defined(W_OK)
3031 stat_mode = S_IWUSR;
3035 #if defined(HAS_ACCESS) && defined(X_OK)
3040 stat_mode = S_IXUSR;
3044 #ifdef PERL_EFF_ACCESS
3047 stat_mode = S_IWUSR;
3051 #ifndef PERL_EFF_ACCESS
3058 #ifdef PERL_EFF_ACCESS
3063 stat_mode = S_IXUSR;
3069 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3070 const char *name = TOPpx;
3072 # ifdef PERL_EFF_ACCESS
3073 result = PERL_EFF_ACCESS(name, access_mode);
3075 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3081 result = access(name, access_mode);
3083 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3094 result = my_stat_flags(0);
3097 if (cando(stat_mode, effective, &PL_statcache))
3106 const int op_type = PL_op->op_type;
3111 case OP_FTIS: opchar = 'e'; break;
3112 case OP_FTSIZE: opchar = 's'; break;
3113 case OP_FTMTIME: opchar = 'M'; break;
3114 case OP_FTCTIME: opchar = 'C'; break;
3115 case OP_FTATIME: opchar = 'A'; break;
3117 tryAMAGICftest_MG(opchar);
3119 result = my_stat_flags(0);
3122 if (op_type == OP_FTIS)
3125 /* You can't dTARGET inside OP_FTIS, because you'll get
3126 "panic: pad_sv po" - the op is not flagged to have a target. */
3130 #if Off_t_size > IVSIZE
3131 sv_setnv(TARG, (NV)PL_statcache.st_size);
3133 sv_setiv(TARG, (IV)PL_statcache.st_size);
3138 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3142 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3146 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3150 if (SvTRUE_nomg(TARG)) FT_RETURN_TRUE(TARG);
3151 else FT_RETURN_FALSE(TARG);
3162 switch (PL_op->op_type) {
3163 case OP_FTROWNED: opchar = 'O'; break;
3164 case OP_FTEOWNED: opchar = 'o'; break;
3165 case OP_FTZERO: opchar = 'z'; break;
3166 case OP_FTSOCK: opchar = 'S'; break;
3167 case OP_FTCHR: opchar = 'c'; break;
3168 case OP_FTBLK: opchar = 'b'; break;
3169 case OP_FTFILE: opchar = 'f'; break;
3170 case OP_FTDIR: opchar = 'd'; break;
3171 case OP_FTPIPE: opchar = 'p'; break;
3172 case OP_FTSUID: opchar = 'u'; break;
3173 case OP_FTSGID: opchar = 'g'; break;
3174 case OP_FTSVTX: opchar = 'k'; break;
3176 tryAMAGICftest_MG(opchar);
3178 /* I believe that all these three are likely to be defined on most every
3179 system these days. */
3181 if(PL_op->op_type == OP_FTSUID) {
3186 if(PL_op->op_type == OP_FTSGID) {
3191 if(PL_op->op_type == OP_FTSVTX) {
3196 result = my_stat_flags(0);
3199 switch (PL_op->op_type) {
3201 if (PL_statcache.st_uid == PerlProc_getuid())
3205 if (PL_statcache.st_uid == PerlProc_geteuid())
3209 if (PL_statcache.st_size == 0)
3213 if (S_ISSOCK(PL_statcache.st_mode))
3217 if (S_ISCHR(PL_statcache.st_mode))
3221 if (S_ISBLK(PL_statcache.st_mode))
3225 if (S_ISREG(PL_statcache.st_mode))
3229 if (S_ISDIR(PL_statcache.st_mode))
3233 if (S_ISFIFO(PL_statcache.st_mode))
3238 if (PL_statcache.st_mode & S_ISUID)
3244 if (PL_statcache.st_mode & S_ISGID)
3250 if (PL_statcache.st_mode & S_ISVTX)
3264 tryAMAGICftest_MG('l');
3265 result = my_lstat_flags(0);
3269 if (S_ISLNK(PL_statcache.st_mode))
3283 tryAMAGICftest_MG('t');
3285 if (PL_op->op_flags & OPf_REF)
3289 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3290 name = SvPV_nomg(tmpsv, namelen);
3291 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3295 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3296 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3297 else if (name && isDIGIT(*name))
3301 if (PerlLIO_isatty(fd))
3306 #if defined(atarist) /* this will work with atariST. Configure will
3307 make guesses for other systems. */
3308 # define FILE_base(f) ((f)->_base)
3309 # define FILE_ptr(f) ((f)->_ptr)
3310 # define FILE_cnt(f) ((f)->_cnt)
3311 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3322 register STDCHAR *s;
3324 register SV *sv = NULL;
3328 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3330 if (PL_op->op_flags & OPf_REF)
3332 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3337 gv = MAYBE_DEREF_GV_nomg(sv);
3341 if (gv == PL_defgv) {
3343 io = SvTYPE(PL_statgv) == SVt_PVIO
3347 goto really_filename;
3352 sv_setpvs(PL_statname, "");
3353 io = GvIO(PL_statgv);
3355 PL_laststatval = -1;
3356 PL_laststype = OP_STAT;
3357 if (io && IoIFP(io)) {
3358 if (! PerlIO_has_base(IoIFP(io)))
3359 DIE(aTHX_ "-T and -B not implemented on filehandles");
3360 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3361 if (PL_laststatval < 0)
3363 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3364 if (PL_op->op_type == OP_FTTEXT)
3369 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3370 i = PerlIO_getc(IoIFP(io));
3372 (void)PerlIO_ungetc(IoIFP(io),i);
3374 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3376 len = PerlIO_get_bufsiz(IoIFP(io));
3377 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3378 /* sfio can have large buffers - limit to 512 */
3383 SETERRNO(EBADF,RMS_IFI);
3385 SETERRNO(EBADF,RMS_IFI);
3390 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3393 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3395 PL_laststatval = -1;
3396 PL_laststype = OP_STAT;
3398 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3400 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3403 PL_laststype = OP_STAT;
3404 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3405 if (PL_laststatval < 0) {
3406 (void)PerlIO_close(fp);
3409 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3410 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3411 (void)PerlIO_close(fp);
3413 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3414 FT_RETURNNO; /* special case NFS directories */
3415 FT_RETURNYES; /* null file is anything */
3420 /* now scan s to look for textiness */
3421 /* XXX ASCII dependent code */
3423 #if defined(DOSISH) || defined(USEMYBINMODE)
3424 /* ignore trailing ^Z on short files */
3425 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3429 for (i = 0; i < len; i++, s++) {
3430 if (!*s) { /* null never allowed in text */
3435 else if (!(isPRINT(*s) || isSPACE(*s)))
3438 else if (*s & 128) {
3440 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3443 /* utf8 characters don't count as odd */
3444 if (UTF8_IS_START(*s)) {
3445 int ulen = UTF8SKIP(s);
3446 if (ulen < len - i) {
3448 for (j = 1; j < ulen; j++) {
3449 if (!UTF8_IS_CONTINUATION(s[j]))
3452 --ulen; /* loop does extra increment */
3462 *s != '\n' && *s != '\r' && *s != '\b' &&
3463 *s != '\t' && *s != '\f' && *s != 27)
3468 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3479 const char *tmps = NULL;
3483 SV * const sv = POPs;
3484 if (PL_op->op_flags & OPf_SPECIAL) {
3485 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3487 else if (!(gv = MAYBE_DEREF_GV(sv)))
3488 tmps = SvPV_nomg_const_nolen(sv);
3491 if( !gv && (!tmps || !*tmps) ) {
3492 HV * const table = GvHVn(PL_envgv);
3495 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3496 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3498 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3503 deprecate("chdir('') or chdir(undef) as chdir()");
3504 tmps = SvPV_nolen_const(*svp);
3508 TAINT_PROPER("chdir");
3513 TAINT_PROPER("chdir");
3516 IO* const io = GvIO(gv);
3519 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3520 } else if (IoIFP(io)) {
3521 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3525 SETERRNO(EBADF, RMS_IFI);
3531 SETERRNO(EBADF,RMS_IFI);
3535 DIE(aTHX_ PL_no_func, "fchdir");
3539 PUSHi( PerlDir_chdir(tmps) >= 0 );
3541 /* Clear the DEFAULT element of ENV so we'll get the new value
3543 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3550 dVAR; dSP; dMARK; dTARGET;
3551 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3562 char * const tmps = POPpx;
3563 TAINT_PROPER("chroot");
3564 PUSHi( chroot(tmps) >= 0 );
3567 DIE(aTHX_ PL_no_func, "chroot");
3575 const char * const tmps2 = POPpconstx;
3576 const char * const tmps = SvPV_nolen_const(TOPs);
3577 TAINT_PROPER("rename");
3579 anum = PerlLIO_rename(tmps, tmps2);
3581 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3582 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3585 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3586 (void)UNLINK(tmps2);
3587 if (!(anum = link(tmps, tmps2)))
3588 anum = UNLINK(tmps);
3596 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3600 const int op_type = PL_op->op_type;
3604 if (op_type == OP_LINK)
3605 DIE(aTHX_ PL_no_func, "link");
3607 # ifndef HAS_SYMLINK
3608 if (op_type == OP_SYMLINK)
3609 DIE(aTHX_ PL_no_func, "symlink");
3613 const char * const tmps2 = POPpconstx;
3614 const char * const tmps = SvPV_nolen_const(TOPs);
3615 TAINT_PROPER(PL_op_desc[op_type]);
3617 # if defined(HAS_LINK)
3618 # if defined(HAS_SYMLINK)
3619 /* Both present - need to choose which. */
3620 (op_type == OP_LINK) ?
3621 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3623 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3624 PerlLIO_link(tmps, tmps2);
3627 # if defined(HAS_SYMLINK)
3628 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3629 symlink(tmps, tmps2);
3634 SETi( result >= 0 );
3641 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3652 char buf[MAXPATHLEN];
3655 #ifndef INCOMPLETE_TAINTS
3659 len = readlink(tmps, buf, sizeof(buf) - 1);
3666 RETSETUNDEF; /* just pretend it's a normal file */
3670 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3672 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3674 char * const save_filename = filename;
3679 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3681 PERL_ARGS_ASSERT_DOONELINER;
3683 Newx(cmdline, size, char);
3684 my_strlcpy(cmdline, cmd, size);
3685 my_strlcat(cmdline, " ", size);
3686 for (s = cmdline + strlen(cmdline); *filename; ) {
3690 if (s - cmdline < size)
3691 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3692 myfp = PerlProc_popen(cmdline, "r");
3696 SV * const tmpsv = sv_newmortal();
3697 /* Need to save/restore 'PL_rs' ?? */
3698 s = sv_gets(tmpsv, myfp, 0);
3699 (void)PerlProc_pclose(myfp);
3703 #ifdef HAS_SYS_ERRLIST
3708 /* you don't see this */
3709 const char * const errmsg =
3710 #ifdef HAS_SYS_ERRLIST
3718 if (instr(s, errmsg)) {
3725 #define EACCES EPERM
3727 if (instr(s, "cannot make"))
3728 SETERRNO(EEXIST,RMS_FEX);
3729 else if (instr(s, "existing file"))
3730 SETERRNO(EEXIST,RMS_FEX);
3731 else if (instr(s, "ile exists"))
3732 SETERRNO(EEXIST,RMS_FEX);
3733 else if (instr(s, "non-exist"))
3734 SETERRNO(ENOENT,RMS_FNF);
3735 else if (instr(s, "does not exist"))
3736 SETERRNO(ENOENT,RMS_FNF);
3737 else if (instr(s, "not empty"))
3738 SETERRNO(EBUSY,SS_DEVOFFLINE);
3739 else if (instr(s, "cannot access"))
3740 SETERRNO(EACCES,RMS_PRV);
3742 SETERRNO(EPERM,RMS_PRV);
3745 else { /* some mkdirs return no failure indication */
3746 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3747 if (PL_op->op_type == OP_RMDIR)
3752 SETERRNO(EACCES,RMS_PRV); /* a guess */
3761 /* This macro removes trailing slashes from a directory name.
3762 * Different operating and file systems take differently to
3763 * trailing slashes. According to POSIX 1003.1 1996 Edition
3764 * any number of trailing slashes should be allowed.
3765 * Thusly we snip them away so that even non-conforming
3766 * systems are happy.
3767 * We should probably do this "filtering" for all
3768 * the functions that expect (potentially) directory names:
3769 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3770 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3772 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3773 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3776 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3777 (tmps) = savepvn((tmps), (len)); \
3787 const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3789 TRIMSLASHES(tmps,len,copy);
3791 TAINT_PROPER("mkdir");
3793 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3797 SETi( dooneliner("mkdir", tmps) );
3798 oldumask = PerlLIO_umask(0);
3799 PerlLIO_umask(oldumask);
3800 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3815 TRIMSLASHES(tmps,len,copy);
3816 TAINT_PROPER("rmdir");
3818 SETi( PerlDir_rmdir(tmps) >= 0 );
3820 SETi( dooneliner("rmdir", tmps) );
3827 /* Directory calls. */
3831 #if defined(Direntry_t) && defined(HAS_READDIR)
3833 const char * const dirname = POPpconstx;
3834 GV * const gv = MUTABLE_GV(POPs);
3835 register IO * const io = GvIOn(gv);
3840 if ((IoIFP(io) || IoOFP(io)))
3841 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3842 "Opening filehandle %"HEKf" also as a directory",
3843 HEKfARG(GvENAME_HEK(gv)) );
3845 PerlDir_close(IoDIRP(io));
3846 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3852 SETERRNO(EBADF,RMS_DIR);
3855 DIE(aTHX_ PL_no_dir_func, "opendir");
3861 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3862 DIE(aTHX_ PL_no_dir_func, "readdir");
3864 #if !defined(I_DIRENT) && !defined(VMS)
3865 Direntry_t *readdir (DIR *);
3871 const I32 gimme = GIMME;
3872 GV * const gv = MUTABLE_GV(POPs);
3873 register const Direntry_t *dp;
3874 register IO * const io = GvIOn(gv);
3876 if (!io || !IoDIRP(io)) {
3877 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3878 "readdir() attempted on invalid dirhandle %"HEKf,
3879 HEKfARG(GvENAME_HEK(gv)));
3884 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3888 sv = newSVpvn(dp->d_name, dp->d_namlen);
3890 sv = newSVpv(dp->d_name, 0);
3892 #ifndef INCOMPLETE_TAINTS
3893 if (!(IoFLAGS(io) & IOf_UNTAINT))
3897 } while (gimme == G_ARRAY);
3899 if (!dp && gimme != G_ARRAY)
3906 SETERRNO(EBADF,RMS_ISI);
3907 if (GIMME == G_ARRAY)
3916 #if defined(HAS_TELLDIR) || defined(telldir)
3918 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3919 /* XXX netbsd still seemed to.
3920 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3921 --JHI 1999-Feb-02 */
3922 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3923 long telldir (DIR *);
3925 GV * const gv = MUTABLE_GV(POPs);
3926 register IO * const io = GvIOn(gv);
3928 if (!io || !IoDIRP(io)) {
3929 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3930 "telldir() attempted on invalid dirhandle %"HEKf,
3931 HEKfARG(GvENAME_HEK(gv)));
3935 PUSHi( PerlDir_tell(IoDIRP(io)) );
3939 SETERRNO(EBADF,RMS_ISI);
3942 DIE(aTHX_ PL_no_dir_func, "telldir");
3948 #if defined(HAS_SEEKDIR) || defined(seekdir)
3950 const long along = POPl;
3951 GV * const gv = MUTABLE_GV(POPs);
3952 register IO * const io = GvIOn(gv);
3954 if (!io || !IoDIRP(io)) {
3955 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3956 "seekdir() attempted on invalid dirhandle %"HEKf,
3957 HEKfARG(GvENAME_HEK(gv)));
3960 (void)PerlDir_seek(IoDIRP(io), along);
3965 SETERRNO(EBADF,RMS_ISI);
3968 DIE(aTHX_ PL_no_dir_func, "seekdir");
3974 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3976 GV * const gv = MUTABLE_GV(POPs);
3977 register IO * const io = GvIOn(gv);
3979 if (!io || !IoDIRP(io)) {
3980 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3981 "rewinddir() attempted on invalid dirhandle %"HEKf,
3982 HEKfARG(GvENAME_HEK(gv)));
3985 (void)PerlDir_rewind(IoDIRP(io));
3989 SETERRNO(EBADF,RMS_ISI);
3992 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3998 #if defined(Direntry_t) && defined(HAS_READDIR)
4000 GV * const gv = MUTABLE_GV(POPs);
4001 register IO * const io = GvIOn(gv);
4003 if (!io || !IoDIRP(io)) {
4004 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4005 "closedir() attempted on invalid dirhandle %"HEKf,
4006 HEKfARG(GvENAME_HEK(gv)));
4009 #ifdef VOID_CLOSEDIR
4010 PerlDir_close(IoDIRP(io));
4012 if (PerlDir_close(IoDIRP(io)) < 0) {
4013 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4022 SETERRNO(EBADF,RMS_IFI);
4025 DIE(aTHX_ PL_no_dir_func, "closedir");
4029 /* Process control. */
4036 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4037 sigset_t oldmask, newmask;
4041 PERL_FLUSHALL_FOR_CHILD;
4042 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4043 sigfillset(&newmask);
4044 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4046 childpid = PerlProc_fork();
4047 if (childpid == 0) {
4051 for (sig = 1; sig < SIG_SIZE; sig++)
4052 PL_psig_pend[sig] = 0;
4054 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4057 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4064 #ifdef PERL_USES_PL_PIDSTATUS
4065 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4071 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4076 PERL_FLUSHALL_FOR_CHILD;
4077 childpid = PerlProc_fork();
4083 DIE(aTHX_ PL_no_func, "fork");
4090 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4095 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4096 childpid = wait4pid(-1, &argflags, 0);
4098 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4103 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4104 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4105 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4107 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4112 DIE(aTHX_ PL_no_func, "wait");
4118 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4120 const int optype = POPi;
4121 const Pid_t pid = TOPi;
4125 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4126 result = wait4pid(pid, &argflags, optype);
4128 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4133 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4134 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4135 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4137 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4142 DIE(aTHX_ PL_no_func, "waitpid");
4148 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4149 #if defined(__LIBCATAMOUNT__)
4150 PL_statusvalue = -1;
4159 while (++MARK <= SP) {
4160 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4165 TAINT_PROPER("system");
4167 PERL_FLUSHALL_FOR_CHILD;
4168 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4173 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4174 sigset_t newset, oldset;
4177 if (PerlProc_pipe(pp) >= 0)
4179 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4180 sigemptyset(&newset);
4181 sigaddset(&newset, SIGCHLD);
4182 sigprocmask(SIG_BLOCK, &newset, &oldset);
4184 while ((childpid = PerlProc_fork()) == -1) {
4185 if (errno != EAGAIN) {
4190 PerlLIO_close(pp[0]);
4191 PerlLIO_close(pp[1]);
4193 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4194 sigprocmask(SIG_SETMASK, &oldset, NULL);
4201 Sigsave_t ihand,qhand; /* place to save signals during system() */
4205 PerlLIO_close(pp[1]);
4207 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4208 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4211 result = wait4pid(childpid, &status, 0);
4212 } while (result == -1 && errno == EINTR);
4214 #ifdef HAS_SIGPROCMASK
4215 sigprocmask(SIG_SETMASK, &oldset, NULL);
4217 (void)rsignal_restore(SIGINT, &ihand);
4218 (void)rsignal_restore(SIGQUIT, &qhand);
4220 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4221 do_execfree(); /* free any memory child malloced on fork */
4228 while (n < sizeof(int)) {
4229 n1 = PerlLIO_read(pp[0],
4230 (void*)(((char*)&errkid)+n),
4236 PerlLIO_close(pp[0]);
4237 if (n) { /* Error */
4238 if (n != sizeof(int))
4239 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4240 errno = errkid; /* Propagate errno from kid */
4241 STATUS_NATIVE_CHILD_SET(-1);
4244 XPUSHi(STATUS_CURRENT);
4247 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4248 sigprocmask(SIG_SETMASK, &oldset, NULL);
4251 PerlLIO_close(pp[0]);
4252 #if defined(HAS_FCNTL) && defined(F_SETFD)
4253 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4256 if (PL_op->op_flags & OPf_STACKED) {
4257 SV * const really = *++MARK;
4258 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4260 else if (SP - MARK != 1)
4261 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4263 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4267 #else /* ! FORK or VMS or OS/2 */
4270 if (PL_op->op_flags & OPf_STACKED) {
4271 SV * const really = *++MARK;
4272 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4273 value = (I32)do_aspawn(really, MARK, SP);
4275 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4278 else if (SP - MARK != 1) {
4279 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4280 value = (I32)do_aspawn(NULL, MARK, SP);
4282 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4286 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4288 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4290 STATUS_NATIVE_CHILD_SET(value);
4293 XPUSHi(result ? value : STATUS_CURRENT);
4294 #endif /* !FORK or VMS or OS/2 */
4301 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4306 while (++MARK <= SP) {
4307 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4312 TAINT_PROPER("exec");
4314 PERL_FLUSHALL_FOR_CHILD;
4315 if (PL_op->op_flags & OPf_STACKED) {
4316 SV * const really = *++MARK;
4317 value = (I32)do_aexec(really, MARK, SP);
4319 else if (SP - MARK != 1)
4321 value = (I32)vms_do_aexec(NULL, MARK, SP);
4325 (void ) do_aspawn(NULL, MARK, SP);
4329 value = (I32)do_aexec(NULL, MARK, SP);
4334 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4337 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4340 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4354 XPUSHi( getppid() );
4357 DIE(aTHX_ PL_no_func, "getppid");
4367 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4370 pgrp = (I32)BSD_GETPGRP(pid);
4372 if (pid != 0 && pid != PerlProc_getpid())
4373 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4379 DIE(aTHX_ PL_no_func, "getpgrp()");
4389 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4390 if (MAXARG > 0) pid = TOPs && TOPi;
4396 TAINT_PROPER("setpgrp");
4398 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4400 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4401 || (pid != 0 && pid != PerlProc_getpid()))
4403 DIE(aTHX_ "setpgrp can't take arguments");
4405 SETi( setpgrp() >= 0 );
4406 #endif /* USE_BSDPGRP */
4409 DIE(aTHX_ PL_no_func, "setpgrp()");
4413 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4414 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4416 # define PRIORITY_WHICH_T(which) which
4421 #ifdef HAS_GETPRIORITY
4423 const int who = POPi;
4424 const int which = TOPi;
4425 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4428 DIE(aTHX_ PL_no_func, "getpriority()");
4434 #ifdef HAS_SETPRIORITY
4436 const int niceval = POPi;
4437 const int who = POPi;
4438 const int which = TOPi;
4439 TAINT_PROPER("setpriority");
4440 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4443 DIE(aTHX_ PL_no_func, "setpriority()");
4447 #undef PRIORITY_WHICH_T
4455 XPUSHn( time(NULL) );
4457 XPUSHi( time(NULL) );
4469 (void)PerlProc_times(&PL_timesbuf);
4471 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4472 /* struct tms, though same data */
4476 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4477 if (GIMME == G_ARRAY) {
4478 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4479 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4480 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4488 if (GIMME == G_ARRAY) {
4495 DIE(aTHX_ "times not implemented");
4497 #endif /* HAS_TIMES */
4500 /* The 32 bit int year limits the times we can represent to these
4501 boundaries with a few days wiggle room to account for time zone
4504 /* Sat Jan 3 00:00:00 -2147481748 */
4505 #define TIME_LOWER_BOUND -67768100567755200.0
4506 /* Sun Dec 29 12:00:00 2147483647 */
4507 #define TIME_UPPER_BOUND 67767976233316800.0
4516 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4517 static const char * const dayname[] =
4518 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4519 static const char * const monname[] =
4520 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4521 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4523 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4526 when = (Time64_T)now;
4529 NV input = Perl_floor(POPn);
4530 when = (Time64_T)input;
4531 if (when != input) {
4532 /* diag_listed_as: gmtime(%f) too large */
4533 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4534 "%s(%.0" NVff ") too large", opname, input);
4538 if ( TIME_LOWER_BOUND > when ) {
4539 /* diag_listed_as: gmtime(%f) too small */
4540 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4541 "%s(%.0" NVff ") too small", opname, when);
4544 else if( when > TIME_UPPER_BOUND ) {
4545 /* diag_listed_as: gmtime(%f) too small */
4546 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4547 "%s(%.0" NVff ") too large", opname, when);
4551 if (PL_op->op_type == OP_LOCALTIME)
4552 err = S_localtime64_r(&when, &tmbuf);
4554 err = S_gmtime64_r(&when, &tmbuf);
4558 /* XXX %lld broken for quads */
4559 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4560 "%s(%.0" NVff ") failed", opname, when);
4563 if (GIMME != G_ARRAY) { /* scalar context */
4565 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4566 double year = (double)tmbuf.tm_year + 1900;
4573 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4574 dayname[tmbuf.tm_wday],
4575 monname[tmbuf.tm_mon],
4583 else { /* list context */
4589 mPUSHi(tmbuf.tm_sec);
4590 mPUSHi(tmbuf.tm_min);
4591 mPUSHi(tmbuf.tm_hour);
4592 mPUSHi(tmbuf.tm_mday);
4593 mPUSHi(tmbuf.tm_mon);
4594 mPUSHn(tmbuf.tm_year);
4595 mPUSHi(tmbuf.tm_wday);
4596 mPUSHi(tmbuf.tm_yday);
4597 mPUSHi(tmbuf.tm_isdst);
4608 anum = alarm((unsigned int)anum);
4614 DIE(aTHX_ PL_no_func, "alarm");
4625 (void)time(&lasttime);
4626 if (MAXARG < 1 || (!TOPs && !POPs))
4630 PerlProc_sleep((unsigned int)duration);
4633 XPUSHi(when - lasttime);
4637 /* Shared memory. */
4638 /* Merged with some message passing. */
4642 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4643 dVAR; dSP; dMARK; dTARGET;
4644 const int op_type = PL_op->op_type;
4649 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4652 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4655 value = (I32)(do_semop(MARK, SP) >= 0);
4658 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4666 return Perl_pp_semget(aTHX);
4674 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4675 dVAR; dSP; dMARK; dTARGET;
4676 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4683 DIE(aTHX_ "System V IPC is not implemented on this machine");
4689 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4690 dVAR; dSP; dMARK; dTARGET;
4691 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4699 PUSHp(zero_but_true, ZBTLEN);
4703 return Perl_pp_semget(aTHX);
4707 /* I can't const this further without getting warnings about the types of
4708 various arrays passed in from structures. */
4710 S_space_join_names_mortal(pTHX_ char *const *array)
4714 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4716 if (array && *array) {
4717 target = newSVpvs_flags("", SVs_TEMP);
4719 sv_catpv(target, *array);
4722 sv_catpvs(target, " ");
4725 target = sv_mortalcopy(&PL_sv_no);
4730 /* Get system info. */
4734 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4736 I32 which = PL_op->op_type;
4737 register char **elem;
4739 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4740 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4741 struct hostent *gethostbyname(Netdb_name_t);
4742 struct hostent *gethostent(void);
4744 struct hostent *hent = NULL;
4748 if (which == OP_GHBYNAME) {
4749 #ifdef HAS_GETHOSTBYNAME
4750 const char* const name = POPpbytex;
4751 hent = PerlSock_gethostbyname(name);
4753 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4756 else if (which == OP_GHBYADDR) {
4757 #ifdef HAS_GETHOSTBYADDR
4758 const int addrtype = POPi;
4759 SV * const addrsv = POPs;
4761 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4763 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4765 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4769 #ifdef HAS_GETHOSTENT
4770 hent = PerlSock_gethostent();
4772 DIE(aTHX_ PL_no_sock_func, "gethostent");
4775 #ifdef HOST_NOT_FOUND
4777 #ifdef USE_REENTRANT_API
4778 # ifdef USE_GETHOSTENT_ERRNO
4779 h_errno = PL_reentrant_buffer->_gethostent_errno;
4782 STATUS_UNIX_SET(h_errno);
4786 if (GIMME != G_ARRAY) {
4787 PUSHs(sv = sv_newmortal());
4789 if (which == OP_GHBYNAME) {
4791 sv_setpvn(sv, hent->h_addr, hent->h_length);
4794 sv_setpv(sv, (char*)hent->h_name);
4800 mPUSHs(newSVpv((char*)hent->h_name, 0));
4801 PUSHs(space_join_names_mortal(hent->h_aliases));
4802 mPUSHi(hent->h_addrtype);
4803 len = hent->h_length;
4806 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4807 mXPUSHp(*elem, len);
4811 mPUSHp(hent->h_addr, len);
4813 PUSHs(sv_mortalcopy(&PL_sv_no));
4818 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4824 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4826 I32 which = PL_op->op_type;
4828 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4829 struct netent *getnetbyaddr(Netdb_net_t, int);
4830 struct netent *getnetbyname(Netdb_name_t);
4831 struct netent *getnetent(void);
4833 struct netent *nent;
4835 if (which == OP_GNBYNAME){
4836 #ifdef HAS_GETNETBYNAME
4837 const char * const name = POPpbytex;
4838 nent = PerlSock_getnetbyname(name);
4840 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4843 else if (which == OP_GNBYADDR) {
4844 #ifdef HAS_GETNETBYADDR
4845 const int addrtype = POPi;
4846 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4847 nent = PerlSock_getnetbyaddr(addr, addrtype);
4849 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4853 #ifdef HAS_GETNETENT
4854 nent = PerlSock_getnetent();
4856 DIE(aTHX_ PL_no_sock_func, "getnetent");
4859 #ifdef HOST_NOT_FOUND
4861 #ifdef USE_REENTRANT_API
4862 # ifdef USE_GETNETENT_ERRNO
4863 h_errno = PL_reentrant_buffer->_getnetent_errno;
4866 STATUS_UNIX_SET(h_errno);
4871 if (GIMME != G_ARRAY) {
4872 PUSHs(sv = sv_newmortal());
4874 if (which == OP_GNBYNAME)
4875 sv_setiv(sv, (IV)nent->n_net);
4877 sv_setpv(sv, nent->n_name);
4883 mPUSHs(newSVpv(nent->n_name, 0));
4884 PUSHs(space_join_names_mortal(nent->n_aliases));
4885 mPUSHi(nent->n_addrtype);
4886 mPUSHi(nent->n_net);
4891 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4897 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4899 I32 which = PL_op->op_type;
4901 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4902 struct protoent *getprotobyname(Netdb_name_t);
4903 struct protoent *getprotobynumber(int);
4904 struct protoent *getprotoent(void);
4906 struct protoent *pent;
4908 if (which == OP_GPBYNAME) {
4909 #ifdef HAS_GETPROTOBYNAME
4910 const char* const name = POPpbytex;
4911 pent = PerlSock_getprotobyname(name);
4913 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4916 else if (which == OP_GPBYNUMBER) {
4917 #ifdef HAS_GETPROTOBYNUMBER
4918 const int number = POPi;
4919 pent = PerlSock_getprotobynumber(number);
4921 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4925 #ifdef HAS_GETPROTOENT
4926 pent = PerlSock_getprotoent();
4928 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4932 if (GIMME != G_ARRAY) {
4933 PUSHs(sv = sv_newmortal());
4935 if (which == OP_GPBYNAME)
4936 sv_setiv(sv, (IV)pent->p_proto);
4938 sv_setpv(sv, pent->p_name);
4944 mPUSHs(newSVpv(pent->p_name, 0));
4945 PUSHs(space_join_names_mortal(pent->p_aliases));
4946 mPUSHi(pent->p_proto);
4951 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4957 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4959 I32 which = PL_op->op_type;
4961 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4962 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4963 struct servent *getservbyport(int, Netdb_name_t);
4964 struct servent *getservent(void);
4966 struct servent *sent;
4968 if (which == OP_GSBYNAME) {
4969 #ifdef HAS_GETSERVBYNAME
4970 const char * const proto = POPpbytex;
4971 const char * const name = POPpbytex;
4972 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4974 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4977 else if (which == OP_GSBYPORT) {
4978 #ifdef HAS_GETSERVBYPORT
4979 const char * const proto = POPpbytex;
4980 unsigned short port = (unsigned short)POPu;
4982 port = PerlSock_htons(port);
4984 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4986 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4990 #ifdef HAS_GETSERVENT
4991 sent = PerlSock_getservent();
4993 DIE(aTHX_ PL_no_sock_func, "getservent");
4997 if (GIMME != G_ARRAY) {
4998 PUSHs(sv = sv_newmortal());
5000 if (which == OP_GSBYNAME) {
5002 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5004 sv_setiv(sv, (IV)(sent->s_port));
5008 sv_setpv(sv, sent->s_name);
5014 mPUSHs(newSVpv(sent->s_name, 0));
5015 PUSHs(space_join_names_mortal(sent->s_aliases));
5017 mPUSHi(PerlSock_ntohs(sent->s_port));
5019 mPUSHi(sent->s_port);
5021 mPUSHs(newSVpv(sent->s_proto, 0));
5026 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5033 const int stayopen = TOPi;
5034 switch(PL_op->op_type) {
5036 #ifdef HAS_SETHOSTENT
5037 PerlSock_sethostent(stayopen);
5039 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5042 #ifdef HAS_SETNETENT
5044 PerlSock_setnetent(stayopen);
5046 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5050 #ifdef HAS_SETPROTOENT
5051 PerlSock_setprotoent(stayopen);
5053 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5057 #ifdef HAS_SETSERVENT
5058 PerlSock_setservent(stayopen);
5060 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5070 switch(PL_op->op_type) {
5072 #ifdef HAS_ENDHOSTENT
5073 PerlSock_endhostent();
5075 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5079 #ifdef HAS_ENDNETENT
5080 PerlSock_endnetent();
5082 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5086 #ifdef HAS_ENDPROTOENT
5087 PerlSock_endprotoent();
5089 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5093 #ifdef HAS_ENDSERVENT
5094 PerlSock_endservent();
5096 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5100 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5103 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5107 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5110 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5114 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5117 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5121 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5124 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5136 I32 which = PL_op->op_type;
5138 struct passwd *pwent = NULL;
5140 * We currently support only the SysV getsp* shadow password interface.
5141 * The interface is declared in <shadow.h> and often one needs to link
5142 * with -lsecurity or some such.
5143 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5146 * AIX getpwnam() is clever enough to return the encrypted password
5147 * only if the caller (euid?) is root.
5149 * There are at least three other shadow password APIs. Many platforms
5150 * seem to contain more than one interface for accessing the shadow
5151 * password databases, possibly for compatibility reasons.
5152 * The getsp*() is by far he simplest one, the other two interfaces
5153 * are much more complicated, but also very similar to each other.
5158 * struct pr_passwd *getprpw*();
5159 * The password is in
5160 * char getprpw*(...).ufld.fd_encrypt[]
5161 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5166 * struct es_passwd *getespw*();
5167 * The password is in
5168 * char *(getespw*(...).ufld.fd_encrypt)
5169 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5172 * struct userpw *getuserpw();
5173 * The password is in
5174 * char *(getuserpw(...)).spw_upw_passwd
5175 * (but the de facto standard getpwnam() should work okay)
5177 * Mention I_PROT here so that Configure probes for it.
5179 * In HP-UX for getprpw*() the manual page claims that one should include
5180 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5181 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5182 * and pp_sys.c already includes <shadow.h> if there is such.
5184 * Note that <sys/security.h> is already probed for, but currently
5185 * it is only included in special cases.
5187 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5188 * be preferred interface, even though also the getprpw*() interface
5189 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5190 * One also needs to call set_auth_parameters() in main() before
5191 * doing anything else, whether one is using getespw*() or getprpw*().
5193 * Note that accessing the shadow databases can be magnitudes
5194 * slower than accessing the standard databases.
5199 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5200 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5201 * the pw_comment is left uninitialized. */
5202 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5208 const char* const name = POPpbytex;
5209 pwent = getpwnam(name);
5215 pwent = getpwuid(uid);
5219 # ifdef HAS_GETPWENT
5221 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5222 if (pwent) pwent = getpwnam(pwent->pw_name);
5225 DIE(aTHX_ PL_no_func, "getpwent");
5231 if (GIMME != G_ARRAY) {
5232 PUSHs(sv = sv_newmortal());
5234 if (which == OP_GPWNAM)
5235 # if Uid_t_sign <= 0
5236 sv_setiv(sv, (IV)pwent->pw_uid);
5238 sv_setuv(sv, (UV)pwent->pw_uid);
5241 sv_setpv(sv, pwent->pw_name);
5247 mPUSHs(newSVpv(pwent->pw_name, 0));
5251 /* If we have getspnam(), we try to dig up the shadow
5252 * password. If we are underprivileged, the shadow
5253 * interface will set the errno to EACCES or similar,
5254 * and return a null pointer. If this happens, we will
5255 * use the dummy password (usually "*" or "x") from the
5256 * standard password database.
5258 * In theory we could skip the shadow call completely
5259 * if euid != 0 but in practice we cannot know which
5260 * security measures are guarding the shadow databases
5261 * on a random platform.
5263 * Resist the urge to use additional shadow interfaces.
5264 * Divert the urge to writing an extension instead.
5267 /* Some AIX setups falsely(?) detect some getspnam(), which
5268 * has a different API than the Solaris/IRIX one. */
5269 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5272 const struct spwd * const spwent = getspnam(pwent->pw_name);
5273 /* Save and restore errno so that
5274 * underprivileged attempts seem
5275 * to have never made the unsuccessful
5276 * attempt to retrieve the shadow password. */
5278 if (spwent && spwent->sp_pwdp)
5279 sv_setpv(sv, spwent->sp_pwdp);
5283 if (!SvPOK(sv)) /* Use the standard password, then. */
5284 sv_setpv(sv, pwent->pw_passwd);
5287 # ifndef INCOMPLETE_TAINTS
5288 /* passwd is tainted because user himself can diddle with it.
5289 * admittedly not much and in a very limited way, but nevertheless. */
5293 # if Uid_t_sign <= 0
5294 mPUSHi(pwent->pw_uid);
5296 mPUSHu(pwent->pw_uid);
5299 # if Uid_t_sign <= 0
5300 mPUSHi(pwent->pw_gid);
5302 mPUSHu(pwent->pw_gid);
5304 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5305 * because of the poor interface of the Perl getpw*(),
5306 * not because there's some standard/convention saying so.
5307 * A better interface would have been to return a hash,
5308 * but we are accursed by our history, alas. --jhi. */
5310 mPUSHi(pwent->pw_change);
5313 mPUSHi(pwent->pw_quota);
5316 mPUSHs(newSVpv(pwent->pw_age, 0));
5318 /* I think that you can never get this compiled, but just in case. */
5319 PUSHs(sv_mortalcopy(&PL_sv_no));
5324 /* pw_class and pw_comment are mutually exclusive--.
5325 * see the above note for pw_change, pw_quota, and pw_age. */
5327 mPUSHs(newSVpv(pwent->pw_class, 0));
5330 mPUSHs(newSVpv(pwent->pw_comment, 0));
5332 /* I think that you can never get this compiled, but just in case. */
5333 PUSHs(sv_mortalcopy(&PL_sv_no));
5338 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5340 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5342 # ifndef INCOMPLETE_TAINTS
5343 /* pw_gecos is tainted because user himself can diddle with it. */
5347 mPUSHs(newSVpv(pwent->pw_dir, 0));
5349 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5350 # ifndef INCOMPLETE_TAINTS
5351 /* pw_shell is tainted because user himself can diddle with it. */
5356 mPUSHi(pwent->pw_expire);
5361 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5369 const I32 which = PL_op->op_type;
5370 const struct group *grent;
5372 if (which == OP_GGRNAM) {
5373 const char* const name = POPpbytex;
5374 grent = (const struct group *)getgrnam(name);
5376 else if (which == OP_GGRGID) {
5377 const Gid_t gid = POPi;
5378 grent = (const struct group *)getgrgid(gid);
5382 grent = (struct group *)getgrent();
5384 DIE(aTHX_ PL_no_func, "getgrent");
5388 if (GIMME != G_ARRAY) {
5389 SV * const sv = sv_newmortal();
5393 if (which == OP_GGRNAM)
5395 sv_setiv(sv, (IV)grent->gr_gid);
5397 sv_setuv(sv, (UV)grent->gr_gid);
5400 sv_setpv(sv, grent->gr_name);
5406 mPUSHs(newSVpv(grent->gr_name, 0));
5409 mPUSHs(newSVpv(grent->gr_passwd, 0));
5411 PUSHs(sv_mortalcopy(&PL_sv_no));
5415 mPUSHi(grent->gr_gid);
5417 mPUSHu(grent->gr_gid);
5420 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5421 /* In UNICOS/mk (_CRAYMPP) the multithreading
5422 * versions (getgrnam_r, getgrgid_r)
5423 * seem to return an illegal pointer
5424 * as the group members list, gr_mem.
5425 * getgrent() doesn't even have a _r version
5426 * but the gr_mem is poisonous anyway.
5427 * So yes, you cannot get the list of group
5428 * members if building multithreaded in UNICOS/mk. */
5429 PUSHs(space_join_names_mortal(grent->gr_mem));
5435 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5445 if (!(tmps = PerlProc_getlogin()))
5447 sv_setpv_mg(TARG, tmps);
5451 DIE(aTHX_ PL_no_func, "getlogin");
5455 /* Miscellaneous. */
5460 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5461 register I32 items = SP - MARK;
5462 unsigned long a[20];
5467 while (++MARK <= SP) {
5468 if (SvTAINTED(*MARK)) {
5474 TAINT_PROPER("syscall");
5477 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5478 * or where sizeof(long) != sizeof(char*). But such machines will
5479 * not likely have syscall implemented either, so who cares?
5481 while (++MARK <= SP) {
5482 if (SvNIOK(*MARK) || !i)
5483 a[i++] = SvIV(*MARK);
5484 else if (*MARK == &PL_sv_undef)
5487 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5493 DIE(aTHX_ "Too many args to syscall");
5495 DIE(aTHX_ "Too few args to syscall");
5497 retval = syscall(a[0]);
5500 retval = syscall(a[0],a[1]);
5503 retval = syscall(a[0],a[1],a[2]);
5506 retval = syscall(a[0],a[1],a[2],a[3]);
5509 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5512 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5515 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5518 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5522 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5525 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5528 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5532 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5536 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5540 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5541 a[10],a[11],a[12],a[13]);
5543 #endif /* atarist */
5549 DIE(aTHX_ PL_no_func, "syscall");
5553 #ifdef FCNTL_EMULATE_FLOCK
5555 /* XXX Emulate flock() with fcntl().
5556 What's really needed is a good file locking module.
5560 fcntl_emulate_flock(int fd, int operation)
5565 switch (operation & ~LOCK_NB) {
5567 flock.l_type = F_RDLCK;
5570 flock.l_type = F_WRLCK;
5573 flock.l_type = F_UNLCK;
5579 flock.l_whence = SEEK_SET;
5580 flock.l_start = flock.l_len = (Off_t)0;
5582 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5583 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5584 errno = EWOULDBLOCK;
5588 #endif /* FCNTL_EMULATE_FLOCK */
5590 #ifdef LOCKF_EMULATE_FLOCK
5592 /* XXX Emulate flock() with lockf(). This is just to increase
5593 portability of scripts. The calls are not completely
5594 interchangeable. What's really needed is a good file
5598 /* The lockf() constants might have been defined in <unistd.h>.
5599 Unfortunately, <unistd.h> causes troubles on some mixed
5600 (BSD/POSIX) systems, such as SunOS 4.1.3.
5602 Further, the lockf() constants aren't POSIX, so they might not be
5603 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5604 just stick in the SVID values and be done with it. Sigh.
5608 # define F_ULOCK 0 /* Unlock a previously locked region */
5611 # define F_LOCK 1 /* Lock a region for exclusive use */
5614 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5617 # define F_TEST 3 /* Test a region for other processes locks */
5621 lockf_emulate_flock(int fd, int operation)
5627 /* flock locks entire file so for lockf we need to do the same */
5628 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5629 if (pos > 0) /* is seekable and needs to be repositioned */
5630 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5631 pos = -1; /* seek failed, so don't seek back afterwards */
5634 switch (operation) {
5636 /* LOCK_SH - get a shared lock */
5638 /* LOCK_EX - get an exclusive lock */
5640 i = lockf (fd, F_LOCK, 0);
5643 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5644 case LOCK_SH|LOCK_NB:
5645 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5646 case LOCK_EX|LOCK_NB:
5647 i = lockf (fd, F_TLOCK, 0);
5649 if ((errno == EAGAIN) || (errno == EACCES))
5650 errno = EWOULDBLOCK;
5653 /* LOCK_UN - unlock (non-blocking is a no-op) */
5655 case LOCK_UN|LOCK_NB:
5656 i = lockf (fd, F_ULOCK, 0);
5659 /* Default - can't decipher operation */
5666 if (pos > 0) /* need to restore position of the handle */
5667 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5672 #endif /* LOCKF_EMULATE_FLOCK */
5676 * c-indentation-style: bsd
5678 * indent-tabs-mode: nil
5681 * ex: set ts=8 sts=4 sw=4 et: