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 if (!io || !(ofp = IoOFP(io)))
1400 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1401 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1403 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1404 PL_formtarget != PL_toptarget)
1408 if (!IoTOP_GV(io)) {
1411 if (!IoTOP_NAME(io)) {
1413 if (!IoFMT_NAME(io))
1414 IoFMT_NAME(io) = savepv(GvNAME(gv));
1415 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1416 HEKfARG(GvNAME_HEK(gv))));
1417 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1418 if ((topgv && GvFORM(topgv)) ||
1419 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1420 IoTOP_NAME(io) = savesvpv(topname);
1422 IoTOP_NAME(io) = savepvs("top");
1424 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1425 if (!topgv || !GvFORM(topgv)) {
1426 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1429 IoTOP_GV(io) = topgv;
1431 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1432 I32 lines = IoLINES_LEFT(io);
1433 const char *s = SvPVX_const(PL_formtarget);
1434 if (lines <= 0) /* Yow, header didn't even fit!!! */
1436 while (lines-- > 0) {
1437 s = strchr(s, '\n');
1443 const STRLEN save = SvCUR(PL_formtarget);
1444 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1445 do_print(PL_formtarget, ofp);
1446 SvCUR_set(PL_formtarget, save);
1447 sv_chop(PL_formtarget, s);
1448 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1451 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1452 do_print(PL_formfeed, ofp);
1453 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1455 PL_formtarget = PL_toptarget;
1456 IoFLAGS(io) |= IOf_DIDTOP;
1459 DIE(aTHX_ "bad top format reference");
1462 SV * const sv = sv_newmortal();
1463 gv_efullname4(sv, fgv, NULL, FALSE);
1464 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1466 return doform(cv, gv, PL_op);
1470 POPBLOCK(cx,PL_curpm);
1472 retop = cx->blk_sub.retop;
1473 SP = newsp; /* ignore retval of formline */
1479 report_wrongway_fh(gv, '<');
1485 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1486 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1488 if (!do_print(PL_formtarget, fp))
1491 FmLINES(PL_formtarget) = 0;
1492 SvCUR_set(PL_formtarget, 0);
1493 *SvEND(PL_formtarget) = '\0';
1494 if (IoFLAGS(io) & IOf_FLUSH)
1495 (void)PerlIO_flush(fp);
1500 PL_formtarget = PL_bodytarget;
1501 PERL_UNUSED_VAR(gimme);
1507 dVAR; dSP; dMARK; dORIGMARK;
1512 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1513 IO *const io = GvIO(gv);
1516 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1518 if (MARK == ORIGMARK) {
1521 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1524 return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io),
1526 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1534 SETERRNO(EBADF,RMS_IFI);
1537 else if (!(fp = IoOFP(io))) {
1539 report_wrongway_fh(gv, '<');
1540 else if (ckWARN(WARN_CLOSED))
1542 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1546 do_sprintf(sv, SP - MARK, MARK + 1);
1547 if (!do_print(sv, fp))
1550 if (IoFLAGS(io) & IOf_FLUSH)
1551 if (PerlIO_flush(fp) == EOF)
1562 PUSHs(&PL_sv_undef);
1570 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1571 const int mode = POPi;
1572 SV * const sv = POPs;
1573 GV * const gv = MUTABLE_GV(POPs);
1576 /* Need TIEHANDLE method ? */
1577 const char * const tmps = SvPV_const(sv, len);
1578 /* FIXME? do_open should do const */
1579 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1580 IoLINES(GvIOp(gv)) = 0;
1584 PUSHs(&PL_sv_undef);
1591 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1605 bool charstart = FALSE;
1606 STRLEN charskip = 0;
1609 GV * const gv = MUTABLE_GV(*++MARK);
1610 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1611 && gv && (io = GvIO(gv)) )
1613 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1615 return Perl_tied_method(aTHX_ "READ", mark - 1, MUTABLE_SV(io), mg,
1616 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1625 sv_setpvs(bufsv, "");
1626 length = SvIVx(*++MARK);
1628 DIE(aTHX_ "Negative length");
1631 offset = SvIVx(*++MARK);
1635 if (!io || !IoIFP(io)) {
1637 SETERRNO(EBADF,RMS_IFI);
1640 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1641 buffer = SvPVutf8_force(bufsv, blen);
1642 /* UTF-8 may not have been set if they are all low bytes */
1647 buffer = SvPV_force(bufsv, blen);
1648 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1650 if (DO_UTF8(bufsv)) {
1651 /* offset adjust in characters not bytes */
1652 /* SV's length cache is only safe for non-magical values */
1653 if (SvGMAGICAL(bufsv))
1654 blen = utf8_length((const U8 *)buffer, (const U8 *)buffer + blen);
1656 blen = sv_len_utf8(bufsv);
1665 if (PL_op->op_type == OP_RECV) {
1666 Sock_size_t bufsize;
1667 char namebuf[MAXPATHLEN];
1668 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1669 bufsize = sizeof (struct sockaddr_in);
1671 bufsize = sizeof namebuf;
1673 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1677 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1678 /* 'offset' means 'flags' here */
1679 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1680 (struct sockaddr *)namebuf, &bufsize);
1683 /* MSG_TRUNC can give oversized count; quietly lose it */
1687 /* Bogus return without padding */
1688 bufsize = sizeof (struct sockaddr_in);
1690 SvCUR_set(bufsv, count);
1691 *SvEND(bufsv) = '\0';
1692 (void)SvPOK_only(bufsv);
1696 /* This should not be marked tainted if the fp is marked clean */
1697 if (!(IoFLAGS(io) & IOf_UNTAINT))
1698 SvTAINTED_on(bufsv);
1700 sv_setpvn(TARG, namebuf, bufsize);
1706 if (-offset > (SSize_t)blen)
1707 DIE(aTHX_ "Offset outside string");
1710 if (DO_UTF8(bufsv)) {
1711 /* convert offset-as-chars to offset-as-bytes */
1712 if (offset >= (SSize_t)blen)
1713 offset += SvCUR(bufsv) - blen;
1715 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1718 orig_size = SvCUR(bufsv);
1719 /* Allocating length + offset + 1 isn't perfect in the case of reading
1720 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1722 (should be 2 * length + offset + 1, or possibly something longer if
1723 PL_encoding is true) */
1724 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1725 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1726 Zero(buffer+orig_size, offset-orig_size, char);
1728 buffer = buffer + offset;
1730 read_target = bufsv;
1732 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1733 concatenate it to the current buffer. */
1735 /* Truncate the existing buffer to the start of where we will be
1737 SvCUR_set(bufsv, offset);
1739 read_target = sv_newmortal();
1740 SvUPGRADE(read_target, SVt_PV);
1741 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1744 if (PL_op->op_type == OP_SYSREAD) {
1745 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1746 if (IoTYPE(io) == IoTYPE_SOCKET) {
1747 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1753 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1758 #ifdef HAS_SOCKET__bad_code_maybe
1759 if (IoTYPE(io) == IoTYPE_SOCKET) {
1760 Sock_size_t bufsize;
1761 char namebuf[MAXPATHLEN];
1762 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1763 bufsize = sizeof (struct sockaddr_in);
1765 bufsize = sizeof namebuf;
1767 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1768 (struct sockaddr *)namebuf, &bufsize);
1773 count = PerlIO_read(IoIFP(io), buffer, length);
1774 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1775 if (count == 0 && PerlIO_error(IoIFP(io)))
1779 if (IoTYPE(io) == IoTYPE_WRONLY)
1780 report_wrongway_fh(gv, '>');
1783 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1784 *SvEND(read_target) = '\0';
1785 (void)SvPOK_only(read_target);
1786 if (fp_utf8 && !IN_BYTES) {
1787 /* Look at utf8 we got back and count the characters */
1788 const char *bend = buffer + count;
1789 while (buffer < bend) {
1791 skip = UTF8SKIP(buffer);
1794 if (buffer - charskip + skip > bend) {
1795 /* partial character - try for rest of it */
1796 length = skip - (bend-buffer);
1797 offset = bend - SvPVX_const(bufsv);
1809 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1810 provided amount read (count) was what was requested (length)
1812 if (got < wanted && count == length) {
1813 length = wanted - got;
1814 offset = bend - SvPVX_const(bufsv);
1817 /* return value is character count */
1821 else if (buffer_utf8) {
1822 /* Let svcatsv upgrade the bytes we read in to utf8.
1823 The buffer is a mortal so will be freed soon. */
1824 sv_catsv_nomg(bufsv, read_target);
1827 /* This should not be marked tainted if the fp is marked clean */
1828 if (!(IoFLAGS(io) & IOf_UNTAINT))
1829 SvTAINTED_on(bufsv);
1841 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1846 STRLEN orig_blen_bytes;
1847 const int op_type = PL_op->op_type;
1850 GV *const gv = MUTABLE_GV(*++MARK);
1851 IO *const io = GvIO(gv);
1853 if (op_type == OP_SYSWRITE && io) {
1854 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1856 if (MARK == SP - 1) {
1858 mXPUSHi(sv_len(sv));
1862 return Perl_tied_method(aTHX_ "WRITE", mark - 1, MUTABLE_SV(io), mg,
1863 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1873 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1875 if (io && IoIFP(io))
1876 report_wrongway_fh(gv, '<');
1879 SETERRNO(EBADF,RMS_IFI);
1883 /* Do this first to trigger any overloading. */
1884 buffer = SvPV_const(bufsv, blen);
1885 orig_blen_bytes = blen;
1886 doing_utf8 = DO_UTF8(bufsv);
1888 if (PerlIO_isutf8(IoIFP(io))) {
1889 if (!SvUTF8(bufsv)) {
1890 /* We don't modify the original scalar. */
1891 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1892 buffer = (char *) tmpbuf;
1896 else if (doing_utf8) {
1897 STRLEN tmplen = blen;
1898 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1901 buffer = (char *) tmpbuf;
1905 assert((char *)result == buffer);
1906 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1911 if (op_type == OP_SEND) {
1912 const int flags = SvIVx(*++MARK);
1915 char * const sockbuf = SvPVx(*++MARK, mlen);
1916 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1917 flags, (struct sockaddr *)sockbuf, mlen);
1921 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1927 Size_t length = 0; /* This length is in characters. */
1933 /* The SV is bytes, and we've had to upgrade it. */
1934 blen_chars = orig_blen_bytes;
1936 /* The SV really is UTF-8. */
1937 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1938 /* Don't call sv_len_utf8 again because it will call magic
1939 or overloading a second time, and we might get back a
1940 different result. */
1941 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1943 /* It's safe, and it may well be cached. */
1944 blen_chars = sv_len_utf8(bufsv);
1952 length = blen_chars;
1954 #if Size_t_size > IVSIZE
1955 length = (Size_t)SvNVx(*++MARK);
1957 length = (Size_t)SvIVx(*++MARK);
1959 if ((SSize_t)length < 0) {
1961 DIE(aTHX_ "Negative length");
1966 offset = SvIVx(*++MARK);
1968 if (-offset > (IV)blen_chars) {
1970 DIE(aTHX_ "Offset outside string");
1972 offset += blen_chars;
1973 } else if (offset > (IV)blen_chars) {
1975 DIE(aTHX_ "Offset outside string");
1979 if (length > blen_chars - offset)
1980 length = blen_chars - offset;
1982 /* Here we convert length from characters to bytes. */
1983 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1984 /* Either we had to convert the SV, or the SV is magical, or
1985 the SV has overloading, in which case we can't or mustn't
1986 or mustn't call it again. */
1988 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1989 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1991 /* It's a real UTF-8 SV, and it's not going to change under
1992 us. Take advantage of any cache. */
1994 I32 len_I32 = length;
1996 /* Convert the start and end character positions to bytes.
1997 Remember that the second argument to sv_pos_u2b is relative
1999 sv_pos_u2b(bufsv, &start, &len_I32);
2006 buffer = buffer+offset;
2008 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2009 if (IoTYPE(io) == IoTYPE_SOCKET) {
2010 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
2016 /* See the note at doio.c:do_print about filesize limits. --jhi */
2017 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2026 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2029 #if Size_t_size > IVSIZE
2049 * in Perl 5.12 and later, the additional parameter is a bitmask:
2052 * 2 = eof() <- ARGV magic
2054 * I'll rely on the compiler's trace flow analysis to decide whether to
2055 * actually assign this out here, or punt it into the only block where it is
2056 * used. Doing it out here is DRY on the condition logic.
2061 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2067 if (PL_op->op_flags & OPf_SPECIAL) {
2068 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2072 gv = PL_last_in_gv; /* eof */
2080 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2081 return tied_method1("EOF", SP, MUTABLE_SV(io), mg, newSVuv(which));
2084 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2085 if (io && !IoIFP(io)) {
2086 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2088 IoFLAGS(io) &= ~IOf_START;
2089 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2091 sv_setpvs(GvSV(gv), "-");
2093 GvSV(gv) = newSVpvs("-");
2094 SvSETMAGIC(GvSV(gv));
2096 else if (!nextargv(gv))
2101 PUSHs(boolSV(do_eof(gv)));
2111 if (MAXARG != 0 && (TOPs || POPs))
2112 PL_last_in_gv = MUTABLE_GV(POPs);
2119 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2121 return tied_method0("TELL", SP, MUTABLE_SV(io), mg);
2126 SETERRNO(EBADF,RMS_IFI);
2131 #if LSEEKSIZE > IVSIZE
2132 PUSHn( do_tell(gv) );
2134 PUSHi( do_tell(gv) );
2142 const int whence = POPi;
2143 #if LSEEKSIZE > IVSIZE
2144 const Off_t offset = (Off_t)SvNVx(POPs);
2146 const Off_t offset = (Off_t)SvIVx(POPs);
2149 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2150 IO *const io = GvIO(gv);
2153 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2155 #if LSEEKSIZE > IVSIZE
2156 SV *const offset_sv = newSVnv((NV) offset);
2158 SV *const offset_sv = newSViv(offset);
2161 return tied_method2("SEEK", SP, MUTABLE_SV(io), mg, offset_sv,
2166 if (PL_op->op_type == OP_SEEK)
2167 PUSHs(boolSV(do_seek(gv, offset, whence)));
2169 const Off_t sought = do_sysseek(gv, offset, whence);
2171 PUSHs(&PL_sv_undef);
2173 SV* const sv = sought ?
2174 #if LSEEKSIZE > IVSIZE
2179 : newSVpvn(zero_but_true, ZBTLEN);
2190 /* There seems to be no consensus on the length type of truncate()
2191 * and ftruncate(), both off_t and size_t have supporters. In
2192 * general one would think that when using large files, off_t is
2193 * at least as wide as size_t, so using an off_t should be okay. */
2194 /* XXX Configure probe for the length type of *truncate() needed XXX */
2197 #if Off_t_size > IVSIZE
2202 /* Checking for length < 0 is problematic as the type might or
2203 * might not be signed: if it is not, clever compilers will moan. */
2204 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2207 SV * const sv = POPs;
2212 if (PL_op->op_flags & OPf_SPECIAL
2213 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2214 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2221 TAINT_PROPER("truncate");
2222 if (!(fp = IoIFP(io))) {
2228 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2230 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2236 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2237 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2238 goto do_ftruncate_io;
2241 const char * const name = SvPV_nomg_const_nolen(sv);
2242 TAINT_PROPER("truncate");
2244 if (truncate(name, len) < 0)
2248 const int tmpfd = PerlLIO_open(name, O_RDWR);
2253 if (my_chsize(tmpfd, len) < 0)
2255 PerlLIO_close(tmpfd);
2264 SETERRNO(EBADF,RMS_IFI);
2272 SV * const argsv = POPs;
2273 const unsigned int func = POPu;
2274 const int optype = PL_op->op_type;
2275 GV * const gv = MUTABLE_GV(POPs);
2276 IO * const io = gv ? GvIOn(gv) : NULL;
2280 if (!io || !argsv || !IoIFP(io)) {
2282 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2286 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2289 s = SvPV_force(argsv, len);
2290 need = IOCPARM_LEN(func);
2292 s = Sv_Grow(argsv, need + 1);
2293 SvCUR_set(argsv, need);
2296 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2299 retval = SvIV(argsv);
2300 s = INT2PTR(char*,retval); /* ouch */
2303 TAINT_PROPER(PL_op_desc[optype]);
2305 if (optype == OP_IOCTL)
2307 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2309 DIE(aTHX_ "ioctl is not implemented");
2313 DIE(aTHX_ "fcntl is not implemented");
2315 #if defined(OS2) && defined(__EMX__)
2316 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2318 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2322 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2324 if (s[SvCUR(argsv)] != 17)
2325 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2327 s[SvCUR(argsv)] = 0; /* put our null back */
2328 SvSETMAGIC(argsv); /* Assume it has changed */
2337 PUSHp(zero_but_true, ZBTLEN);
2348 const int argtype = POPi;
2349 GV * const gv = MUTABLE_GV(POPs);
2350 IO *const io = GvIO(gv);
2351 PerlIO *const fp = io ? IoIFP(io) : NULL;
2353 /* XXX Looks to me like io is always NULL at this point */
2355 (void)PerlIO_flush(fp);
2356 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2361 SETERRNO(EBADF,RMS_IFI);
2366 DIE(aTHX_ PL_no_func, "flock()");
2377 const int protocol = POPi;
2378 const int type = POPi;
2379 const int domain = POPi;
2380 GV * const gv = MUTABLE_GV(POPs);
2381 register IO * const io = gv ? GvIOn(gv) : NULL;
2386 if (io && IoIFP(io))
2387 do_close(gv, FALSE);
2388 SETERRNO(EBADF,LIB_INVARG);
2393 do_close(gv, FALSE);
2395 TAINT_PROPER("socket");
2396 fd = PerlSock_socket(domain, type, protocol);
2399 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2400 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2401 IoTYPE(io) = IoTYPE_SOCKET;
2402 if (!IoIFP(io) || !IoOFP(io)) {
2403 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2404 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2405 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2408 #if defined(HAS_FCNTL) && defined(F_SETFD)
2409 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2413 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2422 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2424 const int protocol = POPi;
2425 const int type = POPi;
2426 const int domain = POPi;
2427 GV * const gv2 = MUTABLE_GV(POPs);
2428 GV * const gv1 = MUTABLE_GV(POPs);
2429 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2430 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2434 report_evil_fh(gv1);
2436 report_evil_fh(gv2);
2438 if (io1 && IoIFP(io1))
2439 do_close(gv1, FALSE);
2440 if (io2 && IoIFP(io2))
2441 do_close(gv2, FALSE);
2446 TAINT_PROPER("socketpair");
2447 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2449 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2450 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2451 IoTYPE(io1) = IoTYPE_SOCKET;
2452 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2453 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2454 IoTYPE(io2) = IoTYPE_SOCKET;
2455 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2456 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2457 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2458 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2459 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2460 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2461 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2464 #if defined(HAS_FCNTL) && defined(F_SETFD)
2465 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2466 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2471 DIE(aTHX_ PL_no_sock_func, "socketpair");
2480 SV * const addrsv = POPs;
2481 /* OK, so on what platform does bind modify addr? */
2483 GV * const gv = MUTABLE_GV(POPs);
2484 register IO * const io = GvIOn(gv);
2486 const int op_type = PL_op->op_type;
2488 if (!io || !IoIFP(io))
2491 addr = SvPV_const(addrsv, len);
2492 TAINT_PROPER(PL_op_desc[op_type]);
2493 if ((op_type == OP_BIND
2494 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2495 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2503 SETERRNO(EBADF,SS_IVCHAN);
2510 const int backlog = POPi;
2511 GV * const gv = MUTABLE_GV(POPs);
2512 register IO * const io = gv ? GvIOn(gv) : NULL;
2514 if (!io || !IoIFP(io))
2517 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2524 SETERRNO(EBADF,SS_IVCHAN);
2533 char namebuf[MAXPATHLEN];
2534 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2535 Sock_size_t len = sizeof (struct sockaddr_in);
2537 Sock_size_t len = sizeof namebuf;
2539 GV * const ggv = MUTABLE_GV(POPs);
2540 GV * const ngv = MUTABLE_GV(POPs);
2549 if (!gstio || !IoIFP(gstio))
2553 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2556 /* Some platforms indicate zero length when an AF_UNIX client is
2557 * not bound. Simulate a non-zero-length sockaddr structure in
2559 namebuf[0] = 0; /* sun_len */
2560 namebuf[1] = AF_UNIX; /* sun_family */
2568 do_close(ngv, FALSE);
2569 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2570 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2571 IoTYPE(nstio) = IoTYPE_SOCKET;
2572 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2573 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2574 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2575 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2578 #if defined(HAS_FCNTL) && defined(F_SETFD)
2579 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2583 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2584 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2586 #ifdef __SCO_VERSION__
2587 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2590 PUSHp(namebuf, len);
2594 report_evil_fh(ggv);
2595 SETERRNO(EBADF,SS_IVCHAN);
2605 const int how = POPi;
2606 GV * const gv = MUTABLE_GV(POPs);
2607 register IO * const io = GvIOn(gv);
2609 if (!io || !IoIFP(io))
2612 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2617 SETERRNO(EBADF,SS_IVCHAN);
2624 const int optype = PL_op->op_type;
2625 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2626 const unsigned int optname = (unsigned int) POPi;
2627 const unsigned int lvl = (unsigned int) POPi;
2628 GV * const gv = MUTABLE_GV(POPs);
2629 register IO * const io = GvIOn(gv);
2633 if (!io || !IoIFP(io))
2636 fd = PerlIO_fileno(IoIFP(io));
2640 (void)SvPOK_only(sv);
2644 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2651 #if defined(__SYMBIAN32__)
2652 # define SETSOCKOPT_OPTION_VALUE_T void *
2654 # define SETSOCKOPT_OPTION_VALUE_T const char *
2656 /* XXX TODO: We need to have a proper type (a Configure probe,
2657 * etc.) for what the C headers think of the third argument of
2658 * setsockopt(), the option_value read-only buffer: is it
2659 * a "char *", or a "void *", const or not. Some compilers
2660 * don't take kindly to e.g. assuming that "char *" implicitly
2661 * promotes to a "void *", or to explicitly promoting/demoting
2662 * consts to non/vice versa. The "const void *" is the SUS
2663 * definition, but that does not fly everywhere for the above
2665 SETSOCKOPT_OPTION_VALUE_T buf;
2669 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2673 aint = (int)SvIV(sv);
2674 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2677 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2687 SETERRNO(EBADF,SS_IVCHAN);
2696 const int optype = PL_op->op_type;
2697 GV * const gv = MUTABLE_GV(POPs);
2698 register IO * const io = GvIOn(gv);
2703 if (!io || !IoIFP(io))
2706 sv = sv_2mortal(newSV(257));
2707 (void)SvPOK_only(sv);
2711 fd = PerlIO_fileno(IoIFP(io));
2713 case OP_GETSOCKNAME:
2714 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2717 case OP_GETPEERNAME:
2718 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2720 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2722 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";
2723 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2724 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2725 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2726 sizeof(u_short) + sizeof(struct in_addr))) {
2733 #ifdef BOGUS_GETNAME_RETURN
2734 /* Interactive Unix, getpeername() and getsockname()
2735 does not return valid namelen */
2736 if (len == BOGUS_GETNAME_RETURN)
2737 len = sizeof(struct sockaddr);
2746 SETERRNO(EBADF,SS_IVCHAN);
2765 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2766 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2767 if (PL_op->op_type == OP_LSTAT) {
2768 if (gv != PL_defgv) {
2769 do_fstat_warning_check:
2770 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2771 "lstat() on filehandle%s%"SVf,
2774 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2776 } else if (PL_laststype != OP_LSTAT)
2777 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2778 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2781 if (gv != PL_defgv) {
2785 PL_laststype = OP_STAT;
2786 PL_statgv = gv ? gv : (GV *)io;
2787 sv_setpvs(PL_statname, "");
2794 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2796 } else if (IoDIRP(io)) {
2798 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2801 PL_laststatval = -1;
2804 else PL_laststatval = -1;
2805 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2808 if (PL_laststatval < 0) {
2813 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2814 io = MUTABLE_IO(SvRV(sv));
2815 if (PL_op->op_type == OP_LSTAT)
2816 goto do_fstat_warning_check;
2817 goto do_fstat_have_io;
2820 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2821 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2823 PL_laststype = PL_op->op_type;
2824 if (PL_op->op_type == OP_LSTAT)
2825 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2827 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2828 if (PL_laststatval < 0) {
2829 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2830 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2836 if (gimme != G_ARRAY) {
2837 if (gimme != G_VOID)
2838 XPUSHs(boolSV(max));
2844 mPUSHi(PL_statcache.st_dev);
2845 #if ST_INO_SIZE > IVSIZE
2846 mPUSHn(PL_statcache.st_ino);
2848 # if ST_INO_SIGN <= 0
2849 mPUSHi(PL_statcache.st_ino);
2851 mPUSHu(PL_statcache.st_ino);
2854 mPUSHu(PL_statcache.st_mode);
2855 mPUSHu(PL_statcache.st_nlink);
2856 #if Uid_t_size > IVSIZE
2857 mPUSHn(PL_statcache.st_uid);
2859 # if Uid_t_sign <= 0
2860 mPUSHi(PL_statcache.st_uid);
2862 mPUSHu(PL_statcache.st_uid);
2865 #if Gid_t_size > IVSIZE
2866 mPUSHn(PL_statcache.st_gid);
2868 # if Gid_t_sign <= 0
2869 mPUSHi(PL_statcache.st_gid);
2871 mPUSHu(PL_statcache.st_gid);
2874 #ifdef USE_STAT_RDEV
2875 mPUSHi(PL_statcache.st_rdev);
2877 PUSHs(newSVpvs_flags("", SVs_TEMP));
2879 #if Off_t_size > IVSIZE
2880 mPUSHn(PL_statcache.st_size);
2882 mPUSHi(PL_statcache.st_size);
2885 mPUSHn(PL_statcache.st_atime);
2886 mPUSHn(PL_statcache.st_mtime);
2887 mPUSHn(PL_statcache.st_ctime);
2889 mPUSHi(PL_statcache.st_atime);
2890 mPUSHi(PL_statcache.st_mtime);
2891 mPUSHi(PL_statcache.st_ctime);
2893 #ifdef USE_STAT_BLOCKS
2894 mPUSHu(PL_statcache.st_blksize);
2895 mPUSHu(PL_statcache.st_blocks);
2897 PUSHs(newSVpvs_flags("", SVs_TEMP));
2898 PUSHs(newSVpvs_flags("", SVs_TEMP));
2904 /* If the next filetest is stacked up with this one
2905 (PL_op->op_private & OPpFT_STACKING), we leave
2906 the original argument on the stack for success,
2907 and skip the stacked operators on failure.
2908 The next few macros/functions take care of this.
2912 S_ft_stacking_return_false(pTHX_ SV *ret) {
2915 while (OP_IS_FILETEST(next->op_type)
2916 && next->op_private & OPpFT_STACKED)
2917 next = next->op_next;
2918 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
2924 #define FT_RETURN_FALSE(X) \
2926 if (PL_op->op_private & OPpFT_STACKING) \
2927 return S_ft_stacking_return_false(aTHX_ X); \
2928 RETURNX(PL_op->op_flags & OPf_REF ? XPUSHs(X) : SETs(X)); \
2930 #define FT_RETURN_TRUE(X) \
2932 PL_op->op_flags & OPf_REF \
2934 PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (X) \
2936 : (PL_op->op_private & OPpFT_STACKING || SETs(X)) \
2939 #define FT_RETURNNO FT_RETURN_FALSE(&PL_sv_no)
2940 #define FT_RETURNUNDEF FT_RETURN_FALSE(&PL_sv_undef)
2941 #define FT_RETURNYES FT_RETURN_TRUE(&PL_sv_yes)
2943 #define tryAMAGICftest_MG(chr) STMT_START { \
2944 if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
2945 && PL_op->op_flags & OPf_KIDS) { \
2946 OP *next = S_try_amagic_ftest(aTHX_ chr); \
2947 if (next) return next; \
2952 S_try_amagic_ftest(pTHX_ char chr) {
2955 SV* const arg = TOPs;
2958 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
2962 const char tmpchr = chr;
2963 SV * const tmpsv = amagic_call(arg,
2964 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2965 ftest_amg, AMGf_unary);
2970 if (SvTRUE(tmpsv)) FT_RETURN_TRUE(tmpsv);
2971 FT_RETURN_FALSE(tmpsv);
2981 /* Not const, because things tweak this below. Not bool, because there's
2982 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2983 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2984 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2985 /* Giving some sort of initial value silences compilers. */
2987 int access_mode = R_OK;
2989 int access_mode = 0;
2992 /* access_mode is never used, but leaving use_access in makes the
2993 conditional compiling below much clearer. */
2996 Mode_t stat_mode = S_IRUSR;
2998 bool effective = FALSE;
3002 switch (PL_op->op_type) {
3003 case OP_FTRREAD: opchar = 'R'; break;
3004 case OP_FTRWRITE: opchar = 'W'; break;
3005 case OP_FTREXEC: opchar = 'X'; break;
3006 case OP_FTEREAD: opchar = 'r'; break;
3007 case OP_FTEWRITE: opchar = 'w'; break;
3008 case OP_FTEEXEC: opchar = 'x'; break;
3010 tryAMAGICftest_MG(opchar);
3012 switch (PL_op->op_type) {
3014 #if !(defined(HAS_ACCESS) && defined(R_OK))
3020 #if defined(HAS_ACCESS) && defined(W_OK)
3025 stat_mode = S_IWUSR;
3029 #if defined(HAS_ACCESS) && defined(X_OK)
3034 stat_mode = S_IXUSR;
3038 #ifdef PERL_EFF_ACCESS
3041 stat_mode = S_IWUSR;
3045 #ifndef PERL_EFF_ACCESS
3052 #ifdef PERL_EFF_ACCESS
3057 stat_mode = S_IXUSR;
3063 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3064 const char *name = TOPpx;
3066 # ifdef PERL_EFF_ACCESS
3067 result = PERL_EFF_ACCESS(name, access_mode);
3069 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3075 result = access(name, access_mode);
3077 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3088 result = my_stat_flags(0);
3091 if (cando(stat_mode, effective, &PL_statcache))
3100 const int op_type = PL_op->op_type;
3105 case OP_FTIS: opchar = 'e'; break;
3106 case OP_FTSIZE: opchar = 's'; break;
3107 case OP_FTMTIME: opchar = 'M'; break;
3108 case OP_FTCTIME: opchar = 'C'; break;
3109 case OP_FTATIME: opchar = 'A'; break;
3111 tryAMAGICftest_MG(opchar);
3113 result = my_stat_flags(0);
3116 if (op_type == OP_FTIS)
3119 /* You can't dTARGET inside OP_FTIS, because you'll get
3120 "panic: pad_sv po" - the op is not flagged to have a target. */
3124 #if Off_t_size > IVSIZE
3125 sv_setnv(TARG, (NV)PL_statcache.st_size);
3127 sv_setiv(TARG, (IV)PL_statcache.st_size);
3132 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3136 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3140 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3144 if (SvTRUE_nomg(TARG)) FT_RETURN_TRUE(TARG);
3145 else FT_RETURN_FALSE(TARG);
3156 switch (PL_op->op_type) {
3157 case OP_FTROWNED: opchar = 'O'; break;
3158 case OP_FTEOWNED: opchar = 'o'; break;
3159 case OP_FTZERO: opchar = 'z'; break;
3160 case OP_FTSOCK: opchar = 'S'; break;
3161 case OP_FTCHR: opchar = 'c'; break;
3162 case OP_FTBLK: opchar = 'b'; break;
3163 case OP_FTFILE: opchar = 'f'; break;
3164 case OP_FTDIR: opchar = 'd'; break;
3165 case OP_FTPIPE: opchar = 'p'; break;
3166 case OP_FTSUID: opchar = 'u'; break;
3167 case OP_FTSGID: opchar = 'g'; break;
3168 case OP_FTSVTX: opchar = 'k'; break;
3170 tryAMAGICftest_MG(opchar);
3172 /* I believe that all these three are likely to be defined on most every
3173 system these days. */
3175 if(PL_op->op_type == OP_FTSUID) {
3180 if(PL_op->op_type == OP_FTSGID) {
3185 if(PL_op->op_type == OP_FTSVTX) {
3190 result = my_stat_flags(0);
3193 switch (PL_op->op_type) {
3195 if (PL_statcache.st_uid == PerlProc_getuid())
3199 if (PL_statcache.st_uid == PerlProc_geteuid())
3203 if (PL_statcache.st_size == 0)
3207 if (S_ISSOCK(PL_statcache.st_mode))
3211 if (S_ISCHR(PL_statcache.st_mode))
3215 if (S_ISBLK(PL_statcache.st_mode))
3219 if (S_ISREG(PL_statcache.st_mode))
3223 if (S_ISDIR(PL_statcache.st_mode))
3227 if (S_ISFIFO(PL_statcache.st_mode))
3232 if (PL_statcache.st_mode & S_ISUID)
3238 if (PL_statcache.st_mode & S_ISGID)
3244 if (PL_statcache.st_mode & S_ISVTX)
3258 tryAMAGICftest_MG('l');
3259 result = my_lstat_flags(0);
3263 if (S_ISLNK(PL_statcache.st_mode))
3277 tryAMAGICftest_MG('t');
3279 if (PL_op->op_flags & OPf_REF)
3283 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3284 name = SvPV_nomg(tmpsv, namelen);
3285 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3289 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3290 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3291 else if (name && isDIGIT(*name))
3295 if (PerlLIO_isatty(fd))
3300 #if defined(atarist) /* this will work with atariST. Configure will
3301 make guesses for other systems. */
3302 # define FILE_base(f) ((f)->_base)
3303 # define FILE_ptr(f) ((f)->_ptr)
3304 # define FILE_cnt(f) ((f)->_cnt)
3305 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3316 register STDCHAR *s;
3318 register SV *sv = NULL;
3322 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3324 if (PL_op->op_flags & OPf_REF)
3326 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3331 gv = MAYBE_DEREF_GV_nomg(sv);
3335 if (gv == PL_defgv) {
3337 io = SvTYPE(PL_statgv) == SVt_PVIO
3341 goto really_filename;
3346 sv_setpvs(PL_statname, "");
3347 io = GvIO(PL_statgv);
3349 PL_laststatval = -1;
3350 PL_laststype = OP_STAT;
3351 if (io && IoIFP(io)) {
3352 if (! PerlIO_has_base(IoIFP(io)))
3353 DIE(aTHX_ "-T and -B not implemented on filehandles");
3354 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3355 if (PL_laststatval < 0)
3357 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3358 if (PL_op->op_type == OP_FTTEXT)
3363 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3364 i = PerlIO_getc(IoIFP(io));
3366 (void)PerlIO_ungetc(IoIFP(io),i);
3368 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3370 len = PerlIO_get_bufsiz(IoIFP(io));
3371 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3372 /* sfio can have large buffers - limit to 512 */
3377 SETERRNO(EBADF,RMS_IFI);
3379 SETERRNO(EBADF,RMS_IFI);
3384 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3387 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3389 PL_laststatval = -1;
3390 PL_laststype = OP_STAT;
3392 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3394 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3397 PL_laststype = OP_STAT;
3398 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3399 if (PL_laststatval < 0) {
3400 (void)PerlIO_close(fp);
3403 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3404 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3405 (void)PerlIO_close(fp);
3407 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3408 FT_RETURNNO; /* special case NFS directories */
3409 FT_RETURNYES; /* null file is anything */
3414 /* now scan s to look for textiness */
3415 /* XXX ASCII dependent code */
3417 #if defined(DOSISH) || defined(USEMYBINMODE)
3418 /* ignore trailing ^Z on short files */
3419 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3423 for (i = 0; i < len; i++, s++) {
3424 if (!*s) { /* null never allowed in text */
3429 else if (!(isPRINT(*s) || isSPACE(*s)))
3432 else if (*s & 128) {
3434 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3437 /* utf8 characters don't count as odd */
3438 if (UTF8_IS_START(*s)) {
3439 int ulen = UTF8SKIP(s);
3440 if (ulen < len - i) {
3442 for (j = 1; j < ulen; j++) {
3443 if (!UTF8_IS_CONTINUATION(s[j]))
3446 --ulen; /* loop does extra increment */
3456 *s != '\n' && *s != '\r' && *s != '\b' &&
3457 *s != '\t' && *s != '\f' && *s != 27)
3462 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3473 const char *tmps = NULL;
3477 SV * const sv = POPs;
3478 if (PL_op->op_flags & OPf_SPECIAL) {
3479 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3481 else if (!(gv = MAYBE_DEREF_GV(sv)))
3482 tmps = SvPV_nomg_const_nolen(sv);
3485 if( !gv && (!tmps || !*tmps) ) {
3486 HV * const table = GvHVn(PL_envgv);
3489 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3490 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3492 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3497 deprecate("chdir('') or chdir(undef) as chdir()");
3498 tmps = SvPV_nolen_const(*svp);
3502 TAINT_PROPER("chdir");
3507 TAINT_PROPER("chdir");
3510 IO* const io = GvIO(gv);
3513 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3514 } else if (IoIFP(io)) {
3515 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3519 SETERRNO(EBADF, RMS_IFI);
3525 SETERRNO(EBADF,RMS_IFI);
3529 DIE(aTHX_ PL_no_func, "fchdir");
3533 PUSHi( PerlDir_chdir(tmps) >= 0 );
3535 /* Clear the DEFAULT element of ENV so we'll get the new value
3537 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3544 dVAR; dSP; dMARK; dTARGET;
3545 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3556 char * const tmps = POPpx;
3557 TAINT_PROPER("chroot");
3558 PUSHi( chroot(tmps) >= 0 );
3561 DIE(aTHX_ PL_no_func, "chroot");
3569 const char * const tmps2 = POPpconstx;
3570 const char * const tmps = SvPV_nolen_const(TOPs);
3571 TAINT_PROPER("rename");
3573 anum = PerlLIO_rename(tmps, tmps2);
3575 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3576 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3579 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3580 (void)UNLINK(tmps2);
3581 if (!(anum = link(tmps, tmps2)))
3582 anum = UNLINK(tmps);
3590 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3594 const int op_type = PL_op->op_type;
3598 if (op_type == OP_LINK)
3599 DIE(aTHX_ PL_no_func, "link");
3601 # ifndef HAS_SYMLINK
3602 if (op_type == OP_SYMLINK)
3603 DIE(aTHX_ PL_no_func, "symlink");
3607 const char * const tmps2 = POPpconstx;
3608 const char * const tmps = SvPV_nolen_const(TOPs);
3609 TAINT_PROPER(PL_op_desc[op_type]);
3611 # if defined(HAS_LINK)
3612 # if defined(HAS_SYMLINK)
3613 /* Both present - need to choose which. */
3614 (op_type == OP_LINK) ?
3615 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3617 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3618 PerlLIO_link(tmps, tmps2);
3621 # if defined(HAS_SYMLINK)
3622 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3623 symlink(tmps, tmps2);
3628 SETi( result >= 0 );
3635 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3646 char buf[MAXPATHLEN];
3649 #ifndef INCOMPLETE_TAINTS
3653 len = readlink(tmps, buf, sizeof(buf) - 1);
3660 RETSETUNDEF; /* just pretend it's a normal file */
3664 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3666 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3668 char * const save_filename = filename;
3673 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3675 PERL_ARGS_ASSERT_DOONELINER;
3677 Newx(cmdline, size, char);
3678 my_strlcpy(cmdline, cmd, size);
3679 my_strlcat(cmdline, " ", size);
3680 for (s = cmdline + strlen(cmdline); *filename; ) {
3684 if (s - cmdline < size)
3685 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3686 myfp = PerlProc_popen(cmdline, "r");
3690 SV * const tmpsv = sv_newmortal();
3691 /* Need to save/restore 'PL_rs' ?? */
3692 s = sv_gets(tmpsv, myfp, 0);
3693 (void)PerlProc_pclose(myfp);
3697 #ifdef HAS_SYS_ERRLIST
3702 /* you don't see this */
3703 const char * const errmsg =
3704 #ifdef HAS_SYS_ERRLIST
3712 if (instr(s, errmsg)) {
3719 #define EACCES EPERM
3721 if (instr(s, "cannot make"))
3722 SETERRNO(EEXIST,RMS_FEX);
3723 else if (instr(s, "existing file"))
3724 SETERRNO(EEXIST,RMS_FEX);
3725 else if (instr(s, "ile exists"))
3726 SETERRNO(EEXIST,RMS_FEX);
3727 else if (instr(s, "non-exist"))
3728 SETERRNO(ENOENT,RMS_FNF);
3729 else if (instr(s, "does not exist"))
3730 SETERRNO(ENOENT,RMS_FNF);
3731 else if (instr(s, "not empty"))
3732 SETERRNO(EBUSY,SS_DEVOFFLINE);
3733 else if (instr(s, "cannot access"))
3734 SETERRNO(EACCES,RMS_PRV);
3736 SETERRNO(EPERM,RMS_PRV);
3739 else { /* some mkdirs return no failure indication */
3740 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3741 if (PL_op->op_type == OP_RMDIR)
3746 SETERRNO(EACCES,RMS_PRV); /* a guess */
3755 /* This macro removes trailing slashes from a directory name.
3756 * Different operating and file systems take differently to
3757 * trailing slashes. According to POSIX 1003.1 1996 Edition
3758 * any number of trailing slashes should be allowed.
3759 * Thusly we snip them away so that even non-conforming
3760 * systems are happy.
3761 * We should probably do this "filtering" for all
3762 * the functions that expect (potentially) directory names:
3763 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3764 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3766 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3767 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3770 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3771 (tmps) = savepvn((tmps), (len)); \
3781 const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3783 TRIMSLASHES(tmps,len,copy);
3785 TAINT_PROPER("mkdir");
3787 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3791 SETi( dooneliner("mkdir", tmps) );
3792 oldumask = PerlLIO_umask(0);
3793 PerlLIO_umask(oldumask);
3794 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3809 TRIMSLASHES(tmps,len,copy);
3810 TAINT_PROPER("rmdir");
3812 SETi( PerlDir_rmdir(tmps) >= 0 );
3814 SETi( dooneliner("rmdir", tmps) );
3821 /* Directory calls. */
3825 #if defined(Direntry_t) && defined(HAS_READDIR)
3827 const char * const dirname = POPpconstx;
3828 GV * const gv = MUTABLE_GV(POPs);
3829 register IO * const io = GvIOn(gv);
3834 if ((IoIFP(io) || IoOFP(io)))
3835 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3836 "Opening filehandle %"HEKf" also as a directory",
3837 HEKfARG(GvENAME_HEK(gv)) );
3839 PerlDir_close(IoDIRP(io));
3840 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3846 SETERRNO(EBADF,RMS_DIR);
3849 DIE(aTHX_ PL_no_dir_func, "opendir");
3855 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3856 DIE(aTHX_ PL_no_dir_func, "readdir");
3858 #if !defined(I_DIRENT) && !defined(VMS)
3859 Direntry_t *readdir (DIR *);
3865 const I32 gimme = GIMME;
3866 GV * const gv = MUTABLE_GV(POPs);
3867 register const Direntry_t *dp;
3868 register IO * const io = GvIOn(gv);
3870 if (!io || !IoDIRP(io)) {
3871 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3872 "readdir() attempted on invalid dirhandle %"HEKf,
3873 HEKfARG(GvENAME_HEK(gv)));
3878 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3882 sv = newSVpvn(dp->d_name, dp->d_namlen);
3884 sv = newSVpv(dp->d_name, 0);
3886 #ifndef INCOMPLETE_TAINTS
3887 if (!(IoFLAGS(io) & IOf_UNTAINT))
3891 } while (gimme == G_ARRAY);
3893 if (!dp && gimme != G_ARRAY)
3900 SETERRNO(EBADF,RMS_ISI);
3901 if (GIMME == G_ARRAY)
3910 #if defined(HAS_TELLDIR) || defined(telldir)
3912 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3913 /* XXX netbsd still seemed to.
3914 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3915 --JHI 1999-Feb-02 */
3916 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3917 long telldir (DIR *);
3919 GV * const gv = MUTABLE_GV(POPs);
3920 register IO * const io = GvIOn(gv);
3922 if (!io || !IoDIRP(io)) {
3923 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3924 "telldir() attempted on invalid dirhandle %"HEKf,
3925 HEKfARG(GvENAME_HEK(gv)));
3929 PUSHi( PerlDir_tell(IoDIRP(io)) );
3933 SETERRNO(EBADF,RMS_ISI);
3936 DIE(aTHX_ PL_no_dir_func, "telldir");
3942 #if defined(HAS_SEEKDIR) || defined(seekdir)
3944 const long along = POPl;
3945 GV * const gv = MUTABLE_GV(POPs);
3946 register IO * const io = GvIOn(gv);
3948 if (!io || !IoDIRP(io)) {
3949 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3950 "seekdir() attempted on invalid dirhandle %"HEKf,
3951 HEKfARG(GvENAME_HEK(gv)));
3954 (void)PerlDir_seek(IoDIRP(io), along);
3959 SETERRNO(EBADF,RMS_ISI);
3962 DIE(aTHX_ PL_no_dir_func, "seekdir");
3968 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3970 GV * const gv = MUTABLE_GV(POPs);
3971 register IO * const io = GvIOn(gv);
3973 if (!io || !IoDIRP(io)) {
3974 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3975 "rewinddir() attempted on invalid dirhandle %"HEKf,
3976 HEKfARG(GvENAME_HEK(gv)));
3979 (void)PerlDir_rewind(IoDIRP(io));
3983 SETERRNO(EBADF,RMS_ISI);
3986 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3992 #if defined(Direntry_t) && defined(HAS_READDIR)
3994 GV * const gv = MUTABLE_GV(POPs);
3995 register IO * const io = GvIOn(gv);
3997 if (!io || !IoDIRP(io)) {
3998 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3999 "closedir() attempted on invalid dirhandle %"HEKf,
4000 HEKfARG(GvENAME_HEK(gv)));
4003 #ifdef VOID_CLOSEDIR
4004 PerlDir_close(IoDIRP(io));
4006 if (PerlDir_close(IoDIRP(io)) < 0) {
4007 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4016 SETERRNO(EBADF,RMS_IFI);
4019 DIE(aTHX_ PL_no_dir_func, "closedir");
4023 /* Process control. */
4030 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4031 sigset_t oldmask, newmask;
4035 PERL_FLUSHALL_FOR_CHILD;
4036 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4037 sigfillset(&newmask);
4038 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4040 childpid = PerlProc_fork();
4041 if (childpid == 0) {
4045 for (sig = 1; sig < SIG_SIZE; sig++)
4046 PL_psig_pend[sig] = 0;
4048 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4051 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4058 #ifdef PERL_USES_PL_PIDSTATUS
4059 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4065 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4070 PERL_FLUSHALL_FOR_CHILD;
4071 childpid = PerlProc_fork();
4077 DIE(aTHX_ PL_no_func, "fork");
4084 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4089 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4090 childpid = wait4pid(-1, &argflags, 0);
4092 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4097 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4098 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4099 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4101 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4106 DIE(aTHX_ PL_no_func, "wait");
4112 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4114 const int optype = POPi;
4115 const Pid_t pid = TOPi;
4119 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4120 result = wait4pid(pid, &argflags, optype);
4122 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4127 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4128 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4129 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4131 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4136 DIE(aTHX_ PL_no_func, "waitpid");
4142 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4143 #if defined(__LIBCATAMOUNT__)
4144 PL_statusvalue = -1;
4153 while (++MARK <= SP) {
4154 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4159 TAINT_PROPER("system");
4161 PERL_FLUSHALL_FOR_CHILD;
4162 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4167 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4168 sigset_t newset, oldset;
4171 if (PerlProc_pipe(pp) >= 0)
4173 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4174 sigemptyset(&newset);
4175 sigaddset(&newset, SIGCHLD);
4176 sigprocmask(SIG_BLOCK, &newset, &oldset);
4178 while ((childpid = PerlProc_fork()) == -1) {
4179 if (errno != EAGAIN) {
4184 PerlLIO_close(pp[0]);
4185 PerlLIO_close(pp[1]);
4187 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4188 sigprocmask(SIG_SETMASK, &oldset, NULL);
4195 Sigsave_t ihand,qhand; /* place to save signals during system() */
4199 PerlLIO_close(pp[1]);
4201 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4202 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4205 result = wait4pid(childpid, &status, 0);
4206 } while (result == -1 && errno == EINTR);
4208 #ifdef HAS_SIGPROCMASK
4209 sigprocmask(SIG_SETMASK, &oldset, NULL);
4211 (void)rsignal_restore(SIGINT, &ihand);
4212 (void)rsignal_restore(SIGQUIT, &qhand);
4214 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4215 do_execfree(); /* free any memory child malloced on fork */
4222 while (n < sizeof(int)) {
4223 n1 = PerlLIO_read(pp[0],
4224 (void*)(((char*)&errkid)+n),
4230 PerlLIO_close(pp[0]);
4231 if (n) { /* Error */
4232 if (n != sizeof(int))
4233 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4234 errno = errkid; /* Propagate errno from kid */
4235 STATUS_NATIVE_CHILD_SET(-1);
4238 XPUSHi(STATUS_CURRENT);
4241 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4242 sigprocmask(SIG_SETMASK, &oldset, NULL);
4245 PerlLIO_close(pp[0]);
4246 #if defined(HAS_FCNTL) && defined(F_SETFD)
4247 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4250 if (PL_op->op_flags & OPf_STACKED) {
4251 SV * const really = *++MARK;
4252 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4254 else if (SP - MARK != 1)
4255 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4257 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4261 #else /* ! FORK or VMS or OS/2 */
4264 if (PL_op->op_flags & OPf_STACKED) {
4265 SV * const really = *++MARK;
4266 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4267 value = (I32)do_aspawn(really, MARK, SP);
4269 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4272 else if (SP - MARK != 1) {
4273 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4274 value = (I32)do_aspawn(NULL, MARK, SP);
4276 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4280 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4282 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4284 STATUS_NATIVE_CHILD_SET(value);
4287 XPUSHi(result ? value : STATUS_CURRENT);
4288 #endif /* !FORK or VMS or OS/2 */
4295 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4300 while (++MARK <= SP) {
4301 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4306 TAINT_PROPER("exec");
4308 PERL_FLUSHALL_FOR_CHILD;
4309 if (PL_op->op_flags & OPf_STACKED) {
4310 SV * const really = *++MARK;
4311 value = (I32)do_aexec(really, MARK, SP);
4313 else if (SP - MARK != 1)
4315 value = (I32)vms_do_aexec(NULL, MARK, SP);
4319 (void ) do_aspawn(NULL, MARK, SP);
4323 value = (I32)do_aexec(NULL, MARK, SP);
4328 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4331 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4334 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4348 XPUSHi( getppid() );
4351 DIE(aTHX_ PL_no_func, "getppid");
4361 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4364 pgrp = (I32)BSD_GETPGRP(pid);
4366 if (pid != 0 && pid != PerlProc_getpid())
4367 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4373 DIE(aTHX_ PL_no_func, "getpgrp()");
4383 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4384 if (MAXARG > 0) pid = TOPs && TOPi;
4390 TAINT_PROPER("setpgrp");
4392 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4394 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4395 || (pid != 0 && pid != PerlProc_getpid()))
4397 DIE(aTHX_ "setpgrp can't take arguments");
4399 SETi( setpgrp() >= 0 );
4400 #endif /* USE_BSDPGRP */
4403 DIE(aTHX_ PL_no_func, "setpgrp()");
4407 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4408 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4410 # define PRIORITY_WHICH_T(which) which
4415 #ifdef HAS_GETPRIORITY
4417 const int who = POPi;
4418 const int which = TOPi;
4419 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4422 DIE(aTHX_ PL_no_func, "getpriority()");
4428 #ifdef HAS_SETPRIORITY
4430 const int niceval = POPi;
4431 const int who = POPi;
4432 const int which = TOPi;
4433 TAINT_PROPER("setpriority");
4434 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4437 DIE(aTHX_ PL_no_func, "setpriority()");
4441 #undef PRIORITY_WHICH_T
4449 XPUSHn( time(NULL) );
4451 XPUSHi( time(NULL) );
4463 (void)PerlProc_times(&PL_timesbuf);
4465 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4466 /* struct tms, though same data */
4470 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4471 if (GIMME == G_ARRAY) {
4472 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4473 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4474 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4482 if (GIMME == G_ARRAY) {
4489 DIE(aTHX_ "times not implemented");
4491 #endif /* HAS_TIMES */
4494 /* The 32 bit int year limits the times we can represent to these
4495 boundaries with a few days wiggle room to account for time zone
4498 /* Sat Jan 3 00:00:00 -2147481748 */
4499 #define TIME_LOWER_BOUND -67768100567755200.0
4500 /* Sun Dec 29 12:00:00 2147483647 */
4501 #define TIME_UPPER_BOUND 67767976233316800.0
4510 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4511 static const char * const dayname[] =
4512 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4513 static const char * const monname[] =
4514 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4515 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4517 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4520 when = (Time64_T)now;
4523 NV input = Perl_floor(POPn);
4524 when = (Time64_T)input;
4525 if (when != input) {
4526 /* diag_listed_as: gmtime(%f) too large */
4527 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4528 "%s(%.0" NVff ") too large", opname, input);
4532 if ( TIME_LOWER_BOUND > when ) {
4533 /* diag_listed_as: gmtime(%f) too small */
4534 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4535 "%s(%.0" NVff ") too small", opname, when);
4538 else if( when > TIME_UPPER_BOUND ) {
4539 /* diag_listed_as: gmtime(%f) too small */
4540 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4541 "%s(%.0" NVff ") too large", opname, when);
4545 if (PL_op->op_type == OP_LOCALTIME)
4546 err = S_localtime64_r(&when, &tmbuf);
4548 err = S_gmtime64_r(&when, &tmbuf);
4552 /* XXX %lld broken for quads */
4553 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4554 "%s(%.0" NVff ") failed", opname, when);
4557 if (GIMME != G_ARRAY) { /* scalar context */
4559 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4560 double year = (double)tmbuf.tm_year + 1900;
4567 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4568 dayname[tmbuf.tm_wday],
4569 monname[tmbuf.tm_mon],
4577 else { /* list context */
4583 mPUSHi(tmbuf.tm_sec);
4584 mPUSHi(tmbuf.tm_min);
4585 mPUSHi(tmbuf.tm_hour);
4586 mPUSHi(tmbuf.tm_mday);
4587 mPUSHi(tmbuf.tm_mon);
4588 mPUSHn(tmbuf.tm_year);
4589 mPUSHi(tmbuf.tm_wday);
4590 mPUSHi(tmbuf.tm_yday);
4591 mPUSHi(tmbuf.tm_isdst);
4602 anum = alarm((unsigned int)anum);
4608 DIE(aTHX_ PL_no_func, "alarm");
4619 (void)time(&lasttime);
4620 if (MAXARG < 1 || (!TOPs && !POPs))
4624 PerlProc_sleep((unsigned int)duration);
4627 XPUSHi(when - lasttime);
4631 /* Shared memory. */
4632 /* Merged with some message passing. */
4636 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4637 dVAR; dSP; dMARK; dTARGET;
4638 const int op_type = PL_op->op_type;
4643 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4646 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4649 value = (I32)(do_semop(MARK, SP) >= 0);
4652 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4660 return Perl_pp_semget(aTHX);
4668 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4669 dVAR; dSP; dMARK; dTARGET;
4670 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4677 DIE(aTHX_ "System V IPC is not implemented on this machine");
4683 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4684 dVAR; dSP; dMARK; dTARGET;
4685 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4693 PUSHp(zero_but_true, ZBTLEN);
4697 return Perl_pp_semget(aTHX);
4701 /* I can't const this further without getting warnings about the types of
4702 various arrays passed in from structures. */
4704 S_space_join_names_mortal(pTHX_ char *const *array)
4708 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4710 if (array && *array) {
4711 target = newSVpvs_flags("", SVs_TEMP);
4713 sv_catpv(target, *array);
4716 sv_catpvs(target, " ");
4719 target = sv_mortalcopy(&PL_sv_no);
4724 /* Get system info. */
4728 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4730 I32 which = PL_op->op_type;
4731 register char **elem;
4733 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4734 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4735 struct hostent *gethostbyname(Netdb_name_t);
4736 struct hostent *gethostent(void);
4738 struct hostent *hent = NULL;
4742 if (which == OP_GHBYNAME) {
4743 #ifdef HAS_GETHOSTBYNAME
4744 const char* const name = POPpbytex;
4745 hent = PerlSock_gethostbyname(name);
4747 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4750 else if (which == OP_GHBYADDR) {
4751 #ifdef HAS_GETHOSTBYADDR
4752 const int addrtype = POPi;
4753 SV * const addrsv = POPs;
4755 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4757 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4759 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4763 #ifdef HAS_GETHOSTENT
4764 hent = PerlSock_gethostent();
4766 DIE(aTHX_ PL_no_sock_func, "gethostent");
4769 #ifdef HOST_NOT_FOUND
4771 #ifdef USE_REENTRANT_API
4772 # ifdef USE_GETHOSTENT_ERRNO
4773 h_errno = PL_reentrant_buffer->_gethostent_errno;
4776 STATUS_UNIX_SET(h_errno);
4780 if (GIMME != G_ARRAY) {
4781 PUSHs(sv = sv_newmortal());
4783 if (which == OP_GHBYNAME) {
4785 sv_setpvn(sv, hent->h_addr, hent->h_length);
4788 sv_setpv(sv, (char*)hent->h_name);
4794 mPUSHs(newSVpv((char*)hent->h_name, 0));
4795 PUSHs(space_join_names_mortal(hent->h_aliases));
4796 mPUSHi(hent->h_addrtype);
4797 len = hent->h_length;
4800 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4801 mXPUSHp(*elem, len);
4805 mPUSHp(hent->h_addr, len);
4807 PUSHs(sv_mortalcopy(&PL_sv_no));
4812 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4818 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4820 I32 which = PL_op->op_type;
4822 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4823 struct netent *getnetbyaddr(Netdb_net_t, int);
4824 struct netent *getnetbyname(Netdb_name_t);
4825 struct netent *getnetent(void);
4827 struct netent *nent;
4829 if (which == OP_GNBYNAME){
4830 #ifdef HAS_GETNETBYNAME
4831 const char * const name = POPpbytex;
4832 nent = PerlSock_getnetbyname(name);
4834 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4837 else if (which == OP_GNBYADDR) {
4838 #ifdef HAS_GETNETBYADDR
4839 const int addrtype = POPi;
4840 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4841 nent = PerlSock_getnetbyaddr(addr, addrtype);
4843 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4847 #ifdef HAS_GETNETENT
4848 nent = PerlSock_getnetent();
4850 DIE(aTHX_ PL_no_sock_func, "getnetent");
4853 #ifdef HOST_NOT_FOUND
4855 #ifdef USE_REENTRANT_API
4856 # ifdef USE_GETNETENT_ERRNO
4857 h_errno = PL_reentrant_buffer->_getnetent_errno;
4860 STATUS_UNIX_SET(h_errno);
4865 if (GIMME != G_ARRAY) {
4866 PUSHs(sv = sv_newmortal());
4868 if (which == OP_GNBYNAME)
4869 sv_setiv(sv, (IV)nent->n_net);
4871 sv_setpv(sv, nent->n_name);
4877 mPUSHs(newSVpv(nent->n_name, 0));
4878 PUSHs(space_join_names_mortal(nent->n_aliases));
4879 mPUSHi(nent->n_addrtype);
4880 mPUSHi(nent->n_net);
4885 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4891 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4893 I32 which = PL_op->op_type;
4895 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4896 struct protoent *getprotobyname(Netdb_name_t);
4897 struct protoent *getprotobynumber(int);
4898 struct protoent *getprotoent(void);
4900 struct protoent *pent;
4902 if (which == OP_GPBYNAME) {
4903 #ifdef HAS_GETPROTOBYNAME
4904 const char* const name = POPpbytex;
4905 pent = PerlSock_getprotobyname(name);
4907 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4910 else if (which == OP_GPBYNUMBER) {
4911 #ifdef HAS_GETPROTOBYNUMBER
4912 const int number = POPi;
4913 pent = PerlSock_getprotobynumber(number);
4915 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4919 #ifdef HAS_GETPROTOENT
4920 pent = PerlSock_getprotoent();
4922 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4926 if (GIMME != G_ARRAY) {
4927 PUSHs(sv = sv_newmortal());
4929 if (which == OP_GPBYNAME)
4930 sv_setiv(sv, (IV)pent->p_proto);
4932 sv_setpv(sv, pent->p_name);
4938 mPUSHs(newSVpv(pent->p_name, 0));
4939 PUSHs(space_join_names_mortal(pent->p_aliases));
4940 mPUSHi(pent->p_proto);
4945 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4951 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4953 I32 which = PL_op->op_type;
4955 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4956 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4957 struct servent *getservbyport(int, Netdb_name_t);
4958 struct servent *getservent(void);
4960 struct servent *sent;
4962 if (which == OP_GSBYNAME) {
4963 #ifdef HAS_GETSERVBYNAME
4964 const char * const proto = POPpbytex;
4965 const char * const name = POPpbytex;
4966 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4968 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4971 else if (which == OP_GSBYPORT) {
4972 #ifdef HAS_GETSERVBYPORT
4973 const char * const proto = POPpbytex;
4974 unsigned short port = (unsigned short)POPu;
4976 port = PerlSock_htons(port);
4978 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4980 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4984 #ifdef HAS_GETSERVENT
4985 sent = PerlSock_getservent();
4987 DIE(aTHX_ PL_no_sock_func, "getservent");
4991 if (GIMME != G_ARRAY) {
4992 PUSHs(sv = sv_newmortal());
4994 if (which == OP_GSBYNAME) {
4996 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4998 sv_setiv(sv, (IV)(sent->s_port));
5002 sv_setpv(sv, sent->s_name);
5008 mPUSHs(newSVpv(sent->s_name, 0));
5009 PUSHs(space_join_names_mortal(sent->s_aliases));
5011 mPUSHi(PerlSock_ntohs(sent->s_port));
5013 mPUSHi(sent->s_port);
5015 mPUSHs(newSVpv(sent->s_proto, 0));
5020 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5027 const int stayopen = TOPi;
5028 switch(PL_op->op_type) {
5030 #ifdef HAS_SETHOSTENT
5031 PerlSock_sethostent(stayopen);
5033 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5036 #ifdef HAS_SETNETENT
5038 PerlSock_setnetent(stayopen);
5040 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5044 #ifdef HAS_SETPROTOENT
5045 PerlSock_setprotoent(stayopen);
5047 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5051 #ifdef HAS_SETSERVENT
5052 PerlSock_setservent(stayopen);
5054 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5064 switch(PL_op->op_type) {
5066 #ifdef HAS_ENDHOSTENT
5067 PerlSock_endhostent();
5069 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5073 #ifdef HAS_ENDNETENT
5074 PerlSock_endnetent();
5076 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5080 #ifdef HAS_ENDPROTOENT
5081 PerlSock_endprotoent();
5083 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5087 #ifdef HAS_ENDSERVENT
5088 PerlSock_endservent();
5090 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5094 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5097 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5101 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5104 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5108 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5111 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5115 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5118 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5130 I32 which = PL_op->op_type;
5132 struct passwd *pwent = NULL;
5134 * We currently support only the SysV getsp* shadow password interface.
5135 * The interface is declared in <shadow.h> and often one needs to link
5136 * with -lsecurity or some such.
5137 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5140 * AIX getpwnam() is clever enough to return the encrypted password
5141 * only if the caller (euid?) is root.
5143 * There are at least three other shadow password APIs. Many platforms
5144 * seem to contain more than one interface for accessing the shadow
5145 * password databases, possibly for compatibility reasons.
5146 * The getsp*() is by far he simplest one, the other two interfaces
5147 * are much more complicated, but also very similar to each other.
5152 * struct pr_passwd *getprpw*();
5153 * The password is in
5154 * char getprpw*(...).ufld.fd_encrypt[]
5155 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5160 * struct es_passwd *getespw*();
5161 * The password is in
5162 * char *(getespw*(...).ufld.fd_encrypt)
5163 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5166 * struct userpw *getuserpw();
5167 * The password is in
5168 * char *(getuserpw(...)).spw_upw_passwd
5169 * (but the de facto standard getpwnam() should work okay)
5171 * Mention I_PROT here so that Configure probes for it.
5173 * In HP-UX for getprpw*() the manual page claims that one should include
5174 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5175 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5176 * and pp_sys.c already includes <shadow.h> if there is such.
5178 * Note that <sys/security.h> is already probed for, but currently
5179 * it is only included in special cases.
5181 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5182 * be preferred interface, even though also the getprpw*() interface
5183 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5184 * One also needs to call set_auth_parameters() in main() before
5185 * doing anything else, whether one is using getespw*() or getprpw*().
5187 * Note that accessing the shadow databases can be magnitudes
5188 * slower than accessing the standard databases.
5193 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5194 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5195 * the pw_comment is left uninitialized. */
5196 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5202 const char* const name = POPpbytex;
5203 pwent = getpwnam(name);
5209 pwent = getpwuid(uid);
5213 # ifdef HAS_GETPWENT
5215 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5216 if (pwent) pwent = getpwnam(pwent->pw_name);
5219 DIE(aTHX_ PL_no_func, "getpwent");
5225 if (GIMME != G_ARRAY) {
5226 PUSHs(sv = sv_newmortal());
5228 if (which == OP_GPWNAM)
5229 # if Uid_t_sign <= 0
5230 sv_setiv(sv, (IV)pwent->pw_uid);
5232 sv_setuv(sv, (UV)pwent->pw_uid);
5235 sv_setpv(sv, pwent->pw_name);
5241 mPUSHs(newSVpv(pwent->pw_name, 0));
5245 /* If we have getspnam(), we try to dig up the shadow
5246 * password. If we are underprivileged, the shadow
5247 * interface will set the errno to EACCES or similar,
5248 * and return a null pointer. If this happens, we will
5249 * use the dummy password (usually "*" or "x") from the
5250 * standard password database.
5252 * In theory we could skip the shadow call completely
5253 * if euid != 0 but in practice we cannot know which
5254 * security measures are guarding the shadow databases
5255 * on a random platform.
5257 * Resist the urge to use additional shadow interfaces.
5258 * Divert the urge to writing an extension instead.
5261 /* Some AIX setups falsely(?) detect some getspnam(), which
5262 * has a different API than the Solaris/IRIX one. */
5263 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5266 const struct spwd * const spwent = getspnam(pwent->pw_name);
5267 /* Save and restore errno so that
5268 * underprivileged attempts seem
5269 * to have never made the unsuccessful
5270 * attempt to retrieve the shadow password. */
5272 if (spwent && spwent->sp_pwdp)
5273 sv_setpv(sv, spwent->sp_pwdp);
5277 if (!SvPOK(sv)) /* Use the standard password, then. */
5278 sv_setpv(sv, pwent->pw_passwd);
5281 # ifndef INCOMPLETE_TAINTS
5282 /* passwd is tainted because user himself can diddle with it.
5283 * admittedly not much and in a very limited way, but nevertheless. */
5287 # if Uid_t_sign <= 0
5288 mPUSHi(pwent->pw_uid);
5290 mPUSHu(pwent->pw_uid);
5293 # if Uid_t_sign <= 0
5294 mPUSHi(pwent->pw_gid);
5296 mPUSHu(pwent->pw_gid);
5298 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5299 * because of the poor interface of the Perl getpw*(),
5300 * not because there's some standard/convention saying so.
5301 * A better interface would have been to return a hash,
5302 * but we are accursed by our history, alas. --jhi. */
5304 mPUSHi(pwent->pw_change);
5307 mPUSHi(pwent->pw_quota);
5310 mPUSHs(newSVpv(pwent->pw_age, 0));
5312 /* I think that you can never get this compiled, but just in case. */
5313 PUSHs(sv_mortalcopy(&PL_sv_no));
5318 /* pw_class and pw_comment are mutually exclusive--.
5319 * see the above note for pw_change, pw_quota, and pw_age. */
5321 mPUSHs(newSVpv(pwent->pw_class, 0));
5324 mPUSHs(newSVpv(pwent->pw_comment, 0));
5326 /* I think that you can never get this compiled, but just in case. */
5327 PUSHs(sv_mortalcopy(&PL_sv_no));
5332 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5334 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5336 # ifndef INCOMPLETE_TAINTS
5337 /* pw_gecos is tainted because user himself can diddle with it. */
5341 mPUSHs(newSVpv(pwent->pw_dir, 0));
5343 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5344 # ifndef INCOMPLETE_TAINTS
5345 /* pw_shell is tainted because user himself can diddle with it. */
5350 mPUSHi(pwent->pw_expire);
5355 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5363 const I32 which = PL_op->op_type;
5364 const struct group *grent;
5366 if (which == OP_GGRNAM) {
5367 const char* const name = POPpbytex;
5368 grent = (const struct group *)getgrnam(name);
5370 else if (which == OP_GGRGID) {
5371 const Gid_t gid = POPi;
5372 grent = (const struct group *)getgrgid(gid);
5376 grent = (struct group *)getgrent();
5378 DIE(aTHX_ PL_no_func, "getgrent");
5382 if (GIMME != G_ARRAY) {
5383 SV * const sv = sv_newmortal();
5387 if (which == OP_GGRNAM)
5389 sv_setiv(sv, (IV)grent->gr_gid);
5391 sv_setuv(sv, (UV)grent->gr_gid);
5394 sv_setpv(sv, grent->gr_name);
5400 mPUSHs(newSVpv(grent->gr_name, 0));
5403 mPUSHs(newSVpv(grent->gr_passwd, 0));
5405 PUSHs(sv_mortalcopy(&PL_sv_no));
5409 mPUSHi(grent->gr_gid);
5411 mPUSHu(grent->gr_gid);
5414 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5415 /* In UNICOS/mk (_CRAYMPP) the multithreading
5416 * versions (getgrnam_r, getgrgid_r)
5417 * seem to return an illegal pointer
5418 * as the group members list, gr_mem.
5419 * getgrent() doesn't even have a _r version
5420 * but the gr_mem is poisonous anyway.
5421 * So yes, you cannot get the list of group
5422 * members if building multithreaded in UNICOS/mk. */
5423 PUSHs(space_join_names_mortal(grent->gr_mem));
5429 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5439 if (!(tmps = PerlProc_getlogin()))
5441 sv_setpv_mg(TARG, tmps);
5445 DIE(aTHX_ PL_no_func, "getlogin");
5449 /* Miscellaneous. */
5454 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5455 register I32 items = SP - MARK;
5456 unsigned long a[20];
5461 while (++MARK <= SP) {
5462 if (SvTAINTED(*MARK)) {
5468 TAINT_PROPER("syscall");
5471 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5472 * or where sizeof(long) != sizeof(char*). But such machines will
5473 * not likely have syscall implemented either, so who cares?
5475 while (++MARK <= SP) {
5476 if (SvNIOK(*MARK) || !i)
5477 a[i++] = SvIV(*MARK);
5478 else if (*MARK == &PL_sv_undef)
5481 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5487 DIE(aTHX_ "Too many args to syscall");
5489 DIE(aTHX_ "Too few args to syscall");
5491 retval = syscall(a[0]);
5494 retval = syscall(a[0],a[1]);
5497 retval = syscall(a[0],a[1],a[2]);
5500 retval = syscall(a[0],a[1],a[2],a[3]);
5503 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5506 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5509 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5512 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5516 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5519 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5522 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5526 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5530 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5534 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5535 a[10],a[11],a[12],a[13]);
5537 #endif /* atarist */
5543 DIE(aTHX_ PL_no_func, "syscall");
5547 #ifdef FCNTL_EMULATE_FLOCK
5549 /* XXX Emulate flock() with fcntl().
5550 What's really needed is a good file locking module.
5554 fcntl_emulate_flock(int fd, int operation)
5559 switch (operation & ~LOCK_NB) {
5561 flock.l_type = F_RDLCK;
5564 flock.l_type = F_WRLCK;
5567 flock.l_type = F_UNLCK;
5573 flock.l_whence = SEEK_SET;
5574 flock.l_start = flock.l_len = (Off_t)0;
5576 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5577 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5578 errno = EWOULDBLOCK;
5582 #endif /* FCNTL_EMULATE_FLOCK */
5584 #ifdef LOCKF_EMULATE_FLOCK
5586 /* XXX Emulate flock() with lockf(). This is just to increase
5587 portability of scripts. The calls are not completely
5588 interchangeable. What's really needed is a good file
5592 /* The lockf() constants might have been defined in <unistd.h>.
5593 Unfortunately, <unistd.h> causes troubles on some mixed
5594 (BSD/POSIX) systems, such as SunOS 4.1.3.
5596 Further, the lockf() constants aren't POSIX, so they might not be
5597 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5598 just stick in the SVID values and be done with it. Sigh.
5602 # define F_ULOCK 0 /* Unlock a previously locked region */
5605 # define F_LOCK 1 /* Lock a region for exclusive use */
5608 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5611 # define F_TEST 3 /* Test a region for other processes locks */
5615 lockf_emulate_flock(int fd, int operation)
5621 /* flock locks entire file so for lockf we need to do the same */
5622 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5623 if (pos > 0) /* is seekable and needs to be repositioned */
5624 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5625 pos = -1; /* seek failed, so don't seek back afterwards */
5628 switch (operation) {
5630 /* LOCK_SH - get a shared lock */
5632 /* LOCK_EX - get an exclusive lock */
5634 i = lockf (fd, F_LOCK, 0);
5637 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5638 case LOCK_SH|LOCK_NB:
5639 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5640 case LOCK_EX|LOCK_NB:
5641 i = lockf (fd, F_TLOCK, 0);
5643 if ((errno == EAGAIN) || (errno == EACCES))
5644 errno = EWOULDBLOCK;
5647 /* LOCK_UN - unlock (non-blocking is a no-op) */
5649 case LOCK_UN|LOCK_NB:
5650 i = lockf (fd, F_ULOCK, 0);
5653 /* Default - can't decipher operation */
5660 if (pos > 0) /* need to restore position of the handle */
5661 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5666 #endif /* LOCKF_EMULATE_FLOCK */
5670 * c-indentation-style: bsd
5672 * indent-tabs-mode: nil
5675 * ex: set ts=8 sts=4 sw=4 et: