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 tryAMAGICunTARGET(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) {
443 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
444 /* well-formed exception supplied */
446 else if (SvROK(ERRSV)) {
449 else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
450 exsv = sv_mortalcopy(ERRSV);
451 sv_catpvs(exsv, "\t...caught");
454 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
456 if (SvROK(exsv) && !PL_warnhook)
457 Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
468 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
470 if (SP - MARK != 1) {
472 do_join(TARG, &PL_sv_no, MARK, SP);
480 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
481 /* well-formed exception supplied */
483 else if (SvROK(ERRSV)) {
485 if (sv_isobject(exsv)) {
486 HV * const stash = SvSTASH(SvRV(exsv));
487 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
489 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
490 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
497 call_sv(MUTABLE_SV(GvCV(gv)),
498 G_SCALAR|G_EVAL|G_KEEPERR);
499 exsv = sv_mortalcopy(*PL_stack_sp--);
503 else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
504 exsv = sv_mortalcopy(ERRSV);
505 sv_catpvs(exsv, "\t...propagated");
508 exsv = newSVpvs_flags("Died", SVs_TEMP);
516 Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv,
517 const MAGIC *const mg, const U32 flags, U32 argc, ...)
522 PERL_ARGS_ASSERT_TIED_METHOD;
524 /* Ensure that our flag bits do not overlap. */
525 assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
526 assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
527 assert((TIED_METHOD_SAY & G_WANT) == 0);
529 PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
530 PUSHSTACKi(PERLSI_MAGIC);
531 EXTEND(SP, argc+1); /* object + args */
533 PUSHs(SvTIED_obj(sv, mg));
534 if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
535 Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
539 const U32 mortalize_not_needed
540 = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
542 va_start(args, argc);
544 SV *const arg = va_arg(args, SV *);
545 if(mortalize_not_needed)
554 ENTER_with_name("call_tied_method");
555 if (flags & TIED_METHOD_SAY) {
556 /* local $\ = "\n" */
557 SAVEGENERICSV(PL_ors_sv);
558 PL_ors_sv = newSVpvs("\n");
560 ret_args = call_method(methname, flags & G_WANT);
565 if (ret_args) { /* copy results back to original stack */
566 EXTEND(sp, ret_args);
567 Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
571 LEAVE_with_name("call_tied_method");
575 #define tied_method0(a,b,c,d) \
576 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
577 #define tied_method1(a,b,c,d,e) \
578 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
579 #define tied_method2(a,b,c,d,e,f) \
580 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
593 GV * const gv = MUTABLE_GV(*++MARK);
595 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
596 DIE(aTHX_ PL_no_usym, "filehandle");
598 if ((io = GvIOp(gv))) {
600 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
603 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
604 "Opening dirhandle %"HEKf" also as a file",
605 HEKfARG(GvENAME_HEK(gv)));
607 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
609 /* Method's args are same as ours ... */
610 /* ... except handle is replaced by the object */
611 return Perl_tied_method(aTHX_ "OPEN", mark - 1, MUTABLE_SV(io), mg,
612 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
624 tmps = SvPV_const(sv, len);
625 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
628 PUSHi( (I32)PL_forkprocess );
629 else if (PL_forkprocess == 0) /* we are a new child */
640 MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
646 IO * const io = GvIO(gv);
648 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
650 return tied_method0("CLOSE", SP, MUTABLE_SV(io), mg);
654 PUSHs(boolSV(do_close(gv, TRUE)));
667 GV * const wgv = MUTABLE_GV(POPs);
668 GV * const rgv = MUTABLE_GV(POPs);
673 if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
674 DIE(aTHX_ PL_no_usym, "filehandle");
679 do_close(rgv, FALSE);
681 do_close(wgv, FALSE);
683 if (PerlProc_pipe(fd) < 0)
686 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
687 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
688 IoOFP(rstio) = IoIFP(rstio);
689 IoIFP(wstio) = IoOFP(wstio);
690 IoTYPE(rstio) = IoTYPE_RDONLY;
691 IoTYPE(wstio) = IoTYPE_WRONLY;
693 if (!IoIFP(rstio) || !IoOFP(wstio)) {
695 PerlIO_close(IoIFP(rstio));
697 PerlLIO_close(fd[0]);
699 PerlIO_close(IoOFP(wstio));
701 PerlLIO_close(fd[1]);
704 #if defined(HAS_FCNTL) && defined(F_SETFD)
705 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
706 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
713 DIE(aTHX_ PL_no_func, "pipe");
727 gv = MUTABLE_GV(POPs);
731 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
733 return tied_method0("FILENO", SP, MUTABLE_SV(io), mg);
736 if (!io || !(fp = IoIFP(io))) {
737 /* Can't do this because people seem to do things like
738 defined(fileno($foo)) to check whether $foo is a valid fh.
745 PUSHi(PerlIO_fileno(fp));
757 if (MAXARG < 1 || (!TOPs && !POPs)) {
758 anum = PerlLIO_umask(022);
759 /* setting it to 022 between the two calls to umask avoids
760 * to have a window where the umask is set to 0 -- meaning
761 * that another thread could create world-writeable files. */
763 (void)PerlLIO_umask(anum);
766 anum = PerlLIO_umask(POPi);
767 TAINT_PROPER("umask");
770 /* Only DIE if trying to restrict permissions on "user" (self).
771 * Otherwise it's harmless and more useful to just return undef
772 * since 'group' and 'other' concepts probably don't exist here. */
773 if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
774 DIE(aTHX_ "umask not implemented");
775 XPUSHs(&PL_sv_undef);
794 gv = MUTABLE_GV(POPs);
798 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
800 /* This takes advantage of the implementation of the varargs
801 function, which I don't think that the optimiser will be able to
802 figure out. Although, as it's a static function, in theory it
804 return Perl_tied_method(aTHX_ "BINMODE", SP, MUTABLE_SV(io), mg,
805 G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
806 discp ? 1 : 0, discp);
810 if (!io || !(fp = IoIFP(io))) {
812 SETERRNO(EBADF,RMS_IFI);
819 const char *d = NULL;
822 d = SvPV_const(discp, len);
823 mode = mode_from_discipline(d, len);
824 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
825 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
826 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
847 const I32 markoff = MARK - PL_stack_base;
848 const char *methname;
849 int how = PERL_MAGIC_tied;
853 switch(SvTYPE(varsv)) {
855 methname = "TIEHASH";
856 HvEITER_set(MUTABLE_HV(varsv), 0);
859 methname = "TIEARRAY";
860 if (!AvREAL(varsv)) {
862 Perl_croak(aTHX_ "Cannot tie unreifiable array");
863 av_clear((AV *)varsv);
870 if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
871 methname = "TIEHANDLE";
872 how = PERL_MAGIC_tiedscalar;
873 /* For tied filehandles, we apply tiedscalar magic to the IO
874 slot of the GP rather than the GV itself. AMS 20010812 */
876 GvIOp(varsv) = newIO();
877 varsv = MUTABLE_SV(GvIOp(varsv));
882 methname = "TIESCALAR";
883 how = PERL_MAGIC_tiedscalar;
887 if (sv_isobject(*MARK)) { /* Calls GET magic. */
888 ENTER_with_name("call_TIE");
889 PUSHSTACKi(PERLSI_MAGIC);
891 EXTEND(SP,(I32)items);
895 call_method(methname, G_SCALAR);
898 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
899 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
900 * wrong error message, and worse case, supreme action at a distance.
901 * (Sorry obfuscation writers. You're not going to be given this one.)
903 stash = gv_stashsv(*MARK, 0);
904 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
905 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
906 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
908 ENTER_with_name("call_TIE");
909 PUSHSTACKi(PERLSI_MAGIC);
911 EXTEND(SP,(I32)items);
915 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
921 if (sv_isobject(sv)) {
922 sv_unmagic(varsv, how);
923 /* Croak if a self-tie on an aggregate is attempted. */
924 if (varsv == SvRV(sv) &&
925 (SvTYPE(varsv) == SVt_PVAV ||
926 SvTYPE(varsv) == SVt_PVHV))
928 "Self-ties of arrays and hashes are not supported");
929 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
931 LEAVE_with_name("call_TIE");
932 SP = PL_stack_base + markoff;
942 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
943 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
945 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
948 if ((mg = SvTIED_mg(sv, how))) {
949 SV * const obj = SvRV(SvTIED_obj(sv, mg));
951 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
953 if (gv && isGV(gv) && (cv = GvCV(gv))) {
955 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
956 mXPUSHi(SvREFCNT(obj) - 1);
958 ENTER_with_name("call_UNTIE");
959 call_sv(MUTABLE_SV(cv), G_VOID);
960 LEAVE_with_name("call_UNTIE");
963 else if (mg && SvREFCNT(obj) > 1) {
964 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
965 "untie attempted while %"UVuf" inner references still exist",
966 (UV)SvREFCNT(obj) - 1 ) ;
970 sv_unmagic(sv, how) ;
980 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
981 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
983 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
986 if ((mg = SvTIED_mg(sv, how))) {
987 PUSHs(SvTIED_obj(sv, mg));
1000 HV * const hv = MUTABLE_HV(POPs);
1001 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1002 stash = gv_stashsv(sv, 0);
1003 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1005 require_pv("AnyDBM_File.pm");
1007 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1008 DIE(aTHX_ "No dbm on this machine");
1018 mPUSHu(O_RDWR|O_CREAT);
1022 if (!SvOK(right)) right = &PL_sv_no;
1026 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1029 if (!sv_isobject(TOPs)) {
1037 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1041 if (sv_isobject(TOPs)) {
1042 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1043 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1060 struct timeval timebuf;
1061 struct timeval *tbuf = &timebuf;
1064 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1069 # if BYTEORDER & 0xf0000
1070 # define ORDERBYTE (0x88888888 - BYTEORDER)
1072 # define ORDERBYTE (0x4444 - BYTEORDER)
1078 for (i = 1; i <= 3; i++) {
1079 SV * const sv = SP[i];
1083 if (SvREADONLY(sv)) {
1085 sv_force_normal_flags(sv, 0);
1086 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1087 Perl_croak_no_modify(aTHX);
1091 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1092 "Non-string passed as bitmask");
1093 SvPV_force_nomg_nolen(sv); /* force string conversion */
1100 /* little endians can use vecs directly */
1101 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1108 masksize = NFDBITS / NBBY;
1110 masksize = sizeof(long); /* documented int, everyone seems to use long */
1112 Zero(&fd_sets[0], 4, char*);
1115 # if SELECT_MIN_BITS == 1
1116 growsize = sizeof(fd_set);
1118 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1119 # undef SELECT_MIN_BITS
1120 # define SELECT_MIN_BITS __FD_SETSIZE
1122 /* If SELECT_MIN_BITS is greater than one we most probably will want
1123 * to align the sizes with SELECT_MIN_BITS/8 because for example
1124 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1125 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1126 * on (sets/tests/clears bits) is 32 bits. */
1127 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1135 timebuf.tv_sec = (long)value;
1136 value -= (NV)timebuf.tv_sec;
1137 timebuf.tv_usec = (long)(value * 1000000.0);
1142 for (i = 1; i <= 3; i++) {
1144 if (!SvOK(sv) || SvCUR(sv) == 0) {
1151 Sv_Grow(sv, growsize);
1155 while (++j <= growsize) {
1159 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1161 Newx(fd_sets[i], growsize, char);
1162 for (offset = 0; offset < growsize; offset += masksize) {
1163 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1164 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1167 fd_sets[i] = SvPVX(sv);
1171 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1172 /* Can't make just the (void*) conditional because that would be
1173 * cpp #if within cpp macro, and not all compilers like that. */
1174 nfound = PerlSock_select(
1176 (Select_fd_set_t) fd_sets[1],
1177 (Select_fd_set_t) fd_sets[2],
1178 (Select_fd_set_t) fd_sets[3],
1179 (void*) tbuf); /* Workaround for compiler bug. */
1181 nfound = PerlSock_select(
1183 (Select_fd_set_t) fd_sets[1],
1184 (Select_fd_set_t) fd_sets[2],
1185 (Select_fd_set_t) fd_sets[3],
1188 for (i = 1; i <= 3; i++) {
1191 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1193 for (offset = 0; offset < growsize; offset += masksize) {
1194 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1195 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1197 Safefree(fd_sets[i]);
1204 if (GIMME == G_ARRAY && tbuf) {
1205 value = (NV)(timebuf.tv_sec) +
1206 (NV)(timebuf.tv_usec) / 1000000.0;
1211 DIE(aTHX_ "select not implemented");
1216 =for apidoc setdefout
1218 Sets PL_defoutgv, the default file handle for output, to the passed in
1219 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1220 count of the passed in typeglob is increased by one, and the reference count
1221 of the typeglob that PL_defoutgv points to is decreased by one.
1227 Perl_setdefout(pTHX_ GV *gv)
1230 SvREFCNT_inc_simple_void(gv);
1231 SvREFCNT_dec(PL_defoutgv);
1239 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1240 GV * egv = GvEGVx(PL_defoutgv);
1245 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1246 gvp = hv && HvENAME(hv)
1247 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1249 if (gvp && *gvp == egv) {
1250 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1254 mXPUSHs(newRV(MUTABLE_SV(egv)));
1258 if (!GvIO(newdefout))
1259 gv_IOadd(newdefout);
1260 setdefout(newdefout);
1270 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1271 IO *const io = GvIO(gv);
1277 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1279 const U32 gimme = GIMME_V;
1280 Perl_tied_method(aTHX_ "GETC", SP, MUTABLE_SV(io), mg, gimme, 0);
1281 if (gimme == G_SCALAR) {
1283 SvSetMagicSV_nosteal(TARG, TOPs);
1288 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1289 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1291 SETERRNO(EBADF,RMS_IFI);
1295 sv_setpvs(TARG, " ");
1296 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1297 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1298 /* Find out how many bytes the char needs */
1299 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1302 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1303 SvCUR_set(TARG,1+len);
1312 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1315 register PERL_CONTEXT *cx;
1316 const I32 gimme = GIMME_V;
1318 PERL_ARGS_ASSERT_DOFORM;
1320 if (cv && CvCLONE(cv))
1321 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1326 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1327 PUSHFORMAT(cx, retop);
1329 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1331 setdefout(gv); /* locally select filehandle so $% et al work */
1350 gv = MUTABLE_GV(POPs);
1364 goto not_a_format_reference;
1368 tmpsv = sv_newmortal();
1369 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1370 if (SvPOK(tmpsv) && *SvPV_nolen_const(tmpsv))
1371 DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
1373 not_a_format_reference:
1374 DIE(aTHX_ "Not a format reference");
1376 IoFLAGS(io) &= ~IOf_DIDTOP;
1377 return doform(cv,gv,PL_op->op_next);
1383 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1384 register IO * const io = GvIOp(gv);
1389 register PERL_CONTEXT *cx;
1392 if (!io || !(ofp = IoOFP(io)))
1395 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1396 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1398 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1399 PL_formtarget != PL_toptarget)
1403 if (!IoTOP_GV(io)) {
1406 if (!IoTOP_NAME(io)) {
1408 if (!IoFMT_NAME(io))
1409 IoFMT_NAME(io) = savepv(GvNAME(gv));
1410 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1411 HEKfARG(GvNAME_HEK(gv))));
1412 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1413 if ((topgv && GvFORM(topgv)) ||
1414 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1415 IoTOP_NAME(io) = savesvpv(topname);
1417 IoTOP_NAME(io) = savepvs("top");
1419 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1420 if (!topgv || !GvFORM(topgv)) {
1421 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1424 IoTOP_GV(io) = topgv;
1426 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1427 I32 lines = IoLINES_LEFT(io);
1428 const char *s = SvPVX_const(PL_formtarget);
1429 if (lines <= 0) /* Yow, header didn't even fit!!! */
1431 while (lines-- > 0) {
1432 s = strchr(s, '\n');
1438 const STRLEN save = SvCUR(PL_formtarget);
1439 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1440 do_print(PL_formtarget, ofp);
1441 SvCUR_set(PL_formtarget, save);
1442 sv_chop(PL_formtarget, s);
1443 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1446 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1447 do_print(PL_formfeed, ofp);
1448 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1450 PL_formtarget = PL_toptarget;
1451 IoFLAGS(io) |= IOf_DIDTOP;
1454 DIE(aTHX_ "bad top format reference");
1457 SV * const sv = sv_newmortal();
1458 gv_efullname4(sv, fgv, NULL, FALSE);
1459 if (SvPOK(sv) && *SvPV_nolen_const(sv))
1460 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1462 DIE(aTHX_ "Undefined top format called");
1464 return doform(cv, gv, PL_op);
1468 POPBLOCK(cx,PL_curpm);
1470 retop = cx->blk_sub.retop;
1476 report_wrongway_fh(gv, '<');
1482 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1483 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1485 if (!do_print(PL_formtarget, fp))
1488 FmLINES(PL_formtarget) = 0;
1489 SvCUR_set(PL_formtarget, 0);
1490 *SvEND(PL_formtarget) = '\0';
1491 if (IoFLAGS(io) & IOf_FLUSH)
1492 (void)PerlIO_flush(fp);
1497 PL_formtarget = PL_bodytarget;
1499 PERL_UNUSED_VAR(newsp);
1500 PERL_UNUSED_VAR(gimme);
1506 dVAR; dSP; dMARK; dORIGMARK;
1511 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1512 IO *const io = GvIO(gv);
1515 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1517 if (MARK == ORIGMARK) {
1520 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1523 return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io),
1525 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1533 SETERRNO(EBADF,RMS_IFI);
1536 else if (!(fp = IoOFP(io))) {
1538 report_wrongway_fh(gv, '<');
1539 else if (ckWARN(WARN_CLOSED))
1541 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1545 do_sprintf(sv, SP - MARK, MARK + 1);
1546 if (!do_print(sv, fp))
1549 if (IoFLAGS(io) & IOf_FLUSH)
1550 if (PerlIO_flush(fp) == EOF)
1561 PUSHs(&PL_sv_undef);
1569 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1570 const int mode = POPi;
1571 SV * const sv = POPs;
1572 GV * const gv = MUTABLE_GV(POPs);
1575 /* Need TIEHANDLE method ? */
1576 const char * const tmps = SvPV_const(sv, len);
1577 /* FIXME? do_open should do const */
1578 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1579 IoLINES(GvIOp(gv)) = 0;
1583 PUSHs(&PL_sv_undef);
1590 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1604 bool charstart = FALSE;
1605 STRLEN charskip = 0;
1608 GV * const gv = MUTABLE_GV(*++MARK);
1609 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1610 && gv && (io = GvIO(gv)) )
1612 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1614 return Perl_tied_method(aTHX_ "READ", mark - 1, MUTABLE_SV(io), mg,
1615 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1624 sv_setpvs(bufsv, "");
1625 length = SvIVx(*++MARK);
1628 offset = SvIVx(*++MARK);
1632 if (!io || !IoIFP(io)) {
1634 SETERRNO(EBADF,RMS_IFI);
1637 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1638 buffer = SvPVutf8_force(bufsv, blen);
1639 /* UTF-8 may not have been set if they are all low bytes */
1644 buffer = SvPV_force(bufsv, blen);
1645 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1648 DIE(aTHX_ "Negative length");
1656 if (PL_op->op_type == OP_RECV) {
1657 Sock_size_t bufsize;
1658 char namebuf[MAXPATHLEN];
1659 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1660 bufsize = sizeof (struct sockaddr_in);
1662 bufsize = sizeof namebuf;
1664 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1668 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1669 /* 'offset' means 'flags' here */
1670 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1671 (struct sockaddr *)namebuf, &bufsize);
1674 /* MSG_TRUNC can give oversized count; quietly lose it */
1678 /* Bogus return without padding */
1679 bufsize = sizeof (struct sockaddr_in);
1681 SvCUR_set(bufsv, count);
1682 *SvEND(bufsv) = '\0';
1683 (void)SvPOK_only(bufsv);
1687 /* This should not be marked tainted if the fp is marked clean */
1688 if (!(IoFLAGS(io) & IOf_UNTAINT))
1689 SvTAINTED_on(bufsv);
1691 sv_setpvn(TARG, namebuf, bufsize);
1696 if (DO_UTF8(bufsv)) {
1697 /* offset adjust in characters not bytes */
1698 blen = sv_len_utf8(bufsv);
1701 if (-offset > (SSize_t)blen)
1702 DIE(aTHX_ "Offset outside string");
1705 if (DO_UTF8(bufsv)) {
1706 /* convert offset-as-chars to offset-as-bytes */
1707 if (offset >= (int)blen)
1708 offset += SvCUR(bufsv) - blen;
1710 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1713 orig_size = SvCUR(bufsv);
1714 /* Allocating length + offset + 1 isn't perfect in the case of reading
1715 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1717 (should be 2 * length + offset + 1, or possibly something longer if
1718 PL_encoding is true) */
1719 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1720 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1721 Zero(buffer+orig_size, offset-orig_size, char);
1723 buffer = buffer + offset;
1725 read_target = bufsv;
1727 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1728 concatenate it to the current buffer. */
1730 /* Truncate the existing buffer to the start of where we will be
1732 SvCUR_set(bufsv, offset);
1734 read_target = sv_newmortal();
1735 SvUPGRADE(read_target, SVt_PV);
1736 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1739 if (PL_op->op_type == OP_SYSREAD) {
1740 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1741 if (IoTYPE(io) == IoTYPE_SOCKET) {
1742 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1748 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1753 #ifdef HAS_SOCKET__bad_code_maybe
1754 if (IoTYPE(io) == IoTYPE_SOCKET) {
1755 Sock_size_t bufsize;
1756 char namebuf[MAXPATHLEN];
1757 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1758 bufsize = sizeof (struct sockaddr_in);
1760 bufsize = sizeof namebuf;
1762 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1763 (struct sockaddr *)namebuf, &bufsize);
1768 count = PerlIO_read(IoIFP(io), buffer, length);
1769 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1770 if (count == 0 && PerlIO_error(IoIFP(io)))
1774 if (IoTYPE(io) == IoTYPE_WRONLY)
1775 report_wrongway_fh(gv, '>');
1778 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1779 *SvEND(read_target) = '\0';
1780 (void)SvPOK_only(read_target);
1781 if (fp_utf8 && !IN_BYTES) {
1782 /* Look at utf8 we got back and count the characters */
1783 const char *bend = buffer + count;
1784 while (buffer < bend) {
1786 skip = UTF8SKIP(buffer);
1789 if (buffer - charskip + skip > bend) {
1790 /* partial character - try for rest of it */
1791 length = skip - (bend-buffer);
1792 offset = bend - SvPVX_const(bufsv);
1804 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1805 provided amount read (count) was what was requested (length)
1807 if (got < wanted && count == length) {
1808 length = wanted - got;
1809 offset = bend - SvPVX_const(bufsv);
1812 /* return value is character count */
1816 else if (buffer_utf8) {
1817 /* Let svcatsv upgrade the bytes we read in to utf8.
1818 The buffer is a mortal so will be freed soon. */
1819 sv_catsv_nomg(bufsv, read_target);
1822 /* This should not be marked tainted if the fp is marked clean */
1823 if (!(IoFLAGS(io) & IOf_UNTAINT))
1824 SvTAINTED_on(bufsv);
1836 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1841 STRLEN orig_blen_bytes;
1842 const int op_type = PL_op->op_type;
1845 GV *const gv = MUTABLE_GV(*++MARK);
1846 IO *const io = GvIO(gv);
1848 if (op_type == OP_SYSWRITE && io) {
1849 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1851 if (MARK == SP - 1) {
1853 mXPUSHi(sv_len(sv));
1857 return Perl_tied_method(aTHX_ "WRITE", mark - 1, MUTABLE_SV(io), mg,
1858 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1868 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1870 if (io && IoIFP(io))
1871 report_wrongway_fh(gv, '<');
1874 SETERRNO(EBADF,RMS_IFI);
1878 /* Do this first to trigger any overloading. */
1879 buffer = SvPV_const(bufsv, blen);
1880 orig_blen_bytes = blen;
1881 doing_utf8 = DO_UTF8(bufsv);
1883 if (PerlIO_isutf8(IoIFP(io))) {
1884 if (!SvUTF8(bufsv)) {
1885 /* We don't modify the original scalar. */
1886 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1887 buffer = (char *) tmpbuf;
1891 else if (doing_utf8) {
1892 STRLEN tmplen = blen;
1893 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1896 buffer = (char *) tmpbuf;
1900 assert((char *)result == buffer);
1901 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1906 if (op_type == OP_SEND) {
1907 const int flags = SvIVx(*++MARK);
1910 char * const sockbuf = SvPVx(*++MARK, mlen);
1911 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1912 flags, (struct sockaddr *)sockbuf, mlen);
1916 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1922 Size_t length = 0; /* This length is in characters. */
1928 /* The SV is bytes, and we've had to upgrade it. */
1929 blen_chars = orig_blen_bytes;
1931 /* The SV really is UTF-8. */
1932 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1933 /* Don't call sv_len_utf8 again because it will call magic
1934 or overloading a second time, and we might get back a
1935 different result. */
1936 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1938 /* It's safe, and it may well be cached. */
1939 blen_chars = sv_len_utf8(bufsv);
1947 length = blen_chars;
1949 #if Size_t_size > IVSIZE
1950 length = (Size_t)SvNVx(*++MARK);
1952 length = (Size_t)SvIVx(*++MARK);
1954 if ((SSize_t)length < 0) {
1956 DIE(aTHX_ "Negative length");
1961 offset = SvIVx(*++MARK);
1963 if (-offset > (IV)blen_chars) {
1965 DIE(aTHX_ "Offset outside string");
1967 offset += blen_chars;
1968 } else if (offset > (IV)blen_chars) {
1970 DIE(aTHX_ "Offset outside string");
1974 if (length > blen_chars - offset)
1975 length = blen_chars - offset;
1977 /* Here we convert length from characters to bytes. */
1978 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1979 /* Either we had to convert the SV, or the SV is magical, or
1980 the SV has overloading, in which case we can't or mustn't
1981 or mustn't call it again. */
1983 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1984 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1986 /* It's a real UTF-8 SV, and it's not going to change under
1987 us. Take advantage of any cache. */
1989 I32 len_I32 = length;
1991 /* Convert the start and end character positions to bytes.
1992 Remember that the second argument to sv_pos_u2b is relative
1994 sv_pos_u2b(bufsv, &start, &len_I32);
2001 buffer = buffer+offset;
2003 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2004 if (IoTYPE(io) == IoTYPE_SOCKET) {
2005 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
2011 /* See the note at doio.c:do_print about filesize limits. --jhi */
2012 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2021 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2024 #if Size_t_size > IVSIZE
2044 * in Perl 5.12 and later, the additional parameter is a bitmask:
2047 * 2 = eof() <- ARGV magic
2049 * I'll rely on the compiler's trace flow analysis to decide whether to
2050 * actually assign this out here, or punt it into the only block where it is
2051 * used. Doing it out here is DRY on the condition logic.
2056 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2062 if (PL_op->op_flags & OPf_SPECIAL) {
2063 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2067 gv = PL_last_in_gv; /* eof */
2075 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2076 return tied_method1("EOF", SP, MUTABLE_SV(io), mg, newSVuv(which));
2079 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2080 if (io && !IoIFP(io)) {
2081 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2083 IoFLAGS(io) &= ~IOf_START;
2084 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2086 sv_setpvs(GvSV(gv), "-");
2088 GvSV(gv) = newSVpvs("-");
2089 SvSETMAGIC(GvSV(gv));
2091 else if (!nextargv(gv))
2096 PUSHs(boolSV(do_eof(gv)));
2106 if (MAXARG != 0 && (TOPs || POPs))
2107 PL_last_in_gv = MUTABLE_GV(POPs);
2114 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2116 return tied_method0("TELL", SP, MUTABLE_SV(io), mg);
2121 SETERRNO(EBADF,RMS_IFI);
2126 #if LSEEKSIZE > IVSIZE
2127 PUSHn( do_tell(gv) );
2129 PUSHi( do_tell(gv) );
2137 const int whence = POPi;
2138 #if LSEEKSIZE > IVSIZE
2139 const Off_t offset = (Off_t)SvNVx(POPs);
2141 const Off_t offset = (Off_t)SvIVx(POPs);
2144 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2145 IO *const io = GvIO(gv);
2148 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2150 #if LSEEKSIZE > IVSIZE
2151 SV *const offset_sv = newSVnv((NV) offset);
2153 SV *const offset_sv = newSViv(offset);
2156 return tied_method2("SEEK", SP, MUTABLE_SV(io), mg, offset_sv,
2161 if (PL_op->op_type == OP_SEEK)
2162 PUSHs(boolSV(do_seek(gv, offset, whence)));
2164 const Off_t sought = do_sysseek(gv, offset, whence);
2166 PUSHs(&PL_sv_undef);
2168 SV* const sv = sought ?
2169 #if LSEEKSIZE > IVSIZE
2174 : newSVpvn(zero_but_true, ZBTLEN);
2185 /* There seems to be no consensus on the length type of truncate()
2186 * and ftruncate(), both off_t and size_t have supporters. In
2187 * general one would think that when using large files, off_t is
2188 * at least as wide as size_t, so using an off_t should be okay. */
2189 /* XXX Configure probe for the length type of *truncate() needed XXX */
2192 #if Off_t_size > IVSIZE
2197 /* Checking for length < 0 is problematic as the type might or
2198 * might not be signed: if it is not, clever compilers will moan. */
2199 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2202 SV * const sv = POPs;
2207 if ((tmpgv = PL_op->op_flags & OPf_SPECIAL
2208 ? gv_fetchsv(sv, 0, SVt_PVIO)
2209 : MAYBE_DEREF_GV(sv) )) {
2216 TAINT_PROPER("truncate");
2217 if (!(fp = IoIFP(io))) {
2223 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2225 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2231 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2232 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2233 goto do_ftruncate_io;
2236 const char * const name = SvPV_nomg_const_nolen(sv);
2237 TAINT_PROPER("truncate");
2239 if (truncate(name, len) < 0)
2243 const int tmpfd = PerlLIO_open(name, O_RDWR);
2248 if (my_chsize(tmpfd, len) < 0)
2250 PerlLIO_close(tmpfd);
2259 SETERRNO(EBADF,RMS_IFI);
2267 SV * const argsv = POPs;
2268 const unsigned int func = POPu;
2269 const int optype = PL_op->op_type;
2270 GV * const gv = MUTABLE_GV(POPs);
2271 IO * const io = gv ? GvIOn(gv) : NULL;
2275 if (!io || !argsv || !IoIFP(io)) {
2277 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2281 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2284 s = SvPV_force(argsv, len);
2285 need = IOCPARM_LEN(func);
2287 s = Sv_Grow(argsv, need + 1);
2288 SvCUR_set(argsv, need);
2291 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2294 retval = SvIV(argsv);
2295 s = INT2PTR(char*,retval); /* ouch */
2298 TAINT_PROPER(PL_op_desc[optype]);
2300 if (optype == OP_IOCTL)
2302 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2304 DIE(aTHX_ "ioctl is not implemented");
2308 DIE(aTHX_ "fcntl is not implemented");
2310 #if defined(OS2) && defined(__EMX__)
2311 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2313 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2317 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2319 if (s[SvCUR(argsv)] != 17)
2320 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2322 s[SvCUR(argsv)] = 0; /* put our null back */
2323 SvSETMAGIC(argsv); /* Assume it has changed */
2332 PUSHp(zero_but_true, ZBTLEN);
2343 const int argtype = POPi;
2344 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
2345 IO *const io = GvIO(gv);
2346 PerlIO *const fp = io ? IoIFP(io) : NULL;
2348 /* XXX Looks to me like io is always NULL at this point */
2350 (void)PerlIO_flush(fp);
2351 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2356 SETERRNO(EBADF,RMS_IFI);
2361 DIE(aTHX_ PL_no_func, "flock()");
2372 const int protocol = POPi;
2373 const int type = POPi;
2374 const int domain = POPi;
2375 GV * const gv = MUTABLE_GV(POPs);
2376 register IO * const io = gv ? GvIOn(gv) : NULL;
2381 if (io && IoIFP(io))
2382 do_close(gv, FALSE);
2383 SETERRNO(EBADF,LIB_INVARG);
2388 do_close(gv, FALSE);
2390 TAINT_PROPER("socket");
2391 fd = PerlSock_socket(domain, type, protocol);
2394 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2395 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2396 IoTYPE(io) = IoTYPE_SOCKET;
2397 if (!IoIFP(io) || !IoOFP(io)) {
2398 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2399 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2400 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2403 #if defined(HAS_FCNTL) && defined(F_SETFD)
2404 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2408 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2417 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2419 const int protocol = POPi;
2420 const int type = POPi;
2421 const int domain = POPi;
2422 GV * const gv2 = MUTABLE_GV(POPs);
2423 GV * const gv1 = MUTABLE_GV(POPs);
2424 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2425 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2429 report_evil_fh(gv1);
2431 report_evil_fh(gv2);
2433 if (io1 && IoIFP(io1))
2434 do_close(gv1, FALSE);
2435 if (io2 && IoIFP(io2))
2436 do_close(gv2, FALSE);
2441 TAINT_PROPER("socketpair");
2442 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2444 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2445 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2446 IoTYPE(io1) = IoTYPE_SOCKET;
2447 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2448 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2449 IoTYPE(io2) = IoTYPE_SOCKET;
2450 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2451 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2452 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2453 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2454 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2455 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2456 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2459 #if defined(HAS_FCNTL) && defined(F_SETFD)
2460 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2461 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2466 DIE(aTHX_ PL_no_sock_func, "socketpair");
2475 SV * const addrsv = POPs;
2476 /* OK, so on what platform does bind modify addr? */
2478 GV * const gv = MUTABLE_GV(POPs);
2479 register IO * const io = GvIOn(gv);
2481 const int op_type = PL_op->op_type;
2483 if (!io || !IoIFP(io))
2486 addr = SvPV_const(addrsv, len);
2487 TAINT_PROPER(PL_op_desc[op_type]);
2488 if ((op_type == OP_BIND
2489 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2490 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2498 SETERRNO(EBADF,SS_IVCHAN);
2505 const int backlog = POPi;
2506 GV * const gv = MUTABLE_GV(POPs);
2507 register IO * const io = gv ? GvIOn(gv) : NULL;
2509 if (!io || !IoIFP(io))
2512 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2519 SETERRNO(EBADF,SS_IVCHAN);
2528 char namebuf[MAXPATHLEN];
2529 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2530 Sock_size_t len = sizeof (struct sockaddr_in);
2532 Sock_size_t len = sizeof namebuf;
2534 GV * const ggv = MUTABLE_GV(POPs);
2535 GV * const ngv = MUTABLE_GV(POPs);
2544 if (!gstio || !IoIFP(gstio))
2548 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2551 /* Some platforms indicate zero length when an AF_UNIX client is
2552 * not bound. Simulate a non-zero-length sockaddr structure in
2554 namebuf[0] = 0; /* sun_len */
2555 namebuf[1] = AF_UNIX; /* sun_family */
2563 do_close(ngv, FALSE);
2564 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2565 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2566 IoTYPE(nstio) = IoTYPE_SOCKET;
2567 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2568 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2569 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2570 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2573 #if defined(HAS_FCNTL) && defined(F_SETFD)
2574 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2578 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2579 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2581 #ifdef __SCO_VERSION__
2582 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2585 PUSHp(namebuf, len);
2589 report_evil_fh(ggv);
2590 SETERRNO(EBADF,SS_IVCHAN);
2600 const int how = POPi;
2601 GV * const gv = MUTABLE_GV(POPs);
2602 register IO * const io = GvIOn(gv);
2604 if (!io || !IoIFP(io))
2607 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2612 SETERRNO(EBADF,SS_IVCHAN);
2619 const int optype = PL_op->op_type;
2620 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2621 const unsigned int optname = (unsigned int) POPi;
2622 const unsigned int lvl = (unsigned int) POPi;
2623 GV * const gv = MUTABLE_GV(POPs);
2624 register IO * const io = GvIOn(gv);
2628 if (!io || !IoIFP(io))
2631 fd = PerlIO_fileno(IoIFP(io));
2635 (void)SvPOK_only(sv);
2639 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2646 #if defined(__SYMBIAN32__)
2647 # define SETSOCKOPT_OPTION_VALUE_T void *
2649 # define SETSOCKOPT_OPTION_VALUE_T const char *
2651 /* XXX TODO: We need to have a proper type (a Configure probe,
2652 * etc.) for what the C headers think of the third argument of
2653 * setsockopt(), the option_value read-only buffer: is it
2654 * a "char *", or a "void *", const or not. Some compilers
2655 * don't take kindly to e.g. assuming that "char *" implicitly
2656 * promotes to a "void *", or to explicitly promoting/demoting
2657 * consts to non/vice versa. The "const void *" is the SUS
2658 * definition, but that does not fly everywhere for the above
2660 SETSOCKOPT_OPTION_VALUE_T buf;
2664 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2668 aint = (int)SvIV(sv);
2669 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2672 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2682 SETERRNO(EBADF,SS_IVCHAN);
2691 const int optype = PL_op->op_type;
2692 GV * const gv = MUTABLE_GV(POPs);
2693 register IO * const io = GvIOn(gv);
2698 if (!io || !IoIFP(io))
2701 sv = sv_2mortal(newSV(257));
2702 (void)SvPOK_only(sv);
2706 fd = PerlIO_fileno(IoIFP(io));
2708 case OP_GETSOCKNAME:
2709 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2712 case OP_GETPEERNAME:
2713 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2715 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2717 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";
2718 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2719 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2720 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2721 sizeof(u_short) + sizeof(struct in_addr))) {
2728 #ifdef BOGUS_GETNAME_RETURN
2729 /* Interactive Unix, getpeername() and getsockname()
2730 does not return valid namelen */
2731 if (len == BOGUS_GETNAME_RETURN)
2732 len = sizeof(struct sockaddr);
2741 SETERRNO(EBADF,SS_IVCHAN);
2760 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2761 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2762 if (PL_op->op_type == OP_LSTAT) {
2763 if (gv != PL_defgv) {
2764 do_fstat_warning_check:
2765 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2766 "lstat() on filehandle%s%"SVf,
2769 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2771 } else if (PL_laststype != OP_LSTAT)
2772 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2773 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2776 if (gv != PL_defgv) {
2780 PL_laststype = OP_STAT;
2781 PL_statgv = gv ? gv : (GV *)io;
2782 sv_setpvs(PL_statname, "");
2789 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2791 } else if (IoDIRP(io)) {
2793 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2796 PL_laststatval = -1;
2799 else PL_laststatval = -1;
2800 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2803 if (PL_laststatval < 0) {
2808 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2809 io = MUTABLE_IO(SvRV(sv));
2810 if (PL_op->op_type == OP_LSTAT)
2811 goto do_fstat_warning_check;
2812 goto do_fstat_have_io;
2815 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2817 PL_laststype = PL_op->op_type;
2818 if (PL_op->op_type == OP_LSTAT)
2819 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2821 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2822 if (PL_laststatval < 0) {
2823 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2824 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2830 if (gimme != G_ARRAY) {
2831 if (gimme != G_VOID)
2832 XPUSHs(boolSV(max));
2838 mPUSHi(PL_statcache.st_dev);
2839 #if ST_INO_SIZE > IVSIZE
2840 mPUSHn(PL_statcache.st_ino);
2842 # if ST_INO_SIGN <= 0
2843 mPUSHi(PL_statcache.st_ino);
2845 mPUSHu(PL_statcache.st_ino);
2848 mPUSHu(PL_statcache.st_mode);
2849 mPUSHu(PL_statcache.st_nlink);
2850 #if Uid_t_size > IVSIZE
2851 mPUSHn(PL_statcache.st_uid);
2853 # if Uid_t_sign <= 0
2854 mPUSHi(PL_statcache.st_uid);
2856 mPUSHu(PL_statcache.st_uid);
2859 #if Gid_t_size > IVSIZE
2860 mPUSHn(PL_statcache.st_gid);
2862 # if Gid_t_sign <= 0
2863 mPUSHi(PL_statcache.st_gid);
2865 mPUSHu(PL_statcache.st_gid);
2868 #ifdef USE_STAT_RDEV
2869 mPUSHi(PL_statcache.st_rdev);
2871 PUSHs(newSVpvs_flags("", SVs_TEMP));
2873 #if Off_t_size > IVSIZE
2874 mPUSHn(PL_statcache.st_size);
2876 mPUSHi(PL_statcache.st_size);
2879 mPUSHn(PL_statcache.st_atime);
2880 mPUSHn(PL_statcache.st_mtime);
2881 mPUSHn(PL_statcache.st_ctime);
2883 mPUSHi(PL_statcache.st_atime);
2884 mPUSHi(PL_statcache.st_mtime);
2885 mPUSHi(PL_statcache.st_ctime);
2887 #ifdef USE_STAT_BLOCKS
2888 mPUSHu(PL_statcache.st_blksize);
2889 mPUSHu(PL_statcache.st_blocks);
2891 PUSHs(newSVpvs_flags("", SVs_TEMP));
2892 PUSHs(newSVpvs_flags("", SVs_TEMP));
2898 /* If the next filetest is stacked up with this one
2899 (PL_op->op_private & OPpFT_STACKING), we leave
2900 the original argument on the stack for success,
2901 and skip the stacked operators on failure.
2902 The next few macros/functions take care of this.
2906 S_ft_stacking_return_false(pTHX_ SV *ret) {
2909 while (OP_IS_FILETEST(next->op_type)
2910 && next->op_private & OPpFT_STACKED)
2911 next = next->op_next;
2912 if (PL_op->op_flags & OPf_REF) PUSHs(ret);
2918 #define FT_RETURN_FALSE(X) \
2920 if (PL_op->op_private & OPpFT_STACKING) \
2921 return S_ft_stacking_return_false(aTHX_ X); \
2922 RETURNX(PUSHs(X)); \
2924 #define FT_RETURN_TRUE(X) \
2926 PL_op->op_private & OPpFT_STACKING \
2927 ? PL_op->op_flags & OPf_REF \
2928 ? PUSHs((SV *)cGVOP_gv) \
2933 #define FT_RETURNNO FT_RETURN_FALSE(&PL_sv_no)
2934 #define FT_RETURNUNDEF FT_RETURN_FALSE(&PL_sv_undef)
2935 #define FT_RETURNYES FT_RETURN_TRUE(&PL_sv_yes)
2937 #define tryAMAGICftest_MG(chr) STMT_START { \
2938 if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
2939 && PL_op->op_flags & OPf_KIDS) { \
2940 OP *next = S_try_amagic_ftest(aTHX_ chr); \
2941 if (next) return next; \
2946 S_try_amagic_ftest(pTHX_ char chr) {
2949 SV* const arg = TOPs;
2952 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
2956 const char tmpchr = chr;
2957 SV * const tmpsv = amagic_call(arg,
2958 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2959 ftest_amg, AMGf_unary);
2966 if (SvTRUE(tmpsv)) FT_RETURN_TRUE(tmpsv);
2967 FT_RETURN_FALSE(tmpsv);
2977 /* Not const, because things tweak this below. Not bool, because there's
2978 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2979 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2980 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2981 /* Giving some sort of initial value silences compilers. */
2983 int access_mode = R_OK;
2985 int access_mode = 0;
2988 /* access_mode is never used, but leaving use_access in makes the
2989 conditional compiling below much clearer. */
2992 Mode_t stat_mode = S_IRUSR;
2994 bool effective = FALSE;
2998 switch (PL_op->op_type) {
2999 case OP_FTRREAD: opchar = 'R'; break;
3000 case OP_FTRWRITE: opchar = 'W'; break;
3001 case OP_FTREXEC: opchar = 'X'; break;
3002 case OP_FTEREAD: opchar = 'r'; break;
3003 case OP_FTEWRITE: opchar = 'w'; break;
3004 case OP_FTEEXEC: opchar = 'x'; break;
3006 tryAMAGICftest_MG(opchar);
3008 switch (PL_op->op_type) {
3010 #if !(defined(HAS_ACCESS) && defined(R_OK))
3016 #if defined(HAS_ACCESS) && defined(W_OK)
3021 stat_mode = S_IWUSR;
3025 #if defined(HAS_ACCESS) && defined(X_OK)
3030 stat_mode = S_IXUSR;
3034 #ifdef PERL_EFF_ACCESS
3037 stat_mode = S_IWUSR;
3041 #ifndef PERL_EFF_ACCESS
3048 #ifdef PERL_EFF_ACCESS
3053 stat_mode = S_IXUSR;
3059 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3060 const char *name = POPpx;
3062 # ifdef PERL_EFF_ACCESS
3063 result = PERL_EFF_ACCESS(name, access_mode);
3065 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3071 result = access(name, access_mode);
3073 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3084 result = my_stat_flags(0);
3088 if (cando(stat_mode, effective, &PL_statcache))
3097 const int op_type = PL_op->op_type;
3102 case OP_FTIS: opchar = 'e'; break;
3103 case OP_FTSIZE: opchar = 's'; break;
3104 case OP_FTMTIME: opchar = 'M'; break;
3105 case OP_FTCTIME: opchar = 'C'; break;
3106 case OP_FTATIME: opchar = 'A'; break;
3108 tryAMAGICftest_MG(opchar);
3110 result = my_stat_flags(0);
3114 if (op_type == OP_FTIS)
3117 /* You can't dTARGET inside OP_FTIS, because you'll get
3118 "panic: pad_sv po" - the op is not flagged to have a target. */
3122 #if Off_t_size > IVSIZE
3123 sv_setnv(TARG, (NV)PL_statcache.st_size);
3125 sv_setiv(TARG, (IV)PL_statcache.st_size);
3130 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3134 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3138 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3142 if (SvTRUE_nomg(TARG)) FT_RETURN_TRUE(TARG);
3143 else FT_RETURN_FALSE(TARG);
3154 switch (PL_op->op_type) {
3155 case OP_FTROWNED: opchar = 'O'; break;
3156 case OP_FTEOWNED: opchar = 'o'; break;
3157 case OP_FTZERO: opchar = 'z'; break;
3158 case OP_FTSOCK: opchar = 'S'; break;
3159 case OP_FTCHR: opchar = 'c'; break;
3160 case OP_FTBLK: opchar = 'b'; break;
3161 case OP_FTFILE: opchar = 'f'; break;
3162 case OP_FTDIR: opchar = 'd'; break;
3163 case OP_FTPIPE: opchar = 'p'; break;
3164 case OP_FTSUID: opchar = 'u'; break;
3165 case OP_FTSGID: opchar = 'g'; break;
3166 case OP_FTSVTX: opchar = 'k'; break;
3168 tryAMAGICftest_MG(opchar);
3170 /* I believe that all these three are likely to be defined on most every
3171 system these days. */
3173 if(PL_op->op_type == OP_FTSUID) {
3174 if ((PL_op->op_flags & OPf_REF) == 0 && !(PL_op->op_private & OPpFT_STACKING))
3180 if(PL_op->op_type == OP_FTSGID) {
3181 if ((PL_op->op_flags & OPf_REF) == 0 && !(PL_op->op_private & OPpFT_STACKING))
3187 if(PL_op->op_type == OP_FTSVTX) {
3188 if ((PL_op->op_flags & OPf_REF) == 0 && !(PL_op->op_private & OPpFT_STACKING))
3194 result = my_stat_flags(0);
3198 switch (PL_op->op_type) {
3200 if (PL_statcache.st_uid == PL_uid)
3204 if (PL_statcache.st_uid == PL_euid)
3208 if (PL_statcache.st_size == 0)
3212 if (S_ISSOCK(PL_statcache.st_mode))
3216 if (S_ISCHR(PL_statcache.st_mode))
3220 if (S_ISBLK(PL_statcache.st_mode))
3224 if (S_ISREG(PL_statcache.st_mode))
3228 if (S_ISDIR(PL_statcache.st_mode))
3232 if (S_ISFIFO(PL_statcache.st_mode))
3237 if (PL_statcache.st_mode & S_ISUID)
3243 if (PL_statcache.st_mode & S_ISGID)
3249 if (PL_statcache.st_mode & S_ISVTX)
3263 tryAMAGICftest_MG('l');
3264 result = my_lstat_flags(0);
3269 if (S_ISLNK(PL_statcache.st_mode))
3283 tryAMAGICftest_MG('t');
3285 if (PL_op->op_flags & OPf_REF)
3288 SV *tmpsv = PL_op->op_private & OPpFT_STACKING ? TOPs : POPs;
3289 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3290 name = SvPV_nomg(tmpsv, namelen);
3291 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3295 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3296 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3297 else if (name && isDIGIT(*name))
3301 if (PerlLIO_isatty(fd))
3306 #if defined(atarist) /* this will work with atariST. Configure will
3307 make guesses for other systems. */
3308 # define FILE_base(f) ((f)->_base)
3309 # define FILE_ptr(f) ((f)->_ptr)
3310 # define FILE_cnt(f) ((f)->_cnt)
3311 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3322 register STDCHAR *s;
3324 register SV *sv = NULL;
3328 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3330 if (PL_op->op_flags & OPf_REF)
3336 sv = PL_op->op_private & OPpFT_STACKING ? TOPs : POPs;
3337 if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3340 else gv = MAYBE_DEREF_GV_nomg(sv);
3344 if (gv == PL_defgv) {
3346 io = SvTYPE(PL_statgv) == SVt_PVIO
3350 goto really_filename;
3355 sv_setpvs(PL_statname, "");
3356 io = GvIO(PL_statgv);
3358 PL_laststatval = -1;
3359 PL_laststype = OP_STAT;
3360 if (io && IoIFP(io)) {
3361 if (! PerlIO_has_base(IoIFP(io)))
3362 DIE(aTHX_ "-T and -B not implemented on filehandles");
3363 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3364 if (PL_laststatval < 0)
3366 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3367 if (PL_op->op_type == OP_FTTEXT)
3372 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3373 i = PerlIO_getc(IoIFP(io));
3375 (void)PerlIO_ungetc(IoIFP(io),i);
3377 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3379 len = PerlIO_get_bufsiz(IoIFP(io));
3380 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3381 /* sfio can have large buffers - limit to 512 */
3386 SETERRNO(EBADF,RMS_IFI);
3388 SETERRNO(EBADF,RMS_IFI);
3393 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3396 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3398 PL_laststatval = -1;
3399 PL_laststype = OP_STAT;
3401 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3403 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3406 PL_laststype = OP_STAT;
3407 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3408 if (PL_laststatval < 0) {
3409 (void)PerlIO_close(fp);
3412 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3413 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3414 (void)PerlIO_close(fp);
3416 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3417 FT_RETURNNO; /* special case NFS directories */
3418 FT_RETURNYES; /* null file is anything */
3423 /* now scan s to look for textiness */
3424 /* XXX ASCII dependent code */
3426 #if defined(DOSISH) || defined(USEMYBINMODE)
3427 /* ignore trailing ^Z on short files */
3428 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3432 for (i = 0; i < len; i++, s++) {
3433 if (!*s) { /* null never allowed in text */
3438 else if (!(isPRINT(*s) || isSPACE(*s)))
3441 else if (*s & 128) {
3443 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3446 /* utf8 characters don't count as odd */
3447 if (UTF8_IS_START(*s)) {
3448 int ulen = UTF8SKIP(s);
3449 if (ulen < len - i) {
3451 for (j = 1; j < ulen; j++) {
3452 if (!UTF8_IS_CONTINUATION(s[j]))
3455 --ulen; /* loop does extra increment */
3465 *s != '\n' && *s != '\r' && *s != '\b' &&
3466 *s != '\t' && *s != '\f' && *s != 27)
3471 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3482 const char *tmps = NULL;
3486 SV * const sv = POPs;
3487 if (PL_op->op_flags & OPf_SPECIAL) {
3488 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3490 else if (!(gv = MAYBE_DEREF_GV(sv)))
3491 tmps = SvPV_nomg_const_nolen(sv);
3494 if( !gv && (!tmps || !*tmps) ) {
3495 HV * const table = GvHVn(PL_envgv);
3498 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3499 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3501 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3506 deprecate("chdir('') or chdir(undef) as chdir()");
3507 tmps = SvPV_nolen_const(*svp);
3511 TAINT_PROPER("chdir");
3516 TAINT_PROPER("chdir");
3519 IO* const io = GvIO(gv);
3522 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3523 } else if (IoIFP(io)) {
3524 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3528 SETERRNO(EBADF, RMS_IFI);
3534 SETERRNO(EBADF,RMS_IFI);
3538 DIE(aTHX_ PL_no_func, "fchdir");
3542 PUSHi( PerlDir_chdir(tmps) >= 0 );
3544 /* Clear the DEFAULT element of ENV so we'll get the new value
3546 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3553 dVAR; dSP; dMARK; dTARGET;
3554 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3565 char * const tmps = POPpx;
3566 TAINT_PROPER("chroot");
3567 PUSHi( chroot(tmps) >= 0 );
3570 DIE(aTHX_ PL_no_func, "chroot");
3578 const char * const tmps2 = POPpconstx;
3579 const char * const tmps = SvPV_nolen_const(TOPs);
3580 TAINT_PROPER("rename");
3582 anum = PerlLIO_rename(tmps, tmps2);
3584 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3585 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3588 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3589 (void)UNLINK(tmps2);
3590 if (!(anum = link(tmps, tmps2)))
3591 anum = UNLINK(tmps);
3599 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3603 const int op_type = PL_op->op_type;
3607 if (op_type == OP_LINK)
3608 DIE(aTHX_ PL_no_func, "link");
3610 # ifndef HAS_SYMLINK
3611 if (op_type == OP_SYMLINK)
3612 DIE(aTHX_ PL_no_func, "symlink");
3616 const char * const tmps2 = POPpconstx;
3617 const char * const tmps = SvPV_nolen_const(TOPs);
3618 TAINT_PROPER(PL_op_desc[op_type]);
3620 # if defined(HAS_LINK)
3621 # if defined(HAS_SYMLINK)
3622 /* Both present - need to choose which. */
3623 (op_type == OP_LINK) ?
3624 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3626 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3627 PerlLIO_link(tmps, tmps2);
3630 # if defined(HAS_SYMLINK)
3631 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3632 symlink(tmps, tmps2);
3637 SETi( result >= 0 );
3644 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3655 char buf[MAXPATHLEN];
3658 #ifndef INCOMPLETE_TAINTS
3662 len = readlink(tmps, buf, sizeof(buf) - 1);
3669 RETSETUNDEF; /* just pretend it's a normal file */
3673 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3675 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3677 char * const save_filename = filename;
3682 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3684 PERL_ARGS_ASSERT_DOONELINER;
3686 Newx(cmdline, size, char);
3687 my_strlcpy(cmdline, cmd, size);
3688 my_strlcat(cmdline, " ", size);
3689 for (s = cmdline + strlen(cmdline); *filename; ) {
3693 if (s - cmdline < size)
3694 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3695 myfp = PerlProc_popen(cmdline, "r");
3699 SV * const tmpsv = sv_newmortal();
3700 /* Need to save/restore 'PL_rs' ?? */
3701 s = sv_gets(tmpsv, myfp, 0);
3702 (void)PerlProc_pclose(myfp);
3706 #ifdef HAS_SYS_ERRLIST
3711 /* you don't see this */
3712 const char * const errmsg =
3713 #ifdef HAS_SYS_ERRLIST
3721 if (instr(s, errmsg)) {
3728 #define EACCES EPERM
3730 if (instr(s, "cannot make"))
3731 SETERRNO(EEXIST,RMS_FEX);
3732 else if (instr(s, "existing file"))
3733 SETERRNO(EEXIST,RMS_FEX);
3734 else if (instr(s, "ile exists"))
3735 SETERRNO(EEXIST,RMS_FEX);
3736 else if (instr(s, "non-exist"))
3737 SETERRNO(ENOENT,RMS_FNF);
3738 else if (instr(s, "does not exist"))
3739 SETERRNO(ENOENT,RMS_FNF);
3740 else if (instr(s, "not empty"))
3741 SETERRNO(EBUSY,SS_DEVOFFLINE);
3742 else if (instr(s, "cannot access"))
3743 SETERRNO(EACCES,RMS_PRV);
3745 SETERRNO(EPERM,RMS_PRV);
3748 else { /* some mkdirs return no failure indication */
3749 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3750 if (PL_op->op_type == OP_RMDIR)
3755 SETERRNO(EACCES,RMS_PRV); /* a guess */
3764 /* This macro removes trailing slashes from a directory name.
3765 * Different operating and file systems take differently to
3766 * trailing slashes. According to POSIX 1003.1 1996 Edition
3767 * any number of trailing slashes should be allowed.
3768 * Thusly we snip them away so that even non-conforming
3769 * systems are happy.
3770 * We should probably do this "filtering" for all
3771 * the functions that expect (potentially) directory names:
3772 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3773 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3775 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3776 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3779 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3780 (tmps) = savepvn((tmps), (len)); \
3790 const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3792 TRIMSLASHES(tmps,len,copy);
3794 TAINT_PROPER("mkdir");
3796 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3800 SETi( dooneliner("mkdir", tmps) );
3801 oldumask = PerlLIO_umask(0);
3802 PerlLIO_umask(oldumask);
3803 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3818 TRIMSLASHES(tmps,len,copy);
3819 TAINT_PROPER("rmdir");
3821 SETi( PerlDir_rmdir(tmps) >= 0 );
3823 SETi( dooneliner("rmdir", tmps) );
3830 /* Directory calls. */
3834 #if defined(Direntry_t) && defined(HAS_READDIR)
3836 const char * const dirname = POPpconstx;
3837 GV * const gv = MUTABLE_GV(POPs);
3838 register IO * const io = GvIOn(gv);
3843 if ((IoIFP(io) || IoOFP(io)))
3844 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3845 "Opening filehandle %"HEKf" also as a directory",
3846 HEKfARG(GvENAME_HEK(gv)) );
3848 PerlDir_close(IoDIRP(io));
3849 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3855 SETERRNO(EBADF,RMS_DIR);
3858 DIE(aTHX_ PL_no_dir_func, "opendir");
3864 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3865 DIE(aTHX_ PL_no_dir_func, "readdir");
3867 #if !defined(I_DIRENT) && !defined(VMS)
3868 Direntry_t *readdir (DIR *);
3874 const I32 gimme = GIMME;
3875 GV * const gv = MUTABLE_GV(POPs);
3876 register const Direntry_t *dp;
3877 register IO * const io = GvIOn(gv);
3879 if (!io || !IoDIRP(io)) {
3880 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3881 "readdir() attempted on invalid dirhandle %"HEKf,
3882 HEKfARG(GvENAME_HEK(gv)));
3887 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3891 sv = newSVpvn(dp->d_name, dp->d_namlen);
3893 sv = newSVpv(dp->d_name, 0);
3895 #ifndef INCOMPLETE_TAINTS
3896 if (!(IoFLAGS(io) & IOf_UNTAINT))
3900 } while (gimme == G_ARRAY);
3902 if (!dp && gimme != G_ARRAY)
3909 SETERRNO(EBADF,RMS_ISI);
3910 if (GIMME == G_ARRAY)
3919 #if defined(HAS_TELLDIR) || defined(telldir)
3921 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3922 /* XXX netbsd still seemed to.
3923 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3924 --JHI 1999-Feb-02 */
3925 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3926 long telldir (DIR *);
3928 GV * const gv = MUTABLE_GV(POPs);
3929 register IO * const io = GvIOn(gv);
3931 if (!io || !IoDIRP(io)) {
3932 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3933 "telldir() attempted on invalid dirhandle %"HEKf,
3934 HEKfARG(GvENAME_HEK(gv)));
3938 PUSHi( PerlDir_tell(IoDIRP(io)) );
3942 SETERRNO(EBADF,RMS_ISI);
3945 DIE(aTHX_ PL_no_dir_func, "telldir");
3951 #if defined(HAS_SEEKDIR) || defined(seekdir)
3953 const long along = POPl;
3954 GV * const gv = MUTABLE_GV(POPs);
3955 register IO * const io = GvIOn(gv);
3957 if (!io || !IoDIRP(io)) {
3958 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3959 "seekdir() attempted on invalid dirhandle %"HEKf,
3960 HEKfARG(GvENAME_HEK(gv)));
3963 (void)PerlDir_seek(IoDIRP(io), along);
3968 SETERRNO(EBADF,RMS_ISI);
3971 DIE(aTHX_ PL_no_dir_func, "seekdir");
3977 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3979 GV * const gv = MUTABLE_GV(POPs);
3980 register IO * const io = GvIOn(gv);
3982 if (!io || !IoDIRP(io)) {
3983 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3984 "rewinddir() attempted on invalid dirhandle %"HEKf,
3985 HEKfARG(GvENAME_HEK(gv)));
3988 (void)PerlDir_rewind(IoDIRP(io));
3992 SETERRNO(EBADF,RMS_ISI);
3995 DIE(aTHX_ PL_no_dir_func, "rewinddir");
4001 #if defined(Direntry_t) && defined(HAS_READDIR)
4003 GV * const gv = MUTABLE_GV(POPs);
4004 register IO * const io = GvIOn(gv);
4006 if (!io || !IoDIRP(io)) {
4007 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4008 "closedir() attempted on invalid dirhandle %"HEKf,
4009 HEKfARG(GvENAME_HEK(gv)));
4012 #ifdef VOID_CLOSEDIR
4013 PerlDir_close(IoDIRP(io));
4015 if (PerlDir_close(IoDIRP(io)) < 0) {
4016 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4025 SETERRNO(EBADF,RMS_IFI);
4028 DIE(aTHX_ PL_no_dir_func, "closedir");
4032 /* Process control. */
4041 PERL_FLUSHALL_FOR_CHILD;
4042 childpid = PerlProc_fork();
4046 #ifdef THREADS_HAVE_PIDS
4047 PL_ppid = (IV)getppid();
4049 #ifdef PERL_USES_PL_PIDSTATUS
4050 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4056 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4061 PERL_FLUSHALL_FOR_CHILD;
4062 childpid = PerlProc_fork();
4068 DIE(aTHX_ PL_no_func, "fork");
4075 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4080 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4081 childpid = wait4pid(-1, &argflags, 0);
4083 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4088 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4089 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4090 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4092 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4097 DIE(aTHX_ PL_no_func, "wait");
4103 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4105 const int optype = POPi;
4106 const Pid_t pid = TOPi;
4110 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4111 result = wait4pid(pid, &argflags, optype);
4113 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4118 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4119 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4120 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4122 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4127 DIE(aTHX_ PL_no_func, "waitpid");
4133 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4134 #if defined(__LIBCATAMOUNT__)
4135 PL_statusvalue = -1;
4144 while (++MARK <= SP) {
4145 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4150 TAINT_PROPER("system");
4152 PERL_FLUSHALL_FOR_CHILD;
4153 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4158 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4159 sigset_t newset, oldset;
4162 if (PerlProc_pipe(pp) >= 0)
4164 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4165 sigemptyset(&newset);
4166 sigaddset(&newset, SIGCHLD);
4167 sigprocmask(SIG_BLOCK, &newset, &oldset);
4169 while ((childpid = PerlProc_fork()) == -1) {
4170 if (errno != EAGAIN) {
4175 PerlLIO_close(pp[0]);
4176 PerlLIO_close(pp[1]);
4178 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4179 sigprocmask(SIG_SETMASK, &oldset, NULL);
4186 Sigsave_t ihand,qhand; /* place to save signals during system() */
4190 PerlLIO_close(pp[1]);
4192 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4193 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4196 result = wait4pid(childpid, &status, 0);
4197 } while (result == -1 && errno == EINTR);
4199 #ifdef HAS_SIGPROCMASK
4200 sigprocmask(SIG_SETMASK, &oldset, NULL);
4202 (void)rsignal_restore(SIGINT, &ihand);
4203 (void)rsignal_restore(SIGQUIT, &qhand);
4205 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4206 do_execfree(); /* free any memory child malloced on fork */
4213 while (n < sizeof(int)) {
4214 n1 = PerlLIO_read(pp[0],
4215 (void*)(((char*)&errkid)+n),
4221 PerlLIO_close(pp[0]);
4222 if (n) { /* Error */
4223 if (n != sizeof(int))
4224 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4225 errno = errkid; /* Propagate errno from kid */
4226 STATUS_NATIVE_CHILD_SET(-1);
4229 XPUSHi(STATUS_CURRENT);
4232 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4233 sigprocmask(SIG_SETMASK, &oldset, NULL);
4236 PerlLIO_close(pp[0]);
4237 #if defined(HAS_FCNTL) && defined(F_SETFD)
4238 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4241 if (PL_op->op_flags & OPf_STACKED) {
4242 SV * const really = *++MARK;
4243 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4245 else if (SP - MARK != 1)
4246 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4248 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4252 #else /* ! FORK or VMS or OS/2 */
4255 if (PL_op->op_flags & OPf_STACKED) {
4256 SV * const really = *++MARK;
4257 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4258 value = (I32)do_aspawn(really, MARK, SP);
4260 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4263 else if (SP - MARK != 1) {
4264 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4265 value = (I32)do_aspawn(NULL, MARK, SP);
4267 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4271 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4273 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4275 STATUS_NATIVE_CHILD_SET(value);
4278 XPUSHi(result ? value : STATUS_CURRENT);
4279 #endif /* !FORK or VMS or OS/2 */
4286 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4291 while (++MARK <= SP) {
4292 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4297 TAINT_PROPER("exec");
4299 PERL_FLUSHALL_FOR_CHILD;
4300 if (PL_op->op_flags & OPf_STACKED) {
4301 SV * const really = *++MARK;
4302 value = (I32)do_aexec(really, MARK, SP);
4304 else if (SP - MARK != 1)
4306 value = (I32)vms_do_aexec(NULL, MARK, SP);
4310 (void ) do_aspawn(NULL, MARK, SP);
4314 value = (I32)do_aexec(NULL, MARK, SP);
4319 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4322 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4325 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4339 # ifdef THREADS_HAVE_PIDS
4340 if (PL_ppid != 1 && getppid() == 1)
4341 /* maybe the parent process has died. Refresh ppid cache */
4345 XPUSHi( getppid() );
4349 DIE(aTHX_ PL_no_func, "getppid");
4359 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4362 pgrp = (I32)BSD_GETPGRP(pid);
4364 if (pid != 0 && pid != PerlProc_getpid())
4365 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4371 DIE(aTHX_ PL_no_func, "getpgrp()");
4381 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4382 if (MAXARG > 0) pid = TOPs && TOPi;
4388 TAINT_PROPER("setpgrp");
4390 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4392 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4393 || (pid != 0 && pid != PerlProc_getpid()))
4395 DIE(aTHX_ "setpgrp can't take arguments");
4397 SETi( setpgrp() >= 0 );
4398 #endif /* USE_BSDPGRP */
4401 DIE(aTHX_ PL_no_func, "setpgrp()");
4405 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4406 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4408 # define PRIORITY_WHICH_T(which) which
4413 #ifdef HAS_GETPRIORITY
4415 const int who = POPi;
4416 const int which = TOPi;
4417 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4420 DIE(aTHX_ PL_no_func, "getpriority()");
4426 #ifdef HAS_SETPRIORITY
4428 const int niceval = POPi;
4429 const int who = POPi;
4430 const int which = TOPi;
4431 TAINT_PROPER("setpriority");
4432 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4435 DIE(aTHX_ PL_no_func, "setpriority()");
4439 #undef PRIORITY_WHICH_T
4447 XPUSHn( time(NULL) );
4449 XPUSHi( time(NULL) );
4461 (void)PerlProc_times(&PL_timesbuf);
4463 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4464 /* struct tms, though same data */
4468 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4469 if (GIMME == G_ARRAY) {
4470 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4471 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4472 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4480 if (GIMME == G_ARRAY) {
4487 DIE(aTHX_ "times not implemented");
4489 #endif /* HAS_TIMES */
4492 /* The 32 bit int year limits the times we can represent to these
4493 boundaries with a few days wiggle room to account for time zone
4496 /* Sat Jan 3 00:00:00 -2147481748 */
4497 #define TIME_LOWER_BOUND -67768100567755200.0
4498 /* Sun Dec 29 12:00:00 2147483647 */
4499 #define TIME_UPPER_BOUND 67767976233316800.0
4508 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4509 static const char * const dayname[] =
4510 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4511 static const char * const monname[] =
4512 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4513 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4515 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4518 when = (Time64_T)now;
4521 NV input = Perl_floor(POPn);
4522 when = (Time64_T)input;
4523 if (when != input) {
4524 /* diag_listed_as: gmtime(%f) too large */
4525 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4526 "%s(%.0" NVff ") too large", opname, input);
4530 if ( TIME_LOWER_BOUND > when ) {
4531 /* diag_listed_as: gmtime(%f) too small */
4532 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4533 "%s(%.0" NVff ") too small", opname, when);
4536 else if( when > TIME_UPPER_BOUND ) {
4537 /* diag_listed_as: gmtime(%f) too small */
4538 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4539 "%s(%.0" NVff ") too large", opname, when);
4543 if (PL_op->op_type == OP_LOCALTIME)
4544 err = S_localtime64_r(&when, &tmbuf);
4546 err = S_gmtime64_r(&when, &tmbuf);
4550 /* XXX %lld broken for quads */
4551 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4552 "%s(%.0" NVff ") failed", opname, when);
4555 if (GIMME != G_ARRAY) { /* scalar context */
4557 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4558 double year = (double)tmbuf.tm_year + 1900;
4565 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4566 dayname[tmbuf.tm_wday],
4567 monname[tmbuf.tm_mon],
4575 else { /* list context */
4581 mPUSHi(tmbuf.tm_sec);
4582 mPUSHi(tmbuf.tm_min);
4583 mPUSHi(tmbuf.tm_hour);
4584 mPUSHi(tmbuf.tm_mday);
4585 mPUSHi(tmbuf.tm_mon);
4586 mPUSHn(tmbuf.tm_year);
4587 mPUSHi(tmbuf.tm_wday);
4588 mPUSHi(tmbuf.tm_yday);
4589 mPUSHi(tmbuf.tm_isdst);
4600 anum = alarm((unsigned int)anum);
4606 DIE(aTHX_ PL_no_func, "alarm");
4617 (void)time(&lasttime);
4618 if (MAXARG < 1 || (!TOPs && !POPs))
4622 PerlProc_sleep((unsigned int)duration);
4625 XPUSHi(when - lasttime);
4629 /* Shared memory. */
4630 /* Merged with some message passing. */
4634 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4635 dVAR; dSP; dMARK; dTARGET;
4636 const int op_type = PL_op->op_type;
4641 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4644 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4647 value = (I32)(do_semop(MARK, SP) >= 0);
4650 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4658 return Perl_pp_semget(aTHX);
4666 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4667 dVAR; dSP; dMARK; dTARGET;
4668 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4675 DIE(aTHX_ "System V IPC is not implemented on this machine");
4681 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4682 dVAR; dSP; dMARK; dTARGET;
4683 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4691 PUSHp(zero_but_true, ZBTLEN);
4695 return Perl_pp_semget(aTHX);
4699 /* I can't const this further without getting warnings about the types of
4700 various arrays passed in from structures. */
4702 S_space_join_names_mortal(pTHX_ char *const *array)
4706 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4708 if (array && *array) {
4709 target = newSVpvs_flags("", SVs_TEMP);
4711 sv_catpv(target, *array);
4714 sv_catpvs(target, " ");
4717 target = sv_mortalcopy(&PL_sv_no);
4722 /* Get system info. */
4726 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4728 I32 which = PL_op->op_type;
4729 register char **elem;
4731 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4732 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4733 struct hostent *gethostbyname(Netdb_name_t);
4734 struct hostent *gethostent(void);
4736 struct hostent *hent = NULL;
4740 if (which == OP_GHBYNAME) {
4741 #ifdef HAS_GETHOSTBYNAME
4742 const char* const name = POPpbytex;
4743 hent = PerlSock_gethostbyname(name);
4745 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4748 else if (which == OP_GHBYADDR) {
4749 #ifdef HAS_GETHOSTBYADDR
4750 const int addrtype = POPi;
4751 SV * const addrsv = POPs;
4753 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4755 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4757 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4761 #ifdef HAS_GETHOSTENT
4762 hent = PerlSock_gethostent();
4764 DIE(aTHX_ PL_no_sock_func, "gethostent");
4767 #ifdef HOST_NOT_FOUND
4769 #ifdef USE_REENTRANT_API
4770 # ifdef USE_GETHOSTENT_ERRNO
4771 h_errno = PL_reentrant_buffer->_gethostent_errno;
4774 STATUS_UNIX_SET(h_errno);
4778 if (GIMME != G_ARRAY) {
4779 PUSHs(sv = sv_newmortal());
4781 if (which == OP_GHBYNAME) {
4783 sv_setpvn(sv, hent->h_addr, hent->h_length);
4786 sv_setpv(sv, (char*)hent->h_name);
4792 mPUSHs(newSVpv((char*)hent->h_name, 0));
4793 PUSHs(space_join_names_mortal(hent->h_aliases));
4794 mPUSHi(hent->h_addrtype);
4795 len = hent->h_length;
4798 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4799 mXPUSHp(*elem, len);
4803 mPUSHp(hent->h_addr, len);
4805 PUSHs(sv_mortalcopy(&PL_sv_no));
4810 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4816 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4818 I32 which = PL_op->op_type;
4820 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4821 struct netent *getnetbyaddr(Netdb_net_t, int);
4822 struct netent *getnetbyname(Netdb_name_t);
4823 struct netent *getnetent(void);
4825 struct netent *nent;
4827 if (which == OP_GNBYNAME){
4828 #ifdef HAS_GETNETBYNAME
4829 const char * const name = POPpbytex;
4830 nent = PerlSock_getnetbyname(name);
4832 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4835 else if (which == OP_GNBYADDR) {
4836 #ifdef HAS_GETNETBYADDR
4837 const int addrtype = POPi;
4838 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4839 nent = PerlSock_getnetbyaddr(addr, addrtype);
4841 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4845 #ifdef HAS_GETNETENT
4846 nent = PerlSock_getnetent();
4848 DIE(aTHX_ PL_no_sock_func, "getnetent");
4851 #ifdef HOST_NOT_FOUND
4853 #ifdef USE_REENTRANT_API
4854 # ifdef USE_GETNETENT_ERRNO
4855 h_errno = PL_reentrant_buffer->_getnetent_errno;
4858 STATUS_UNIX_SET(h_errno);
4863 if (GIMME != G_ARRAY) {
4864 PUSHs(sv = sv_newmortal());
4866 if (which == OP_GNBYNAME)
4867 sv_setiv(sv, (IV)nent->n_net);
4869 sv_setpv(sv, nent->n_name);
4875 mPUSHs(newSVpv(nent->n_name, 0));
4876 PUSHs(space_join_names_mortal(nent->n_aliases));
4877 mPUSHi(nent->n_addrtype);
4878 mPUSHi(nent->n_net);
4883 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4889 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4891 I32 which = PL_op->op_type;
4893 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4894 struct protoent *getprotobyname(Netdb_name_t);
4895 struct protoent *getprotobynumber(int);
4896 struct protoent *getprotoent(void);
4898 struct protoent *pent;
4900 if (which == OP_GPBYNAME) {
4901 #ifdef HAS_GETPROTOBYNAME
4902 const char* const name = POPpbytex;
4903 pent = PerlSock_getprotobyname(name);
4905 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4908 else if (which == OP_GPBYNUMBER) {
4909 #ifdef HAS_GETPROTOBYNUMBER
4910 const int number = POPi;
4911 pent = PerlSock_getprotobynumber(number);
4913 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4917 #ifdef HAS_GETPROTOENT
4918 pent = PerlSock_getprotoent();
4920 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4924 if (GIMME != G_ARRAY) {
4925 PUSHs(sv = sv_newmortal());
4927 if (which == OP_GPBYNAME)
4928 sv_setiv(sv, (IV)pent->p_proto);
4930 sv_setpv(sv, pent->p_name);
4936 mPUSHs(newSVpv(pent->p_name, 0));
4937 PUSHs(space_join_names_mortal(pent->p_aliases));
4938 mPUSHi(pent->p_proto);
4943 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4949 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4951 I32 which = PL_op->op_type;
4953 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4954 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4955 struct servent *getservbyport(int, Netdb_name_t);
4956 struct servent *getservent(void);
4958 struct servent *sent;
4960 if (which == OP_GSBYNAME) {
4961 #ifdef HAS_GETSERVBYNAME
4962 const char * const proto = POPpbytex;
4963 const char * const name = POPpbytex;
4964 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4966 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4969 else if (which == OP_GSBYPORT) {
4970 #ifdef HAS_GETSERVBYPORT
4971 const char * const proto = POPpbytex;
4972 unsigned short port = (unsigned short)POPu;
4974 port = PerlSock_htons(port);
4976 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4978 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4982 #ifdef HAS_GETSERVENT
4983 sent = PerlSock_getservent();
4985 DIE(aTHX_ PL_no_sock_func, "getservent");
4989 if (GIMME != G_ARRAY) {
4990 PUSHs(sv = sv_newmortal());
4992 if (which == OP_GSBYNAME) {
4994 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4996 sv_setiv(sv, (IV)(sent->s_port));
5000 sv_setpv(sv, sent->s_name);
5006 mPUSHs(newSVpv(sent->s_name, 0));
5007 PUSHs(space_join_names_mortal(sent->s_aliases));
5009 mPUSHi(PerlSock_ntohs(sent->s_port));
5011 mPUSHi(sent->s_port);
5013 mPUSHs(newSVpv(sent->s_proto, 0));
5018 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5025 const int stayopen = TOPi;
5026 switch(PL_op->op_type) {
5028 #ifdef HAS_SETHOSTENT
5029 PerlSock_sethostent(stayopen);
5031 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5034 #ifdef HAS_SETNETENT
5036 PerlSock_setnetent(stayopen);
5038 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5042 #ifdef HAS_SETPROTOENT
5043 PerlSock_setprotoent(stayopen);
5045 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5049 #ifdef HAS_SETSERVENT
5050 PerlSock_setservent(stayopen);
5052 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5062 switch(PL_op->op_type) {
5064 #ifdef HAS_ENDHOSTENT
5065 PerlSock_endhostent();
5067 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5071 #ifdef HAS_ENDNETENT
5072 PerlSock_endnetent();
5074 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5078 #ifdef HAS_ENDPROTOENT
5079 PerlSock_endprotoent();
5081 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5085 #ifdef HAS_ENDSERVENT
5086 PerlSock_endservent();
5088 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5092 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5095 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5099 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5102 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5106 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5109 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5113 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5116 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5128 I32 which = PL_op->op_type;
5130 struct passwd *pwent = NULL;
5132 * We currently support only the SysV getsp* shadow password interface.
5133 * The interface is declared in <shadow.h> and often one needs to link
5134 * with -lsecurity or some such.
5135 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5138 * AIX getpwnam() is clever enough to return the encrypted password
5139 * only if the caller (euid?) is root.
5141 * There are at least three other shadow password APIs. Many platforms
5142 * seem to contain more than one interface for accessing the shadow
5143 * password databases, possibly for compatibility reasons.
5144 * The getsp*() is by far he simplest one, the other two interfaces
5145 * are much more complicated, but also very similar to each other.
5150 * struct pr_passwd *getprpw*();
5151 * The password is in
5152 * char getprpw*(...).ufld.fd_encrypt[]
5153 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5158 * struct es_passwd *getespw*();
5159 * The password is in
5160 * char *(getespw*(...).ufld.fd_encrypt)
5161 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5164 * struct userpw *getuserpw();
5165 * The password is in
5166 * char *(getuserpw(...)).spw_upw_passwd
5167 * (but the de facto standard getpwnam() should work okay)
5169 * Mention I_PROT here so that Configure probes for it.
5171 * In HP-UX for getprpw*() the manual page claims that one should include
5172 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5173 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5174 * and pp_sys.c already includes <shadow.h> if there is such.
5176 * Note that <sys/security.h> is already probed for, but currently
5177 * it is only included in special cases.
5179 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5180 * be preferred interface, even though also the getprpw*() interface
5181 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5182 * One also needs to call set_auth_parameters() in main() before
5183 * doing anything else, whether one is using getespw*() or getprpw*().
5185 * Note that accessing the shadow databases can be magnitudes
5186 * slower than accessing the standard databases.
5191 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5192 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5193 * the pw_comment is left uninitialized. */
5194 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5200 const char* const name = POPpbytex;
5201 pwent = getpwnam(name);
5207 pwent = getpwuid(uid);
5211 # ifdef HAS_GETPWENT
5213 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5214 if (pwent) pwent = getpwnam(pwent->pw_name);
5217 DIE(aTHX_ PL_no_func, "getpwent");
5223 if (GIMME != G_ARRAY) {
5224 PUSHs(sv = sv_newmortal());
5226 if (which == OP_GPWNAM)
5227 # if Uid_t_sign <= 0
5228 sv_setiv(sv, (IV)pwent->pw_uid);
5230 sv_setuv(sv, (UV)pwent->pw_uid);
5233 sv_setpv(sv, pwent->pw_name);
5239 mPUSHs(newSVpv(pwent->pw_name, 0));
5243 /* If we have getspnam(), we try to dig up the shadow
5244 * password. If we are underprivileged, the shadow
5245 * interface will set the errno to EACCES or similar,
5246 * and return a null pointer. If this happens, we will
5247 * use the dummy password (usually "*" or "x") from the
5248 * standard password database.
5250 * In theory we could skip the shadow call completely
5251 * if euid != 0 but in practice we cannot know which
5252 * security measures are guarding the shadow databases
5253 * on a random platform.
5255 * Resist the urge to use additional shadow interfaces.
5256 * Divert the urge to writing an extension instead.
5259 /* Some AIX setups falsely(?) detect some getspnam(), which
5260 * has a different API than the Solaris/IRIX one. */
5261 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5264 const struct spwd * const spwent = getspnam(pwent->pw_name);
5265 /* Save and restore errno so that
5266 * underprivileged attempts seem
5267 * to have never made the unsuccessful
5268 * attempt to retrieve the shadow password. */
5270 if (spwent && spwent->sp_pwdp)
5271 sv_setpv(sv, spwent->sp_pwdp);
5275 if (!SvPOK(sv)) /* Use the standard password, then. */
5276 sv_setpv(sv, pwent->pw_passwd);
5279 # ifndef INCOMPLETE_TAINTS
5280 /* passwd is tainted because user himself can diddle with it.
5281 * admittedly not much and in a very limited way, but nevertheless. */
5285 # if Uid_t_sign <= 0
5286 mPUSHi(pwent->pw_uid);
5288 mPUSHu(pwent->pw_uid);
5291 # if Uid_t_sign <= 0
5292 mPUSHi(pwent->pw_gid);
5294 mPUSHu(pwent->pw_gid);
5296 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5297 * because of the poor interface of the Perl getpw*(),
5298 * not because there's some standard/convention saying so.
5299 * A better interface would have been to return a hash,
5300 * but we are accursed by our history, alas. --jhi. */
5302 mPUSHi(pwent->pw_change);
5305 mPUSHi(pwent->pw_quota);
5308 mPUSHs(newSVpv(pwent->pw_age, 0));
5310 /* I think that you can never get this compiled, but just in case. */
5311 PUSHs(sv_mortalcopy(&PL_sv_no));
5316 /* pw_class and pw_comment are mutually exclusive--.
5317 * see the above note for pw_change, pw_quota, and pw_age. */
5319 mPUSHs(newSVpv(pwent->pw_class, 0));
5322 mPUSHs(newSVpv(pwent->pw_comment, 0));
5324 /* I think that you can never get this compiled, but just in case. */
5325 PUSHs(sv_mortalcopy(&PL_sv_no));
5330 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5332 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5334 # ifndef INCOMPLETE_TAINTS
5335 /* pw_gecos is tainted because user himself can diddle with it. */
5339 mPUSHs(newSVpv(pwent->pw_dir, 0));
5341 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5342 # ifndef INCOMPLETE_TAINTS
5343 /* pw_shell is tainted because user himself can diddle with it. */
5348 mPUSHi(pwent->pw_expire);
5353 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5361 const I32 which = PL_op->op_type;
5362 const struct group *grent;
5364 if (which == OP_GGRNAM) {
5365 const char* const name = POPpbytex;
5366 grent = (const struct group *)getgrnam(name);
5368 else if (which == OP_GGRGID) {
5369 const Gid_t gid = POPi;
5370 grent = (const struct group *)getgrgid(gid);
5374 grent = (struct group *)getgrent();
5376 DIE(aTHX_ PL_no_func, "getgrent");
5380 if (GIMME != G_ARRAY) {
5381 SV * const sv = sv_newmortal();
5385 if (which == OP_GGRNAM)
5387 sv_setiv(sv, (IV)grent->gr_gid);
5389 sv_setuv(sv, (UV)grent->gr_gid);
5392 sv_setpv(sv, grent->gr_name);
5398 mPUSHs(newSVpv(grent->gr_name, 0));
5401 mPUSHs(newSVpv(grent->gr_passwd, 0));
5403 PUSHs(sv_mortalcopy(&PL_sv_no));
5407 mPUSHi(grent->gr_gid);
5409 mPUSHu(grent->gr_gid);
5412 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5413 /* In UNICOS/mk (_CRAYMPP) the multithreading
5414 * versions (getgrnam_r, getgrgid_r)
5415 * seem to return an illegal pointer
5416 * as the group members list, gr_mem.
5417 * getgrent() doesn't even have a _r version
5418 * but the gr_mem is poisonous anyway.
5419 * So yes, you cannot get the list of group
5420 * members if building multithreaded in UNICOS/mk. */
5421 PUSHs(space_join_names_mortal(grent->gr_mem));
5427 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5437 if (!(tmps = PerlProc_getlogin()))
5439 sv_setpv_mg(TARG, tmps);
5443 DIE(aTHX_ PL_no_func, "getlogin");
5447 /* Miscellaneous. */
5452 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5453 register I32 items = SP - MARK;
5454 unsigned long a[20];
5459 while (++MARK <= SP) {
5460 if (SvTAINTED(*MARK)) {
5466 TAINT_PROPER("syscall");
5469 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5470 * or where sizeof(long) != sizeof(char*). But such machines will
5471 * not likely have syscall implemented either, so who cares?
5473 while (++MARK <= SP) {
5474 if (SvNIOK(*MARK) || !i)
5475 a[i++] = SvIV(*MARK);
5476 else if (*MARK == &PL_sv_undef)
5479 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5485 DIE(aTHX_ "Too many args to syscall");
5487 DIE(aTHX_ "Too few args to syscall");
5489 retval = syscall(a[0]);
5492 retval = syscall(a[0],a[1]);
5495 retval = syscall(a[0],a[1],a[2]);
5498 retval = syscall(a[0],a[1],a[2],a[3]);
5501 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5504 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5507 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5510 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5514 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5517 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5520 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5524 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5528 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5532 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5533 a[10],a[11],a[12],a[13]);
5535 #endif /* atarist */
5541 DIE(aTHX_ PL_no_func, "syscall");
5545 #ifdef FCNTL_EMULATE_FLOCK
5547 /* XXX Emulate flock() with fcntl().
5548 What's really needed is a good file locking module.
5552 fcntl_emulate_flock(int fd, int operation)
5557 switch (operation & ~LOCK_NB) {
5559 flock.l_type = F_RDLCK;
5562 flock.l_type = F_WRLCK;
5565 flock.l_type = F_UNLCK;
5571 flock.l_whence = SEEK_SET;
5572 flock.l_start = flock.l_len = (Off_t)0;
5574 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5575 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5576 errno = EWOULDBLOCK;
5580 #endif /* FCNTL_EMULATE_FLOCK */
5582 #ifdef LOCKF_EMULATE_FLOCK
5584 /* XXX Emulate flock() with lockf(). This is just to increase
5585 portability of scripts. The calls are not completely
5586 interchangeable. What's really needed is a good file
5590 /* The lockf() constants might have been defined in <unistd.h>.
5591 Unfortunately, <unistd.h> causes troubles on some mixed
5592 (BSD/POSIX) systems, such as SunOS 4.1.3.
5594 Further, the lockf() constants aren't POSIX, so they might not be
5595 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5596 just stick in the SVID values and be done with it. Sigh.
5600 # define F_ULOCK 0 /* Unlock a previously locked region */
5603 # define F_LOCK 1 /* Lock a region for exclusive use */
5606 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5609 # define F_TEST 3 /* Test a region for other processes locks */
5613 lockf_emulate_flock(int fd, int operation)
5619 /* flock locks entire file so for lockf we need to do the same */
5620 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5621 if (pos > 0) /* is seekable and needs to be repositioned */
5622 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5623 pos = -1; /* seek failed, so don't seek back afterwards */
5626 switch (operation) {
5628 /* LOCK_SH - get a shared lock */
5630 /* LOCK_EX - get an exclusive lock */
5632 i = lockf (fd, F_LOCK, 0);
5635 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5636 case LOCK_SH|LOCK_NB:
5637 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5638 case LOCK_EX|LOCK_NB:
5639 i = lockf (fd, F_TLOCK, 0);
5641 if ((errno == EAGAIN) || (errno == EACCES))
5642 errno = EWOULDBLOCK;
5645 /* LOCK_UN - unlock (non-blocking is a no-op) */
5647 case LOCK_UN|LOCK_NB:
5648 i = lockf (fd, F_ULOCK, 0);
5651 /* Default - can't decipher operation */
5658 if (pos > 0) /* need to restore position of the handle */
5659 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5664 #endif /* LOCKF_EMULATE_FLOCK */
5668 * c-indentation-style: bsd
5670 * indent-tabs-mode: t
5673 * ex: set ts=8 sts=4 sw=4 noet: