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/wait.h>
57 # include <sys/resource.h>
66 # include <sys/select.h>
70 /* XXX Configure test needed.
71 h_errno might not be a simple 'int', especially for multi-threaded
72 applications, see "extern int errno in perl.h". Creating such
73 a test requires taking into account the differences between
74 compiling multithreaded and singlethreaded ($ccflags et al).
75 HOST_NOT_FOUND is typically defined in <netdb.h>.
77 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
86 struct passwd *getpwnam (char *);
87 struct passwd *getpwuid (Uid_t);
92 struct passwd *getpwent (void);
93 #elif defined (VMS) && defined (my_getpwent)
94 struct passwd *Perl_my_getpwent (pTHX);
103 struct group *getgrnam (char *);
104 struct group *getgrgid (Gid_t);
108 struct group *getgrent (void);
114 # if defined(_MSC_VER) || defined(__MINGW32__)
115 # include <sys/utime.h>
122 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
125 # define my_chsize PerlLIO_chsize
128 # define my_chsize PerlLIO_chsize
130 I32 my_chsize(int fd, Off_t length);
136 #else /* no flock() */
138 /* fcntl.h might not have been included, even if it exists, because
139 the current Configure only sets I_FCNTL if it's needed to pick up
140 the *_OK constants. Make sure it has been included before testing
141 the fcntl() locking constants. */
142 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
146 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
147 # define FLOCK fcntl_emulate_flock
148 # define FCNTL_EMULATE_FLOCK
149 # else /* no flock() or fcntl(F_SETLK,...) */
151 # define FLOCK lockf_emulate_flock
152 # define LOCKF_EMULATE_FLOCK
154 # endif /* no flock() or fcntl(F_SETLK,...) */
157 static int FLOCK (int, int);
160 * These are the flock() constants. Since this sytems doesn't have
161 * flock(), the values of the constants are probably not available.
175 # endif /* emulating flock() */
177 #endif /* no flock() */
180 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
182 #if defined(I_SYS_ACCESS) && !defined(R_OK)
183 # include <sys/access.h>
186 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
187 # define FD_CLOEXEC 1 /* NeXT needs this */
193 /* Missing protos on LynxOS */
194 void sethostent(int);
195 void endhostent(void);
197 void endnetent(void);
198 void setprotoent(int);
199 void endprotoent(void);
200 void setservent(int);
201 void endservent(void);
204 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
206 /* F_OK unused: if stat() cannot find it... */
208 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
209 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
210 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
213 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
214 # ifdef I_SYS_SECURITY
215 # include <sys/security.h>
219 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
222 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
226 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
228 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
232 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
233 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
234 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
237 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
239 const Uid_t ruid = getuid();
240 const Uid_t euid = geteuid();
241 const Gid_t rgid = getgid();
242 const Gid_t egid = getegid();
245 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
246 Perl_croak(aTHX_ "switching effective uid is not implemented");
249 if (setreuid(euid, ruid))
252 if (setresuid(euid, ruid, (Uid_t)-1))
255 Perl_croak(aTHX_ "entering effective uid failed");
258 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
259 Perl_croak(aTHX_ "switching effective gid is not implemented");
262 if (setregid(egid, rgid))
265 if (setresgid(egid, rgid, (Gid_t)-1))
268 Perl_croak(aTHX_ "entering effective gid failed");
271 res = access(path, mode);
274 if (setreuid(ruid, euid))
277 if (setresuid(ruid, euid, (Uid_t)-1))
280 Perl_croak(aTHX_ "leaving effective uid failed");
283 if (setregid(rgid, egid))
286 if (setresgid(rgid, egid, (Gid_t)-1))
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)
361 tryAMAGICunTARGET(iter, -1);
363 /* Note that we only ever get here if File::Glob fails to load
364 * without at the same time croaking, for some reason, or if
365 * perl was built with PERL_EXTERNAL_GLOB */
367 ENTER_with_name("glob");
372 * The external globbing program may use things we can't control,
373 * so for security reasons we must assume the worst.
376 taint_proper(PL_no_security, "glob");
380 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
381 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
383 SAVESPTR(PL_rs); /* This is not permanent, either. */
384 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
387 *SvPVX(PL_rs) = '\n';
391 result = do_readline();
392 LEAVE_with_name("glob");
399 PL_last_in_gv = cGVOP_gv;
400 return do_readline();
411 do_join(TARG, &PL_sv_no, MARK, SP);
415 else if (SP == MARK) {
424 if (SvROK(exsv) || (pv = SvPV_const(exsv, len), len)) {
425 /* well-formed exception supplied */
427 else if (SvROK(ERRSV)) {
430 else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
431 exsv = sv_mortalcopy(ERRSV);
432 sv_catpvs(exsv, "\t...caught");
435 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
448 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
450 if (SP - MARK != 1) {
452 do_join(TARG, &PL_sv_no, MARK, SP);
460 if (SvROK(exsv) || (pv = SvPV_const(exsv, len), len)) {
461 /* well-formed exception supplied */
463 else if (SvROK(ERRSV)) {
465 if (sv_isobject(exsv)) {
466 HV * const stash = SvSTASH(SvRV(exsv));
467 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
469 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
470 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
477 call_sv(MUTABLE_SV(GvCV(gv)),
478 G_SCALAR|G_EVAL|G_KEEPERR);
479 exsv = sv_mortalcopy(*PL_stack_sp--);
483 else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
484 exsv = sv_mortalcopy(ERRSV);
485 sv_catpvs(exsv, "\t...propagated");
488 exsv = newSVpvs_flags("Died", SVs_TEMP);
506 GV * const gv = MUTABLE_GV(*++MARK);
508 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
509 DIE(aTHX_ PL_no_usym, "filehandle");
511 if ((io = GvIOp(gv))) {
513 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
516 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
517 "Opening dirhandle %s also as a file",
520 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
522 /* Method's args are same as ours ... */
523 /* ... except handle is replaced by the object */
524 *MARK-- = SvTIED_obj(MUTABLE_SV(io), mg);
527 ENTER_with_name("call_OPEN");
528 call_method("OPEN", G_SCALAR);
529 LEAVE_with_name("call_OPEN");
542 tmps = SvPV_const(sv, len);
543 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
546 PUSHi( (I32)PL_forkprocess );
547 else if (PL_forkprocess == 0) /* we are a new child */
554 /* These are private to this function, which is private to this file.
555 Use 0x04 rather than the next available bit, to help the compiler if the
556 architecture can generate more efficient instructions. */
557 #define MORTALIZE_NOT_NEEDED 0x04
558 #define TIED_HANDLE_ARGC_SHIFT 3
561 S_tied_handle_method(pTHX_ const char *const methname, SV **sp,
562 IO *const io, MAGIC *const mg, const U32 flags, ...)
564 U32 argc = flags >> TIED_HANDLE_ARGC_SHIFT;
566 PERL_ARGS_ASSERT_TIED_HANDLE_METHOD;
568 /* Ensure that our flag bits do not overlap. */
569 assert((MORTALIZE_NOT_NEEDED & G_WANT) == 0);
570 assert((G_WANT >> TIED_HANDLE_ARGC_SHIFT) == 0);
573 PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
575 const U32 mortalize_not_needed = flags & MORTALIZE_NOT_NEEDED;
577 va_start(args, flags);
579 SV *const arg = va_arg(args, SV *);
580 if(mortalize_not_needed)
589 ENTER_with_name("call_tied_handle_method");
590 call_method(methname, flags & G_WANT);
591 LEAVE_with_name("call_tied_handle_method");
595 #define tied_handle_method(a,b,c,d) \
596 S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR)
597 #define tied_handle_method1(a,b,c,d,e) \
598 S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR | (1 << TIED_HANDLE_ARGC_SHIFT),e)
599 #define tied_handle_method2(a,b,c,d,e,f) \
600 S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR | (2 << TIED_HANDLE_ARGC_SHIFT), e,f)
605 GV * const gv = (MAXARG == 0) ? PL_defoutgv : MUTABLE_GV(POPs);
611 IO * const io = GvIO(gv);
613 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
615 return tied_handle_method("CLOSE", SP, io, mg);
619 PUSHs(boolSV(do_close(gv, TRUE)));
632 GV * const wgv = MUTABLE_GV(POPs);
633 GV * const rgv = MUTABLE_GV(POPs);
638 if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
639 DIE(aTHX_ PL_no_usym, "filehandle");
644 do_close(rgv, FALSE);
646 do_close(wgv, FALSE);
648 if (PerlProc_pipe(fd) < 0)
651 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
652 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
653 IoOFP(rstio) = IoIFP(rstio);
654 IoIFP(wstio) = IoOFP(wstio);
655 IoTYPE(rstio) = IoTYPE_RDONLY;
656 IoTYPE(wstio) = IoTYPE_WRONLY;
658 if (!IoIFP(rstio) || !IoOFP(wstio)) {
660 PerlIO_close(IoIFP(rstio));
662 PerlLIO_close(fd[0]);
664 PerlIO_close(IoOFP(wstio));
666 PerlLIO_close(fd[1]);
669 #if defined(HAS_FCNTL) && defined(F_SETFD)
670 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
671 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
678 DIE(aTHX_ PL_no_func, "pipe");
692 gv = MUTABLE_GV(POPs);
694 if (gv && (io = GvIO(gv))
695 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
697 return tied_handle_method("FILENO", SP, io, mg);
700 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
701 /* Can't do this because people seem to do things like
702 defined(fileno($foo)) to check whether $foo is a valid fh.
703 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
704 report_evil_fh(gv, io, PL_op->op_type);
709 PUSHi(PerlIO_fileno(fp));
722 anum = PerlLIO_umask(022);
723 /* setting it to 022 between the two calls to umask avoids
724 * to have a window where the umask is set to 0 -- meaning
725 * that another thread could create world-writeable files. */
727 (void)PerlLIO_umask(anum);
730 anum = PerlLIO_umask(POPi);
731 TAINT_PROPER("umask");
734 /* Only DIE if trying to restrict permissions on "user" (self).
735 * Otherwise it's harmless and more useful to just return undef
736 * since 'group' and 'other' concepts probably don't exist here. */
737 if (MAXARG >= 1 && (POPi & 0700))
738 DIE(aTHX_ "umask not implemented");
739 XPUSHs(&PL_sv_undef);
758 gv = MUTABLE_GV(POPs);
760 if (gv && (io = GvIO(gv))) {
761 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
763 /* This takes advantage of the implementation of the varargs
764 function, which I don't think that the optimiser will be able to
765 figure out. Although, as it's a static function, in theory it
767 return S_tied_handle_method(aTHX_ "BINMODE", SP, io, mg,
768 G_SCALAR|MORTALIZE_NOT_NEEDED
770 ? (1 << TIED_HANDLE_ARGC_SHIFT) : 0),
775 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
776 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
777 report_evil_fh(gv, io, PL_op->op_type);
778 SETERRNO(EBADF,RMS_IFI);
785 const char *d = NULL;
788 d = SvPV_const(discp, len);
789 mode = mode_from_discipline(d, len);
790 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
791 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
792 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
813 const I32 markoff = MARK - PL_stack_base;
814 const char *methname;
815 int how = PERL_MAGIC_tied;
819 switch(SvTYPE(varsv)) {
821 methname = "TIEHASH";
822 HvEITER_set(MUTABLE_HV(varsv), 0);
825 methname = "TIEARRAY";
829 if (isGV_with_GP(varsv)) {
830 if (SvFAKE(varsv) && !(GvFLAGS(varsv) & GVf_TIEWARNED)) {
831 deprecate("tie on a handle without *");
832 GvFLAGS(varsv) |= GVf_TIEWARNED;
834 methname = "TIEHANDLE";
835 how = PERL_MAGIC_tiedscalar;
836 /* For tied filehandles, we apply tiedscalar magic to the IO
837 slot of the GP rather than the GV itself. AMS 20010812 */
839 GvIOp(varsv) = newIO();
840 varsv = MUTABLE_SV(GvIOp(varsv));
845 methname = "TIESCALAR";
846 how = PERL_MAGIC_tiedscalar;
850 if (sv_isobject(*MARK)) { /* Calls GET magic. */
851 ENTER_with_name("call_TIE");
852 PUSHSTACKi(PERLSI_MAGIC);
854 EXTEND(SP,(I32)items);
858 call_method(methname, G_SCALAR);
861 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
862 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
863 * wrong error message, and worse case, supreme action at a distance.
864 * (Sorry obfuscation writers. You're not going to be given this one.)
867 const char *name = SvPV_nomg_const(*MARK, len);
868 stash = gv_stashpvn(name, len, 0);
869 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
870 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
871 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
873 ENTER_with_name("call_TIE");
874 PUSHSTACKi(PERLSI_MAGIC);
876 EXTEND(SP,(I32)items);
880 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
886 if (sv_isobject(sv)) {
887 sv_unmagic(varsv, how);
888 /* Croak if a self-tie on an aggregate is attempted. */
889 if (varsv == SvRV(sv) &&
890 (SvTYPE(varsv) == SVt_PVAV ||
891 SvTYPE(varsv) == SVt_PVHV))
893 "Self-ties of arrays and hashes are not supported");
894 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
896 LEAVE_with_name("call_TIE");
897 SP = PL_stack_base + markoff;
907 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
908 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
910 if (isGV_with_GP(sv)) {
911 if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
912 deprecate("untie on a handle without *");
913 GvFLAGS(sv) |= GVf_TIEWARNED;
915 if (!(sv = MUTABLE_SV(GvIOp(sv))))
919 if ((mg = SvTIED_mg(sv, how))) {
920 SV * const obj = SvRV(SvTIED_obj(sv, mg));
922 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
924 if (gv && isGV(gv) && (cv = GvCV(gv))) {
926 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
927 mXPUSHi(SvREFCNT(obj) - 1);
929 ENTER_with_name("call_UNTIE");
930 call_sv(MUTABLE_SV(cv), G_VOID);
931 LEAVE_with_name("call_UNTIE");
934 else if (mg && SvREFCNT(obj) > 1) {
935 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
936 "untie attempted while %"UVuf" inner references still exist",
937 (UV)SvREFCNT(obj) - 1 ) ;
941 sv_unmagic(sv, how) ;
951 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
952 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
954 if (isGV_with_GP(sv)) {
955 if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
956 deprecate("tied on a handle without *");
957 GvFLAGS(sv) |= GVf_TIEWARNED;
959 if (!(sv = MUTABLE_SV(GvIOp(sv))))
963 if ((mg = SvTIED_mg(sv, how))) {
964 SV *osv = SvTIED_obj(sv, mg);
965 if (osv == mg->mg_obj)
966 osv = sv_mortalcopy(osv);
980 HV * const hv = MUTABLE_HV(POPs);
981 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
982 stash = gv_stashsv(sv, 0);
983 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
985 require_pv("AnyDBM_File.pm");
987 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
988 DIE(aTHX_ "No dbm on this machine");
998 mPUSHu(O_RDWR|O_CREAT);
1003 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1006 if (!sv_isobject(TOPs)) {
1014 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1018 if (sv_isobject(TOPs)) {
1019 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1020 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1037 struct timeval timebuf;
1038 struct timeval *tbuf = &timebuf;
1041 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1046 # if BYTEORDER & 0xf0000
1047 # define ORDERBYTE (0x88888888 - BYTEORDER)
1049 # define ORDERBYTE (0x4444 - BYTEORDER)
1055 for (i = 1; i <= 3; i++) {
1056 SV * const sv = SP[i];
1059 if (SvREADONLY(sv)) {
1061 sv_force_normal_flags(sv, 0);
1062 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1063 Perl_croak_no_modify(aTHX);
1066 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1067 SvPV_force_nolen(sv); /* force string conversion */
1074 /* little endians can use vecs directly */
1075 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1082 masksize = NFDBITS / NBBY;
1084 masksize = sizeof(long); /* documented int, everyone seems to use long */
1086 Zero(&fd_sets[0], 4, char*);
1089 # if SELECT_MIN_BITS == 1
1090 growsize = sizeof(fd_set);
1092 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1093 # undef SELECT_MIN_BITS
1094 # define SELECT_MIN_BITS __FD_SETSIZE
1096 /* If SELECT_MIN_BITS is greater than one we most probably will want
1097 * to align the sizes with SELECT_MIN_BITS/8 because for example
1098 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1099 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1100 * on (sets/tests/clears bits) is 32 bits. */
1101 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1109 timebuf.tv_sec = (long)value;
1110 value -= (NV)timebuf.tv_sec;
1111 timebuf.tv_usec = (long)(value * 1000000.0);
1116 for (i = 1; i <= 3; i++) {
1118 if (!SvOK(sv) || SvCUR(sv) == 0) {
1125 Sv_Grow(sv, growsize);
1129 while (++j <= growsize) {
1133 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1135 Newx(fd_sets[i], growsize, char);
1136 for (offset = 0; offset < growsize; offset += masksize) {
1137 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1138 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1141 fd_sets[i] = SvPVX(sv);
1145 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1146 /* Can't make just the (void*) conditional because that would be
1147 * cpp #if within cpp macro, and not all compilers like that. */
1148 nfound = PerlSock_select(
1150 (Select_fd_set_t) fd_sets[1],
1151 (Select_fd_set_t) fd_sets[2],
1152 (Select_fd_set_t) fd_sets[3],
1153 (void*) tbuf); /* Workaround for compiler bug. */
1155 nfound = PerlSock_select(
1157 (Select_fd_set_t) fd_sets[1],
1158 (Select_fd_set_t) fd_sets[2],
1159 (Select_fd_set_t) fd_sets[3],
1162 for (i = 1; i <= 3; i++) {
1165 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1167 for (offset = 0; offset < growsize; offset += masksize) {
1168 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1169 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1171 Safefree(fd_sets[i]);
1178 if (GIMME == G_ARRAY && tbuf) {
1179 value = (NV)(timebuf.tv_sec) +
1180 (NV)(timebuf.tv_usec) / 1000000.0;
1185 DIE(aTHX_ "select not implemented");
1190 =for apidoc setdefout
1192 Sets PL_defoutgv, the default file handle for output, to the passed in
1193 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1194 count of the passed in typeglob is increased by one, and the reference count
1195 of the typeglob that PL_defoutgv points to is decreased by one.
1201 Perl_setdefout(pTHX_ GV *gv)
1204 SvREFCNT_inc_simple_void(gv);
1205 SvREFCNT_dec(PL_defoutgv);
1213 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1214 GV * egv = GvEGVx(PL_defoutgv);
1218 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1220 XPUSHs(&PL_sv_undef);
1222 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1223 if (gvp && *gvp == egv) {
1224 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1228 mXPUSHs(newRV(MUTABLE_SV(egv)));
1233 if (!GvIO(newdefout))
1234 gv_IOadd(newdefout);
1235 setdefout(newdefout);
1245 GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs);
1250 if (gv && (io = GvIO(gv))) {
1251 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1253 const U32 gimme = GIMME_V;
1254 S_tied_handle_method(aTHX_ "GETC", SP, io, mg, gimme);
1255 if (gimme == G_SCALAR) {
1257 SvSetMagicSV_nosteal(TARG, TOPs);
1262 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1263 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1264 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1265 report_evil_fh(gv, io, PL_op->op_type);
1266 SETERRNO(EBADF,RMS_IFI);
1270 sv_setpvs(TARG, " ");
1271 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1272 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1273 /* Find out how many bytes the char needs */
1274 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1277 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1278 SvCUR_set(TARG,1+len);
1287 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1290 register PERL_CONTEXT *cx;
1291 const I32 gimme = GIMME_V;
1293 PERL_ARGS_ASSERT_DOFORM;
1295 if (cv && CvCLONE(cv))
1296 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1301 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1302 PUSHFORMAT(cx, retop);
1304 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1306 setdefout(gv); /* locally select filehandle so $% et al work */
1325 gv = MUTABLE_GV(POPs);
1339 goto not_a_format_reference;
1344 tmpsv = sv_newmortal();
1345 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1346 name = SvPV_nolen_const(tmpsv);
1348 DIE(aTHX_ "Undefined format \"%s\" called", name);
1350 not_a_format_reference:
1351 DIE(aTHX_ "Not a format reference");
1353 IoFLAGS(io) &= ~IOf_DIDTOP;
1354 return doform(cv,gv,PL_op->op_next);
1360 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1361 register IO * const io = GvIOp(gv);
1366 register PERL_CONTEXT *cx;
1369 if (!io || !(ofp = IoOFP(io)))
1372 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1373 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1375 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1376 PL_formtarget != PL_toptarget)
1380 if (!IoTOP_GV(io)) {
1383 if (!IoTOP_NAME(io)) {
1385 if (!IoFMT_NAME(io))
1386 IoFMT_NAME(io) = savepv(GvNAME(gv));
1387 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1388 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1389 if ((topgv && GvFORM(topgv)) ||
1390 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1391 IoTOP_NAME(io) = savesvpv(topname);
1393 IoTOP_NAME(io) = savepvs("top");
1395 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1396 if (!topgv || !GvFORM(topgv)) {
1397 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1400 IoTOP_GV(io) = topgv;
1402 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1403 I32 lines = IoLINES_LEFT(io);
1404 const char *s = SvPVX_const(PL_formtarget);
1405 if (lines <= 0) /* Yow, header didn't even fit!!! */
1407 while (lines-- > 0) {
1408 s = strchr(s, '\n');
1414 const STRLEN save = SvCUR(PL_formtarget);
1415 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1416 do_print(PL_formtarget, ofp);
1417 SvCUR_set(PL_formtarget, save);
1418 sv_chop(PL_formtarget, s);
1419 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1422 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1423 do_print(PL_formfeed, ofp);
1424 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1426 PL_formtarget = PL_toptarget;
1427 IoFLAGS(io) |= IOf_DIDTOP;
1430 DIE(aTHX_ "bad top format reference");
1433 SV * const sv = sv_newmortal();
1435 gv_efullname4(sv, fgv, NULL, FALSE);
1436 name = SvPV_nolen_const(sv);
1438 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1440 DIE(aTHX_ "Undefined top format called");
1442 return doform(cv, gv, PL_op);
1446 POPBLOCK(cx,PL_curpm);
1448 retop = cx->blk_sub.retop;
1453 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1455 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1456 else if (ckWARN(WARN_CLOSED))
1457 report_evil_fh(gv, io, PL_op->op_type);
1462 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1463 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1465 if (!do_print(PL_formtarget, fp))
1468 FmLINES(PL_formtarget) = 0;
1469 SvCUR_set(PL_formtarget, 0);
1470 *SvEND(PL_formtarget) = '\0';
1471 if (IoFLAGS(io) & IOf_FLUSH)
1472 (void)PerlIO_flush(fp);
1477 PL_formtarget = PL_bodytarget;
1479 PERL_UNUSED_VAR(newsp);
1480 PERL_UNUSED_VAR(gimme);
1486 dVAR; dSP; dMARK; dORIGMARK;
1492 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1494 if (gv && (io = GvIO(gv))) {
1495 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1497 if (MARK == ORIGMARK) {
1500 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1504 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1507 call_method("PRINTF", G_SCALAR);
1510 MARK = ORIGMARK + 1;
1518 if (!(io = GvIO(gv))) {
1519 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1520 report_evil_fh(gv, io, PL_op->op_type);
1521 SETERRNO(EBADF,RMS_IFI);
1524 else if (!(fp = IoOFP(io))) {
1525 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1527 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1528 else if (ckWARN(WARN_CLOSED))
1529 report_evil_fh(gv, io, PL_op->op_type);
1531 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1535 if (SvTAINTED(MARK[1]))
1536 TAINT_PROPER("printf");
1537 do_sprintf(sv, SP - MARK, MARK + 1);
1538 if (!do_print(sv, fp))
1541 if (IoFLAGS(io) & IOf_FLUSH)
1542 if (PerlIO_flush(fp) == EOF)
1553 PUSHs(&PL_sv_undef);
1561 const int perm = (MAXARG > 3) ? POPi : 0666;
1562 const int mode = POPi;
1563 SV * const sv = POPs;
1564 GV * const gv = MUTABLE_GV(POPs);
1567 /* Need TIEHANDLE method ? */
1568 const char * const tmps = SvPV_const(sv, len);
1569 /* FIXME? do_open should do const */
1570 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1571 IoLINES(GvIOp(gv)) = 0;
1575 PUSHs(&PL_sv_undef);
1582 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1588 Sock_size_t bufsize;
1596 bool charstart = FALSE;
1597 STRLEN charskip = 0;
1600 GV * const gv = MUTABLE_GV(*++MARK);
1601 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1602 && gv && (io = GvIO(gv)) )
1604 const MAGIC * mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1608 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1610 call_method("READ", G_SCALAR);
1624 sv_setpvs(bufsv, "");
1625 length = SvIVx(*++MARK);
1628 offset = SvIVx(*++MARK);
1632 if (!io || !IoIFP(io)) {
1633 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1634 report_evil_fh(gv, io, PL_op->op_type);
1635 SETERRNO(EBADF,RMS_IFI);
1638 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1639 buffer = SvPVutf8_force(bufsv, blen);
1640 /* UTF-8 may not have been set if they are all low bytes */
1645 buffer = SvPV_force(bufsv, blen);
1646 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1649 DIE(aTHX_ "Negative length");
1657 if (PL_op->op_type == OP_RECV) {
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 (PL_op->op_type == OP_RECV)
1697 DIE(aTHX_ PL_no_sock_func, "recv");
1699 if (DO_UTF8(bufsv)) {
1700 /* offset adjust in characters not bytes */
1701 blen = sv_len_utf8(bufsv);
1704 if (-offset > (int)blen)
1705 DIE(aTHX_ "Offset outside string");
1708 if (DO_UTF8(bufsv)) {
1709 /* convert offset-as-chars to offset-as-bytes */
1710 if (offset >= (int)blen)
1711 offset += SvCUR(bufsv) - blen;
1713 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1716 bufsize = SvCUR(bufsv);
1717 /* Allocating length + offset + 1 isn't perfect in the case of reading
1718 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1720 (should be 2 * length + offset + 1, or possibly something longer if
1721 PL_encoding is true) */
1722 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1723 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1724 Zero(buffer+bufsize, offset-bufsize, char);
1726 buffer = buffer + offset;
1728 read_target = bufsv;
1730 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1731 concatenate it to the current buffer. */
1733 /* Truncate the existing buffer to the start of where we will be
1735 SvCUR_set(bufsv, offset);
1737 read_target = sv_newmortal();
1738 SvUPGRADE(read_target, SVt_PV);
1739 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1742 if (PL_op->op_type == OP_SYSREAD) {
1743 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1744 if (IoTYPE(io) == IoTYPE_SOCKET) {
1745 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1751 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1756 #ifdef HAS_SOCKET__bad_code_maybe
1757 if (IoTYPE(io) == IoTYPE_SOCKET) {
1758 char namebuf[MAXPATHLEN];
1759 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1760 bufsize = sizeof (struct sockaddr_in);
1762 bufsize = sizeof namebuf;
1764 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1765 (struct sockaddr *)namebuf, &bufsize);
1770 count = PerlIO_read(IoIFP(io), buffer, length);
1771 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1772 if (count == 0 && PerlIO_error(IoIFP(io)))
1776 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1777 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1780 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1781 *SvEND(read_target) = '\0';
1782 (void)SvPOK_only(read_target);
1783 if (fp_utf8 && !IN_BYTES) {
1784 /* Look at utf8 we got back and count the characters */
1785 const char *bend = buffer + count;
1786 while (buffer < bend) {
1788 skip = UTF8SKIP(buffer);
1791 if (buffer - charskip + skip > bend) {
1792 /* partial character - try for rest of it */
1793 length = skip - (bend-buffer);
1794 offset = bend - SvPVX_const(bufsv);
1806 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1807 provided amount read (count) was what was requested (length)
1809 if (got < wanted && count == length) {
1810 length = wanted - got;
1811 offset = bend - SvPVX_const(bufsv);
1814 /* return value is character count */
1818 else if (buffer_utf8) {
1819 /* Let svcatsv upgrade the bytes we read in to utf8.
1820 The buffer is a mortal so will be freed soon. */
1821 sv_catsv_nomg(bufsv, read_target);
1824 /* This should not be marked tainted if the fp is marked clean */
1825 if (!(IoFLAGS(io) & IOf_UNTAINT))
1826 SvTAINTED_on(bufsv);
1838 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1844 STRLEN orig_blen_bytes;
1845 const int op_type = PL_op->op_type;
1849 GV *const gv = MUTABLE_GV(*++MARK);
1850 if (PL_op->op_type == OP_SYSWRITE
1851 && gv && (io = GvIO(gv))) {
1852 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1856 if (MARK == SP - 1) {
1858 mXPUSHi(sv_len(sv));
1863 *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg);
1865 call_method("WRITE", G_SCALAR);
1881 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1883 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1884 if (io && IoIFP(io))
1885 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1887 report_evil_fh(gv, io, PL_op->op_type);
1889 SETERRNO(EBADF,RMS_IFI);
1893 /* Do this first to trigger any overloading. */
1894 buffer = SvPV_const(bufsv, blen);
1895 orig_blen_bytes = blen;
1896 doing_utf8 = DO_UTF8(bufsv);
1898 if (PerlIO_isutf8(IoIFP(io))) {
1899 if (!SvUTF8(bufsv)) {
1900 /* We don't modify the original scalar. */
1901 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1902 buffer = (char *) tmpbuf;
1906 else if (doing_utf8) {
1907 STRLEN tmplen = blen;
1908 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1911 buffer = (char *) tmpbuf;
1915 assert((char *)result == buffer);
1916 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1920 if (op_type == OP_SYSWRITE) {
1921 Size_t length = 0; /* This length is in characters. */
1927 /* The SV is bytes, and we've had to upgrade it. */
1928 blen_chars = orig_blen_bytes;
1930 /* The SV really is UTF-8. */
1931 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1932 /* Don't call sv_len_utf8 again because it will call magic
1933 or overloading a second time, and we might get back a
1934 different result. */
1935 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1937 /* It's safe, and it may well be cached. */
1938 blen_chars = sv_len_utf8(bufsv);
1946 length = blen_chars;
1948 #if Size_t_size > IVSIZE
1949 length = (Size_t)SvNVx(*++MARK);
1951 length = (Size_t)SvIVx(*++MARK);
1953 if ((SSize_t)length < 0) {
1955 DIE(aTHX_ "Negative length");
1960 offset = SvIVx(*++MARK);
1962 if (-offset > (IV)blen_chars) {
1964 DIE(aTHX_ "Offset outside string");
1966 offset += blen_chars;
1967 } else if (offset > (IV)blen_chars) {
1969 DIE(aTHX_ "Offset outside string");
1973 if (length > blen_chars - offset)
1974 length = blen_chars - offset;
1976 /* Here we convert length from characters to bytes. */
1977 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1978 /* Either we had to convert the SV, or the SV is magical, or
1979 the SV has overloading, in which case we can't or mustn't
1980 or mustn't call it again. */
1982 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1983 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1985 /* It's a real UTF-8 SV, and it's not going to change under
1986 us. Take advantage of any cache. */
1988 I32 len_I32 = length;
1990 /* Convert the start and end character positions to bytes.
1991 Remember that the second argument to sv_pos_u2b is relative
1993 sv_pos_u2b(bufsv, &start, &len_I32);
2000 buffer = buffer+offset;
2002 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2003 if (IoTYPE(io) == IoTYPE_SOCKET) {
2004 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
2010 /* See the note at doio.c:do_print about filesize limits. --jhi */
2011 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2017 const int flags = SvIVx(*++MARK);
2020 char * const sockbuf = SvPVx(*++MARK, mlen);
2021 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
2022 flags, (struct sockaddr *)sockbuf, mlen);
2026 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
2031 DIE(aTHX_ PL_no_sock_func, "send");
2038 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2041 #if Size_t_size > IVSIZE
2061 * in Perl 5.12 and later, the additional parameter is a bitmask:
2064 * 2 = eof() <- ARGV magic
2066 * I'll rely on the compiler's trace flow analysis to decide whether to
2067 * actually assign this out here, or punt it into the only block where it is
2068 * used. Doing it out here is DRY on the condition logic.
2073 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2079 if (PL_op->op_flags & OPf_SPECIAL) {
2080 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2084 gv = PL_last_in_gv; /* eof */
2092 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2093 return tied_handle_method1("EOF", SP, io, mg, newSVuv(which));
2096 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2097 if (io && !IoIFP(io)) {
2098 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2100 IoFLAGS(io) &= ~IOf_START;
2101 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2103 sv_setpvs(GvSV(gv), "-");
2105 GvSV(gv) = newSVpvs("-");
2106 SvSETMAGIC(GvSV(gv));
2108 else if (!nextargv(gv))
2113 PUSHs(boolSV(do_eof(gv)));
2124 PL_last_in_gv = MUTABLE_GV(POPs);
2129 if (gv && (io = GvIO(gv))) {
2130 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2132 return tied_handle_method("TELL", SP, io, mg);
2137 SETERRNO(EBADF,RMS_IFI);
2142 #if LSEEKSIZE > IVSIZE
2143 PUSHn( do_tell(gv) );
2145 PUSHi( do_tell(gv) );
2153 const int whence = POPi;
2154 #if LSEEKSIZE > IVSIZE
2155 const Off_t offset = (Off_t)SvNVx(POPs);
2157 const Off_t offset = (Off_t)SvIVx(POPs);
2160 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2163 if (gv && (io = GvIO(gv))) {
2164 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2166 #if LSEEKSIZE > IVSIZE
2167 SV *const offset_sv = newSVnv((NV) offset);
2169 SV *const offset_sv = newSViv(offset);
2172 return tied_handle_method2("SEEK", SP, io, mg, offset_sv,
2177 if (PL_op->op_type == OP_SEEK)
2178 PUSHs(boolSV(do_seek(gv, offset, whence)));
2180 const Off_t sought = do_sysseek(gv, offset, whence);
2182 PUSHs(&PL_sv_undef);
2184 SV* const sv = sought ?
2185 #if LSEEKSIZE > IVSIZE
2190 : newSVpvn(zero_but_true, ZBTLEN);
2201 /* There seems to be no consensus on the length type of truncate()
2202 * and ftruncate(), both off_t and size_t have supporters. In
2203 * general one would think that when using large files, off_t is
2204 * at least as wide as size_t, so using an off_t should be okay. */
2205 /* XXX Configure probe for the length type of *truncate() needed XXX */
2208 #if Off_t_size > IVSIZE
2213 /* Checking for length < 0 is problematic as the type might or
2214 * might not be signed: if it is not, clever compilers will moan. */
2215 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2222 if (PL_op->op_flags & OPf_SPECIAL) {
2223 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2232 TAINT_PROPER("truncate");
2233 if (!(fp = IoIFP(io))) {
2239 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2241 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2248 SV * const sv = POPs;
2251 if (isGV_with_GP(sv)) {
2252 tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */
2253 goto do_ftruncate_gv;
2255 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2256 tmpgv = MUTABLE_GV(SvRV(sv)); /* \*main::FRED for example */
2257 goto do_ftruncate_gv;
2259 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2260 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2261 goto do_ftruncate_io;
2264 name = SvPV_nolen_const(sv);
2265 TAINT_PROPER("truncate");
2267 if (truncate(name, len) < 0)
2271 const int tmpfd = PerlLIO_open(name, O_RDWR);
2276 if (my_chsize(tmpfd, len) < 0)
2278 PerlLIO_close(tmpfd);
2287 SETERRNO(EBADF,RMS_IFI);
2295 SV * const argsv = POPs;
2296 const unsigned int func = POPu;
2297 const int optype = PL_op->op_type;
2298 GV * const gv = MUTABLE_GV(POPs);
2299 IO * const io = gv ? GvIOn(gv) : NULL;
2303 if (!io || !argsv || !IoIFP(io)) {
2304 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2305 report_evil_fh(gv, io, PL_op->op_type);
2306 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2310 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2313 s = SvPV_force(argsv, len);
2314 need = IOCPARM_LEN(func);
2316 s = Sv_Grow(argsv, need + 1);
2317 SvCUR_set(argsv, need);
2320 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2323 retval = SvIV(argsv);
2324 s = INT2PTR(char*,retval); /* ouch */
2327 TAINT_PROPER(PL_op_desc[optype]);
2329 if (optype == OP_IOCTL)
2331 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2333 DIE(aTHX_ "ioctl is not implemented");
2337 DIE(aTHX_ "fcntl is not implemented");
2339 #if defined(OS2) && defined(__EMX__)
2340 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2342 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2346 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2348 if (s[SvCUR(argsv)] != 17)
2349 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2351 s[SvCUR(argsv)] = 0; /* put our null back */
2352 SvSETMAGIC(argsv); /* Assume it has changed */
2361 PUSHp(zero_but_true, ZBTLEN);
2374 const int argtype = POPi;
2375 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
2377 if (gv && (io = GvIO(gv)))
2383 /* XXX Looks to me like io is always NULL at this point */
2385 (void)PerlIO_flush(fp);
2386 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2389 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2390 report_evil_fh(gv, io, PL_op->op_type);
2392 SETERRNO(EBADF,RMS_IFI);
2397 DIE(aTHX_ PL_no_func, "flock()");
2407 const int protocol = POPi;
2408 const int type = POPi;
2409 const int domain = POPi;
2410 GV * const gv = MUTABLE_GV(POPs);
2411 register IO * const io = gv ? GvIOn(gv) : NULL;
2415 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2416 report_evil_fh(gv, io, PL_op->op_type);
2417 if (io && IoIFP(io))
2418 do_close(gv, FALSE);
2419 SETERRNO(EBADF,LIB_INVARG);
2424 do_close(gv, FALSE);
2426 TAINT_PROPER("socket");
2427 fd = PerlSock_socket(domain, type, protocol);
2430 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2431 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2432 IoTYPE(io) = IoTYPE_SOCKET;
2433 if (!IoIFP(io) || !IoOFP(io)) {
2434 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2435 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2436 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2439 #if defined(HAS_FCNTL) && defined(F_SETFD)
2440 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2444 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2449 DIE(aTHX_ PL_no_sock_func, "socket");
2455 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2457 const int protocol = POPi;
2458 const int type = POPi;
2459 const int domain = POPi;
2460 GV * const gv2 = MUTABLE_GV(POPs);
2461 GV * const gv1 = MUTABLE_GV(POPs);
2462 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2463 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2466 if (!gv1 || !gv2 || !io1 || !io2) {
2467 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2469 report_evil_fh(gv1, io1, PL_op->op_type);
2471 report_evil_fh(gv1, io2, PL_op->op_type);
2473 if (io1 && IoIFP(io1))
2474 do_close(gv1, FALSE);
2475 if (io2 && IoIFP(io2))
2476 do_close(gv2, FALSE);
2481 do_close(gv1, FALSE);
2483 do_close(gv2, FALSE);
2485 TAINT_PROPER("socketpair");
2486 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2488 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2489 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2490 IoTYPE(io1) = IoTYPE_SOCKET;
2491 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2492 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2493 IoTYPE(io2) = IoTYPE_SOCKET;
2494 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2495 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2496 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2497 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2498 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2499 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2500 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2503 #if defined(HAS_FCNTL) && defined(F_SETFD)
2504 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2505 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2510 DIE(aTHX_ PL_no_sock_func, "socketpair");
2518 SV * const addrsv = POPs;
2519 /* OK, so on what platform does bind modify addr? */
2521 GV * const gv = MUTABLE_GV(POPs);
2522 register IO * const io = GvIOn(gv);
2525 if (!io || !IoIFP(io))
2528 addr = SvPV_const(addrsv, len);
2529 TAINT_PROPER("bind");
2530 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2536 if (ckWARN(WARN_CLOSED))
2537 report_evil_fh(gv, io, PL_op->op_type);
2538 SETERRNO(EBADF,SS_IVCHAN);
2541 DIE(aTHX_ PL_no_sock_func, "bind");
2549 SV * const addrsv = POPs;
2550 GV * const gv = MUTABLE_GV(POPs);
2551 register IO * const io = GvIOn(gv);
2555 if (!io || !IoIFP(io))
2558 addr = SvPV_const(addrsv, len);
2559 TAINT_PROPER("connect");
2560 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2566 if (ckWARN(WARN_CLOSED))
2567 report_evil_fh(gv, io, PL_op->op_type);
2568 SETERRNO(EBADF,SS_IVCHAN);
2571 DIE(aTHX_ PL_no_sock_func, "connect");
2579 const int backlog = POPi;
2580 GV * const gv = MUTABLE_GV(POPs);
2581 register IO * const io = gv ? GvIOn(gv) : NULL;
2583 if (!gv || !io || !IoIFP(io))
2586 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2592 if (ckWARN(WARN_CLOSED))
2593 report_evil_fh(gv, io, PL_op->op_type);
2594 SETERRNO(EBADF,SS_IVCHAN);
2597 DIE(aTHX_ PL_no_sock_func, "listen");
2607 char namebuf[MAXPATHLEN];
2608 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2609 Sock_size_t len = sizeof (struct sockaddr_in);
2611 Sock_size_t len = sizeof namebuf;
2613 GV * const ggv = MUTABLE_GV(POPs);
2614 GV * const ngv = MUTABLE_GV(POPs);
2623 if (!gstio || !IoIFP(gstio))
2627 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2630 /* Some platforms indicate zero length when an AF_UNIX client is
2631 * not bound. Simulate a non-zero-length sockaddr structure in
2633 namebuf[0] = 0; /* sun_len */
2634 namebuf[1] = AF_UNIX; /* sun_family */
2642 do_close(ngv, FALSE);
2643 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2644 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2645 IoTYPE(nstio) = IoTYPE_SOCKET;
2646 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2647 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2648 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2649 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2652 #if defined(HAS_FCNTL) && defined(F_SETFD)
2653 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2657 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2658 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2660 #ifdef __SCO_VERSION__
2661 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2664 PUSHp(namebuf, len);
2668 if (ckWARN(WARN_CLOSED))
2669 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2670 SETERRNO(EBADF,SS_IVCHAN);
2676 DIE(aTHX_ PL_no_sock_func, "accept");
2684 const int how = POPi;
2685 GV * const gv = MUTABLE_GV(POPs);
2686 register IO * const io = GvIOn(gv);
2688 if (!io || !IoIFP(io))
2691 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2695 if (ckWARN(WARN_CLOSED))
2696 report_evil_fh(gv, io, PL_op->op_type);
2697 SETERRNO(EBADF,SS_IVCHAN);
2700 DIE(aTHX_ PL_no_sock_func, "shutdown");
2708 const int optype = PL_op->op_type;
2709 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2710 const unsigned int optname = (unsigned int) POPi;
2711 const unsigned int lvl = (unsigned int) POPi;
2712 GV * const gv = MUTABLE_GV(POPs);
2713 register IO * const io = GvIOn(gv);
2717 if (!io || !IoIFP(io))
2720 fd = PerlIO_fileno(IoIFP(io));
2724 (void)SvPOK_only(sv);
2728 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2735 #if defined(__SYMBIAN32__)
2736 # define SETSOCKOPT_OPTION_VALUE_T void *
2738 # define SETSOCKOPT_OPTION_VALUE_T const char *
2740 /* XXX TODO: We need to have a proper type (a Configure probe,
2741 * etc.) for what the C headers think of the third argument of
2742 * setsockopt(), the option_value read-only buffer: is it
2743 * a "char *", or a "void *", const or not. Some compilers
2744 * don't take kindly to e.g. assuming that "char *" implicitly
2745 * promotes to a "void *", or to explicitly promoting/demoting
2746 * consts to non/vice versa. The "const void *" is the SUS
2747 * definition, but that does not fly everywhere for the above
2749 SETSOCKOPT_OPTION_VALUE_T buf;
2753 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2757 aint = (int)SvIV(sv);
2758 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2761 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2770 if (ckWARN(WARN_CLOSED))
2771 report_evil_fh(gv, io, optype);
2772 SETERRNO(EBADF,SS_IVCHAN);
2777 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2785 const int optype = PL_op->op_type;
2786 GV * const gv = MUTABLE_GV(POPs);
2787 register IO * const io = GvIOn(gv);
2792 if (!io || !IoIFP(io))
2795 sv = sv_2mortal(newSV(257));
2796 (void)SvPOK_only(sv);
2800 fd = PerlIO_fileno(IoIFP(io));
2802 case OP_GETSOCKNAME:
2803 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2806 case OP_GETPEERNAME:
2807 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2809 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2811 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";
2812 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2813 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2814 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2815 sizeof(u_short) + sizeof(struct in_addr))) {
2822 #ifdef BOGUS_GETNAME_RETURN
2823 /* Interactive Unix, getpeername() and getsockname()
2824 does not return valid namelen */
2825 if (len == BOGUS_GETNAME_RETURN)
2826 len = sizeof(struct sockaddr);
2834 if (ckWARN(WARN_CLOSED))
2835 report_evil_fh(gv, io, optype);
2836 SETERRNO(EBADF,SS_IVCHAN);
2841 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2856 if (PL_op->op_flags & OPf_REF) {
2858 if (PL_op->op_type == OP_LSTAT) {
2859 if (gv != PL_defgv) {
2860 do_fstat_warning_check:
2861 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2862 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2863 } else if (PL_laststype != OP_LSTAT)
2864 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2868 if (gv != PL_defgv) {
2869 PL_laststype = OP_STAT;
2871 sv_setpvs(PL_statname, "");
2878 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2879 } else if (IoDIRP(io)) {
2881 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2883 PL_laststatval = -1;
2889 if (PL_laststatval < 0) {
2890 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2891 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2896 SV* const sv = POPs;
2897 if (isGV_with_GP(sv)) {
2898 gv = MUTABLE_GV(sv);
2900 } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2901 gv = MUTABLE_GV(SvRV(sv));
2902 if (PL_op->op_type == OP_LSTAT)
2903 goto do_fstat_warning_check;
2905 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2906 io = MUTABLE_IO(SvRV(sv));
2907 if (PL_op->op_type == OP_LSTAT)
2908 goto do_fstat_warning_check;
2909 goto do_fstat_have_io;
2912 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2914 PL_laststype = PL_op->op_type;
2915 if (PL_op->op_type == OP_LSTAT)
2916 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2918 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2919 if (PL_laststatval < 0) {
2920 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2921 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2927 if (gimme != G_ARRAY) {
2928 if (gimme != G_VOID)
2929 XPUSHs(boolSV(max));
2935 mPUSHi(PL_statcache.st_dev);
2936 mPUSHi(PL_statcache.st_ino);
2937 mPUSHu(PL_statcache.st_mode);
2938 mPUSHu(PL_statcache.st_nlink);
2939 #if Uid_t_size > IVSIZE
2940 mPUSHn(PL_statcache.st_uid);
2942 # if Uid_t_sign <= 0
2943 mPUSHi(PL_statcache.st_uid);
2945 mPUSHu(PL_statcache.st_uid);
2948 #if Gid_t_size > IVSIZE
2949 mPUSHn(PL_statcache.st_gid);
2951 # if Gid_t_sign <= 0
2952 mPUSHi(PL_statcache.st_gid);
2954 mPUSHu(PL_statcache.st_gid);
2957 #ifdef USE_STAT_RDEV
2958 mPUSHi(PL_statcache.st_rdev);
2960 PUSHs(newSVpvs_flags("", SVs_TEMP));
2962 #if Off_t_size > IVSIZE
2963 mPUSHn(PL_statcache.st_size);
2965 mPUSHi(PL_statcache.st_size);
2968 mPUSHn(PL_statcache.st_atime);
2969 mPUSHn(PL_statcache.st_mtime);
2970 mPUSHn(PL_statcache.st_ctime);
2972 mPUSHi(PL_statcache.st_atime);
2973 mPUSHi(PL_statcache.st_mtime);
2974 mPUSHi(PL_statcache.st_ctime);
2976 #ifdef USE_STAT_BLOCKS
2977 mPUSHu(PL_statcache.st_blksize);
2978 mPUSHu(PL_statcache.st_blocks);
2980 PUSHs(newSVpvs_flags("", SVs_TEMP));
2981 PUSHs(newSVpvs_flags("", SVs_TEMP));
2987 #define tryAMAGICftest_MG(chr) STMT_START { \
2988 if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
2989 && S_try_amagic_ftest(aTHX_ chr)) \
2994 S_try_amagic_ftest(pTHX_ char chr) {
2997 SV* const arg = TOPs;
3002 if ((PL_op->op_flags & OPf_KIDS)
3005 const char tmpchr = chr;
3007 SV * const tmpsv = amagic_call(arg,
3008 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
3009 ftest_amg, AMGf_unary);
3016 next = PL_op->op_next;
3017 if (next->op_type >= OP_FTRREAD &&
3018 next->op_type <= OP_FTBINARY &&
3019 next->op_private & OPpFT_STACKED
3022 /* leave the object alone */
3034 /* This macro is used by the stacked filetest operators :
3035 * if the previous filetest failed, short-circuit and pass its value.
3036 * Else, discard it from the stack and continue. --rgs
3038 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
3039 if (!SvTRUE(TOPs)) { RETURN; } \
3040 else { (void)POPs; PUTBACK; } \
3047 /* Not const, because things tweak this below. Not bool, because there's
3048 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
3049 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3050 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3051 /* Giving some sort of initial value silences compilers. */
3053 int access_mode = R_OK;
3055 int access_mode = 0;
3058 /* access_mode is never used, but leaving use_access in makes the
3059 conditional compiling below much clearer. */
3062 int stat_mode = S_IRUSR;
3064 bool effective = FALSE;
3068 switch (PL_op->op_type) {
3069 case OP_FTRREAD: opchar = 'R'; break;
3070 case OP_FTRWRITE: opchar = 'W'; break;
3071 case OP_FTREXEC: opchar = 'X'; break;
3072 case OP_FTEREAD: opchar = 'r'; break;
3073 case OP_FTEWRITE: opchar = 'w'; break;
3074 case OP_FTEEXEC: opchar = 'x'; break;
3076 tryAMAGICftest_MG(opchar);
3078 STACKED_FTEST_CHECK;
3080 switch (PL_op->op_type) {
3082 #if !(defined(HAS_ACCESS) && defined(R_OK))
3088 #if defined(HAS_ACCESS) && defined(W_OK)
3093 stat_mode = S_IWUSR;
3097 #if defined(HAS_ACCESS) && defined(X_OK)
3102 stat_mode = S_IXUSR;
3106 #ifdef PERL_EFF_ACCESS
3109 stat_mode = S_IWUSR;
3113 #ifndef PERL_EFF_ACCESS
3120 #ifdef PERL_EFF_ACCESS
3125 stat_mode = S_IXUSR;
3131 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3132 const char *name = POPpx;
3134 # ifdef PERL_EFF_ACCESS
3135 result = PERL_EFF_ACCESS(name, access_mode);
3137 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3143 result = access(name, access_mode);
3145 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3156 result = my_stat_flags(0);
3160 if (cando(stat_mode, effective, &PL_statcache))
3169 const int op_type = PL_op->op_type;
3174 case OP_FTIS: opchar = 'e'; break;
3175 case OP_FTSIZE: opchar = 's'; break;
3176 case OP_FTMTIME: opchar = 'M'; break;
3177 case OP_FTCTIME: opchar = 'C'; break;
3178 case OP_FTATIME: opchar = 'A'; break;
3180 tryAMAGICftest_MG(opchar);
3182 STACKED_FTEST_CHECK;
3184 result = my_stat_flags(0);
3188 if (op_type == OP_FTIS)
3191 /* You can't dTARGET inside OP_FTIS, because you'll get
3192 "panic: pad_sv po" - the op is not flagged to have a target. */
3196 #if Off_t_size > IVSIZE
3197 PUSHn(PL_statcache.st_size);
3199 PUSHi(PL_statcache.st_size);
3203 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3206 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3209 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3223 switch (PL_op->op_type) {
3224 case OP_FTROWNED: opchar = 'O'; break;
3225 case OP_FTEOWNED: opchar = 'o'; break;
3226 case OP_FTZERO: opchar = 'z'; break;
3227 case OP_FTSOCK: opchar = 'S'; break;
3228 case OP_FTCHR: opchar = 'c'; break;
3229 case OP_FTBLK: opchar = 'b'; break;
3230 case OP_FTFILE: opchar = 'f'; break;
3231 case OP_FTDIR: opchar = 'd'; break;
3232 case OP_FTPIPE: opchar = 'p'; break;
3233 case OP_FTSUID: opchar = 'u'; break;
3234 case OP_FTSGID: opchar = 'g'; break;
3235 case OP_FTSVTX: opchar = 'k'; break;
3237 tryAMAGICftest_MG(opchar);
3239 STACKED_FTEST_CHECK;
3241 /* I believe that all these three are likely to be defined on most every
3242 system these days. */
3244 if(PL_op->op_type == OP_FTSUID) {
3245 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3251 if(PL_op->op_type == OP_FTSGID) {
3252 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3258 if(PL_op->op_type == OP_FTSVTX) {
3259 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3265 result = my_stat_flags(0);
3269 switch (PL_op->op_type) {
3271 if (PL_statcache.st_uid == PL_uid)
3275 if (PL_statcache.st_uid == PL_euid)
3279 if (PL_statcache.st_size == 0)
3283 if (S_ISSOCK(PL_statcache.st_mode))
3287 if (S_ISCHR(PL_statcache.st_mode))
3291 if (S_ISBLK(PL_statcache.st_mode))
3295 if (S_ISREG(PL_statcache.st_mode))
3299 if (S_ISDIR(PL_statcache.st_mode))
3303 if (S_ISFIFO(PL_statcache.st_mode))
3308 if (PL_statcache.st_mode & S_ISUID)
3314 if (PL_statcache.st_mode & S_ISGID)
3320 if (PL_statcache.st_mode & S_ISVTX)
3334 tryAMAGICftest_MG('l');
3335 result = my_lstat_flags(0);
3340 if (S_ISLNK(PL_statcache.st_mode))
3355 tryAMAGICftest_MG('t');
3357 STACKED_FTEST_CHECK;
3359 if (PL_op->op_flags & OPf_REF)
3361 else if (isGV_with_GP(TOPs))
3362 gv = MUTABLE_GV(POPs);
3363 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3364 gv = MUTABLE_GV(SvRV(POPs));
3367 name = SvPV_nomg(tmpsv, namelen);
3368 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3371 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3372 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3373 else if (tmpsv && SvOK(tmpsv)) {
3381 if (PerlLIO_isatty(fd))
3386 #if defined(atarist) /* this will work with atariST. Configure will
3387 make guesses for other systems. */
3388 # define FILE_base(f) ((f)->_base)
3389 # define FILE_ptr(f) ((f)->_ptr)
3390 # define FILE_cnt(f) ((f)->_cnt)
3391 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3402 register STDCHAR *s;
3408 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3410 STACKED_FTEST_CHECK;
3412 if (PL_op->op_flags & OPf_REF)
3414 else if (isGV_with_GP(TOPs))
3415 gv = MUTABLE_GV(POPs);
3416 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3417 gv = MUTABLE_GV(SvRV(POPs));
3423 if (gv == PL_defgv) {
3425 io = GvIO(PL_statgv);
3428 goto really_filename;
3433 PL_laststatval = -1;
3434 sv_setpvs(PL_statname, "");
3435 io = GvIO(PL_statgv);
3437 if (io && IoIFP(io)) {
3438 if (! PerlIO_has_base(IoIFP(io)))
3439 DIE(aTHX_ "-T and -B not implemented on filehandles");
3440 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3441 if (PL_laststatval < 0)
3443 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3444 if (PL_op->op_type == OP_FTTEXT)
3449 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3450 i = PerlIO_getc(IoIFP(io));
3452 (void)PerlIO_ungetc(IoIFP(io),i);
3454 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3456 len = PerlIO_get_bufsiz(IoIFP(io));
3457 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3458 /* sfio can have large buffers - limit to 512 */
3463 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3465 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3467 SETERRNO(EBADF,RMS_IFI);
3475 PL_laststype = OP_STAT;
3476 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3477 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3478 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3480 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3483 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3484 if (PL_laststatval < 0) {
3485 (void)PerlIO_close(fp);
3488 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3489 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3490 (void)PerlIO_close(fp);
3492 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3493 RETPUSHNO; /* special case NFS directories */
3494 RETPUSHYES; /* null file is anything */
3499 /* now scan s to look for textiness */
3500 /* XXX ASCII dependent code */
3502 #if defined(DOSISH) || defined(USEMYBINMODE)
3503 /* ignore trailing ^Z on short files */
3504 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3508 for (i = 0; i < len; i++, s++) {
3509 if (!*s) { /* null never allowed in text */
3514 else if (!(isPRINT(*s) || isSPACE(*s)))
3517 else if (*s & 128) {
3519 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3522 /* utf8 characters don't count as odd */
3523 if (UTF8_IS_START(*s)) {
3524 int ulen = UTF8SKIP(s);
3525 if (ulen < len - i) {
3527 for (j = 1; j < ulen; j++) {
3528 if (!UTF8_IS_CONTINUATION(s[j]))
3531 --ulen; /* loop does extra increment */
3541 *s != '\n' && *s != '\r' && *s != '\b' &&
3542 *s != '\t' && *s != '\f' && *s != 27)
3547 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3558 const char *tmps = NULL;
3562 SV * const sv = POPs;
3563 if (PL_op->op_flags & OPf_SPECIAL) {
3564 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3566 else if (isGV_with_GP(sv)) {
3567 gv = MUTABLE_GV(sv);
3569 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
3570 gv = MUTABLE_GV(SvRV(sv));
3573 tmps = SvPV_nolen_const(sv);
3577 if( !gv && (!tmps || !*tmps) ) {
3578 HV * const table = GvHVn(PL_envgv);
3581 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3582 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3584 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3589 deprecate("chdir('') or chdir(undef) as chdir()");
3590 tmps = SvPV_nolen_const(*svp);
3594 TAINT_PROPER("chdir");
3599 TAINT_PROPER("chdir");
3602 IO* const io = GvIO(gv);
3605 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3606 } else if (IoIFP(io)) {
3607 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3610 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3611 report_evil_fh(gv, io, PL_op->op_type);
3612 SETERRNO(EBADF, RMS_IFI);
3617 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3618 report_evil_fh(gv, io, PL_op->op_type);
3619 SETERRNO(EBADF,RMS_IFI);
3623 DIE(aTHX_ PL_no_func, "fchdir");
3627 PUSHi( PerlDir_chdir(tmps) >= 0 );
3629 /* Clear the DEFAULT element of ENV so we'll get the new value
3631 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3638 dVAR; dSP; dMARK; dTARGET;
3639 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3650 char * const tmps = POPpx;
3651 TAINT_PROPER("chroot");
3652 PUSHi( chroot(tmps) >= 0 );
3655 DIE(aTHX_ PL_no_func, "chroot");
3663 const char * const tmps2 = POPpconstx;
3664 const char * const tmps = SvPV_nolen_const(TOPs);
3665 TAINT_PROPER("rename");
3667 anum = PerlLIO_rename(tmps, tmps2);
3669 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3670 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3673 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3674 (void)UNLINK(tmps2);
3675 if (!(anum = link(tmps, tmps2)))
3676 anum = UNLINK(tmps);
3684 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3688 const int op_type = PL_op->op_type;
3692 if (op_type == OP_LINK)
3693 DIE(aTHX_ PL_no_func, "link");
3695 # ifndef HAS_SYMLINK
3696 if (op_type == OP_SYMLINK)
3697 DIE(aTHX_ PL_no_func, "symlink");
3701 const char * const tmps2 = POPpconstx;
3702 const char * const tmps = SvPV_nolen_const(TOPs);
3703 TAINT_PROPER(PL_op_desc[op_type]);
3705 # if defined(HAS_LINK)
3706 # if defined(HAS_SYMLINK)
3707 /* Both present - need to choose which. */
3708 (op_type == OP_LINK) ?
3709 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3711 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3712 PerlLIO_link(tmps, tmps2);
3715 # if defined(HAS_SYMLINK)
3716 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3717 symlink(tmps, tmps2);
3722 SETi( result >= 0 );
3729 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3740 char buf[MAXPATHLEN];
3743 #ifndef INCOMPLETE_TAINTS
3747 len = readlink(tmps, buf, sizeof(buf) - 1);
3754 RETSETUNDEF; /* just pretend it's a normal file */
3758 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3760 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3762 char * const save_filename = filename;
3767 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3769 PERL_ARGS_ASSERT_DOONELINER;
3771 Newx(cmdline, size, char);
3772 my_strlcpy(cmdline, cmd, size);
3773 my_strlcat(cmdline, " ", size);
3774 for (s = cmdline + strlen(cmdline); *filename; ) {
3778 if (s - cmdline < size)
3779 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3780 myfp = PerlProc_popen(cmdline, "r");
3784 SV * const tmpsv = sv_newmortal();
3785 /* Need to save/restore 'PL_rs' ?? */
3786 s = sv_gets(tmpsv, myfp, 0);
3787 (void)PerlProc_pclose(myfp);
3791 #ifdef HAS_SYS_ERRLIST
3796 /* you don't see this */
3797 const char * const errmsg =
3798 #ifdef HAS_SYS_ERRLIST
3806 if (instr(s, errmsg)) {
3813 #define EACCES EPERM
3815 if (instr(s, "cannot make"))
3816 SETERRNO(EEXIST,RMS_FEX);
3817 else if (instr(s, "existing file"))
3818 SETERRNO(EEXIST,RMS_FEX);
3819 else if (instr(s, "ile exists"))
3820 SETERRNO(EEXIST,RMS_FEX);
3821 else if (instr(s, "non-exist"))
3822 SETERRNO(ENOENT,RMS_FNF);
3823 else if (instr(s, "does not exist"))
3824 SETERRNO(ENOENT,RMS_FNF);
3825 else if (instr(s, "not empty"))
3826 SETERRNO(EBUSY,SS_DEVOFFLINE);
3827 else if (instr(s, "cannot access"))
3828 SETERRNO(EACCES,RMS_PRV);
3830 SETERRNO(EPERM,RMS_PRV);
3833 else { /* some mkdirs return no failure indication */
3834 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3835 if (PL_op->op_type == OP_RMDIR)
3840 SETERRNO(EACCES,RMS_PRV); /* a guess */
3849 /* This macro removes trailing slashes from a directory name.
3850 * Different operating and file systems take differently to
3851 * trailing slashes. According to POSIX 1003.1 1996 Edition
3852 * any number of trailing slashes should be allowed.
3853 * Thusly we snip them away so that even non-conforming
3854 * systems are happy.
3855 * We should probably do this "filtering" for all
3856 * the functions that expect (potentially) directory names:
3857 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3858 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3860 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3861 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3864 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3865 (tmps) = savepvn((tmps), (len)); \
3875 const int mode = (MAXARG > 1) ? POPi : 0777;
3877 TRIMSLASHES(tmps,len,copy);
3879 TAINT_PROPER("mkdir");
3881 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3885 SETi( dooneliner("mkdir", tmps) );
3886 oldumask = PerlLIO_umask(0);
3887 PerlLIO_umask(oldumask);
3888 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3903 TRIMSLASHES(tmps,len,copy);
3904 TAINT_PROPER("rmdir");
3906 SETi( PerlDir_rmdir(tmps) >= 0 );
3908 SETi( dooneliner("rmdir", tmps) );
3915 /* Directory calls. */
3919 #if defined(Direntry_t) && defined(HAS_READDIR)
3921 const char * const dirname = POPpconstx;
3922 GV * const gv = MUTABLE_GV(POPs);
3923 register IO * const io = GvIOn(gv);
3928 if ((IoIFP(io) || IoOFP(io)))
3929 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3930 "Opening filehandle %s also as a directory",
3933 PerlDir_close(IoDIRP(io));
3934 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3940 SETERRNO(EBADF,RMS_DIR);
3943 DIE(aTHX_ PL_no_dir_func, "opendir");
3949 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3950 DIE(aTHX_ PL_no_dir_func, "readdir");
3952 #if !defined(I_DIRENT) && !defined(VMS)
3953 Direntry_t *readdir (DIR *);
3959 const I32 gimme = GIMME;
3960 GV * const gv = MUTABLE_GV(POPs);
3961 register const Direntry_t *dp;
3962 register IO * const io = GvIOn(gv);
3964 if (!io || !IoDIRP(io)) {
3965 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3966 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3971 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3975 sv = newSVpvn(dp->d_name, dp->d_namlen);
3977 sv = newSVpv(dp->d_name, 0);
3979 #ifndef INCOMPLETE_TAINTS
3980 if (!(IoFLAGS(io) & IOf_UNTAINT))
3984 } while (gimme == G_ARRAY);
3986 if (!dp && gimme != G_ARRAY)
3993 SETERRNO(EBADF,RMS_ISI);
3994 if (GIMME == G_ARRAY)
4003 #if defined(HAS_TELLDIR) || defined(telldir)
4005 /* XXX does _anyone_ need this? --AD 2/20/1998 */
4006 /* XXX netbsd still seemed to.
4007 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
4008 --JHI 1999-Feb-02 */
4009 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
4010 long telldir (DIR *);
4012 GV * const gv = MUTABLE_GV(POPs);
4013 register IO * const io = GvIOn(gv);
4015 if (!io || !IoDIRP(io)) {
4016 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4017 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
4021 PUSHi( PerlDir_tell(IoDIRP(io)) );
4025 SETERRNO(EBADF,RMS_ISI);
4028 DIE(aTHX_ PL_no_dir_func, "telldir");
4034 #if defined(HAS_SEEKDIR) || defined(seekdir)
4036 const long along = POPl;
4037 GV * const gv = MUTABLE_GV(POPs);
4038 register IO * const io = GvIOn(gv);
4040 if (!io || !IoDIRP(io)) {
4041 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4042 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
4045 (void)PerlDir_seek(IoDIRP(io), along);
4050 SETERRNO(EBADF,RMS_ISI);
4053 DIE(aTHX_ PL_no_dir_func, "seekdir");
4059 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4061 GV * const gv = MUTABLE_GV(POPs);
4062 register IO * const io = GvIOn(gv);
4064 if (!io || !IoDIRP(io)) {
4065 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4066 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
4069 (void)PerlDir_rewind(IoDIRP(io));
4073 SETERRNO(EBADF,RMS_ISI);
4076 DIE(aTHX_ PL_no_dir_func, "rewinddir");
4082 #if defined(Direntry_t) && defined(HAS_READDIR)
4084 GV * const gv = MUTABLE_GV(POPs);
4085 register IO * const io = GvIOn(gv);
4087 if (!io || !IoDIRP(io)) {
4088 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4089 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
4092 #ifdef VOID_CLOSEDIR
4093 PerlDir_close(IoDIRP(io));
4095 if (PerlDir_close(IoDIRP(io)) < 0) {
4096 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4105 SETERRNO(EBADF,RMS_IFI);
4108 DIE(aTHX_ PL_no_dir_func, "closedir");
4112 /* Process control. */
4121 PERL_FLUSHALL_FOR_CHILD;
4122 childpid = PerlProc_fork();
4126 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
4128 SvREADONLY_off(GvSV(tmpgv));
4129 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4130 SvREADONLY_on(GvSV(tmpgv));
4132 #ifdef THREADS_HAVE_PIDS
4133 PL_ppid = (IV)getppid();
4135 #ifdef PERL_USES_PL_PIDSTATUS
4136 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4142 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4147 PERL_FLUSHALL_FOR_CHILD;
4148 childpid = PerlProc_fork();
4154 DIE(aTHX_ PL_no_func, "fork");
4161 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4166 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4167 childpid = wait4pid(-1, &argflags, 0);
4169 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4174 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4175 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4176 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4178 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4183 DIE(aTHX_ PL_no_func, "wait");
4189 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4191 const int optype = POPi;
4192 const Pid_t pid = TOPi;
4196 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4197 result = wait4pid(pid, &argflags, optype);
4199 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4204 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4205 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4206 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4208 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4213 DIE(aTHX_ PL_no_func, "waitpid");
4219 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4220 #if defined(__LIBCATAMOUNT__)
4221 PL_statusvalue = -1;
4230 while (++MARK <= SP) {
4231 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4236 TAINT_PROPER("system");
4238 PERL_FLUSHALL_FOR_CHILD;
4239 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4245 if (PerlProc_pipe(pp) >= 0)
4247 while ((childpid = PerlProc_fork()) == -1) {
4248 if (errno != EAGAIN) {
4253 PerlLIO_close(pp[0]);
4254 PerlLIO_close(pp[1]);
4261 Sigsave_t ihand,qhand; /* place to save signals during system() */
4265 PerlLIO_close(pp[1]);
4267 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4268 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4271 result = wait4pid(childpid, &status, 0);
4272 } while (result == -1 && errno == EINTR);
4274 (void)rsignal_restore(SIGINT, &ihand);
4275 (void)rsignal_restore(SIGQUIT, &qhand);
4277 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4278 do_execfree(); /* free any memory child malloced on fork */
4285 while (n < sizeof(int)) {
4286 n1 = PerlLIO_read(pp[0],
4287 (void*)(((char*)&errkid)+n),
4293 PerlLIO_close(pp[0]);
4294 if (n) { /* Error */
4295 if (n != sizeof(int))
4296 DIE(aTHX_ "panic: kid popen errno read");
4297 errno = errkid; /* Propagate errno from kid */
4298 STATUS_NATIVE_CHILD_SET(-1);
4301 XPUSHi(STATUS_CURRENT);
4305 PerlLIO_close(pp[0]);
4306 #if defined(HAS_FCNTL) && defined(F_SETFD)
4307 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4310 if (PL_op->op_flags & OPf_STACKED) {
4311 SV * const really = *++MARK;
4312 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4314 else if (SP - MARK != 1)
4315 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4317 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4321 #else /* ! FORK or VMS or OS/2 */
4324 if (PL_op->op_flags & OPf_STACKED) {
4325 SV * const really = *++MARK;
4326 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4327 value = (I32)do_aspawn(really, MARK, SP);
4329 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4332 else if (SP - MARK != 1) {
4333 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4334 value = (I32)do_aspawn(NULL, MARK, SP);
4336 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4340 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4342 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4344 STATUS_NATIVE_CHILD_SET(value);
4347 XPUSHi(result ? value : STATUS_CURRENT);
4348 #endif /* !FORK or VMS or OS/2 */
4355 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4360 while (++MARK <= SP) {
4361 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4366 TAINT_PROPER("exec");
4368 PERL_FLUSHALL_FOR_CHILD;
4369 if (PL_op->op_flags & OPf_STACKED) {
4370 SV * const really = *++MARK;
4371 value = (I32)do_aexec(really, MARK, SP);
4373 else if (SP - MARK != 1)
4375 value = (I32)vms_do_aexec(NULL, MARK, SP);
4379 (void ) do_aspawn(NULL, MARK, SP);
4383 value = (I32)do_aexec(NULL, MARK, SP);
4388 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4391 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4394 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4408 # ifdef THREADS_HAVE_PIDS
4409 if (PL_ppid != 1 && getppid() == 1)
4410 /* maybe the parent process has died. Refresh ppid cache */
4414 XPUSHi( getppid() );
4418 DIE(aTHX_ PL_no_func, "getppid");
4427 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4430 pgrp = (I32)BSD_GETPGRP(pid);
4432 if (pid != 0 && pid != PerlProc_getpid())
4433 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4439 DIE(aTHX_ PL_no_func, "getpgrp()");
4459 TAINT_PROPER("setpgrp");
4461 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4463 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4464 || (pid != 0 && pid != PerlProc_getpid()))
4466 DIE(aTHX_ "setpgrp can't take arguments");
4468 SETi( setpgrp() >= 0 );
4469 #endif /* USE_BSDPGRP */
4472 DIE(aTHX_ PL_no_func, "setpgrp()");
4477 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4479 # define PRIORITY_WHICH_T(which) which
4484 #ifdef HAS_GETPRIORITY
4486 const int who = POPi;
4487 const int which = TOPi;
4488 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4491 DIE(aTHX_ PL_no_func, "getpriority()");
4497 #ifdef HAS_SETPRIORITY
4499 const int niceval = POPi;
4500 const int who = POPi;
4501 const int which = TOPi;
4502 TAINT_PROPER("setpriority");
4503 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4506 DIE(aTHX_ PL_no_func, "setpriority()");
4510 #undef PRIORITY_WHICH_T
4518 XPUSHn( time(NULL) );
4520 XPUSHi( time(NULL) );
4532 (void)PerlProc_times(&PL_timesbuf);
4534 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4535 /* struct tms, though same data */
4539 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4540 if (GIMME == G_ARRAY) {
4541 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4542 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4543 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4551 if (GIMME == G_ARRAY) {
4558 DIE(aTHX_ "times not implemented");
4560 #endif /* HAS_TIMES */
4563 /* The 32 bit int year limits the times we can represent to these
4564 boundaries with a few days wiggle room to account for time zone
4567 /* Sat Jan 3 00:00:00 -2147481748 */
4568 #define TIME_LOWER_BOUND -67768100567755200.0
4569 /* Sun Dec 29 12:00:00 2147483647 */
4570 #define TIME_UPPER_BOUND 67767976233316800.0
4579 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4580 static const char * const dayname[] =
4581 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4582 static const char * const monname[] =
4583 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4584 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4589 when = (Time64_T)now;
4592 NV input = Perl_floor(POPn);
4593 when = (Time64_T)input;
4594 if (when != input) {
4595 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4596 "%s(%.0" NVff ") too large", opname, input);
4600 if ( TIME_LOWER_BOUND > when ) {
4601 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4602 "%s(%.0" NVff ") too small", opname, when);
4605 else if( when > TIME_UPPER_BOUND ) {
4606 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4607 "%s(%.0" NVff ") too large", opname, when);
4611 if (PL_op->op_type == OP_LOCALTIME)
4612 err = S_localtime64_r(&when, &tmbuf);
4614 err = S_gmtime64_r(&when, &tmbuf);
4618 /* XXX %lld broken for quads */
4619 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4620 "%s(%.0" NVff ") failed", opname, when);
4623 if (GIMME != G_ARRAY) { /* scalar context */
4625 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4626 double year = (double)tmbuf.tm_year + 1900;
4633 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4634 dayname[tmbuf.tm_wday],
4635 monname[tmbuf.tm_mon],
4643 else { /* list context */
4649 mPUSHi(tmbuf.tm_sec);
4650 mPUSHi(tmbuf.tm_min);
4651 mPUSHi(tmbuf.tm_hour);
4652 mPUSHi(tmbuf.tm_mday);
4653 mPUSHi(tmbuf.tm_mon);
4654 mPUSHn(tmbuf.tm_year);
4655 mPUSHi(tmbuf.tm_wday);
4656 mPUSHi(tmbuf.tm_yday);
4657 mPUSHi(tmbuf.tm_isdst);
4668 anum = alarm((unsigned int)anum);
4674 DIE(aTHX_ PL_no_func, "alarm");
4685 (void)time(&lasttime);
4690 PerlProc_sleep((unsigned int)duration);
4693 XPUSHi(when - lasttime);
4697 /* Shared memory. */
4698 /* Merged with some message passing. */
4702 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4703 dVAR; dSP; dMARK; dTARGET;
4704 const int op_type = PL_op->op_type;
4709 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4712 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4715 value = (I32)(do_semop(MARK, SP) >= 0);
4718 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4734 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4735 dVAR; dSP; dMARK; dTARGET;
4736 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4743 DIE(aTHX_ "System V IPC is not implemented on this machine");
4749 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4750 dVAR; dSP; dMARK; dTARGET;
4751 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4759 PUSHp(zero_but_true, ZBTLEN);
4767 /* I can't const this further without getting warnings about the types of
4768 various arrays passed in from structures. */
4770 S_space_join_names_mortal(pTHX_ char *const *array)
4774 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4776 if (array && *array) {
4777 target = newSVpvs_flags("", SVs_TEMP);
4779 sv_catpv(target, *array);
4782 sv_catpvs(target, " ");
4785 target = sv_mortalcopy(&PL_sv_no);
4790 /* Get system info. */
4794 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4796 I32 which = PL_op->op_type;
4797 register char **elem;
4799 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4800 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4801 struct hostent *gethostbyname(Netdb_name_t);
4802 struct hostent *gethostent(void);
4804 struct hostent *hent = NULL;
4808 if (which == OP_GHBYNAME) {
4809 #ifdef HAS_GETHOSTBYNAME
4810 const char* const name = POPpbytex;
4811 hent = PerlSock_gethostbyname(name);
4813 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4816 else if (which == OP_GHBYADDR) {
4817 #ifdef HAS_GETHOSTBYADDR
4818 const int addrtype = POPi;
4819 SV * const addrsv = POPs;
4821 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4823 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4825 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4829 #ifdef HAS_GETHOSTENT
4830 hent = PerlSock_gethostent();
4832 DIE(aTHX_ PL_no_sock_func, "gethostent");
4835 #ifdef HOST_NOT_FOUND
4837 #ifdef USE_REENTRANT_API
4838 # ifdef USE_GETHOSTENT_ERRNO
4839 h_errno = PL_reentrant_buffer->_gethostent_errno;
4842 STATUS_UNIX_SET(h_errno);
4846 if (GIMME != G_ARRAY) {
4847 PUSHs(sv = sv_newmortal());
4849 if (which == OP_GHBYNAME) {
4851 sv_setpvn(sv, hent->h_addr, hent->h_length);
4854 sv_setpv(sv, (char*)hent->h_name);
4860 mPUSHs(newSVpv((char*)hent->h_name, 0));
4861 PUSHs(space_join_names_mortal(hent->h_aliases));
4862 mPUSHi(hent->h_addrtype);
4863 len = hent->h_length;
4866 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4867 mXPUSHp(*elem, len);
4871 mPUSHp(hent->h_addr, len);
4873 PUSHs(sv_mortalcopy(&PL_sv_no));
4878 DIE(aTHX_ PL_no_sock_func, "gethostent");
4884 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4886 I32 which = PL_op->op_type;
4888 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4889 struct netent *getnetbyaddr(Netdb_net_t, int);
4890 struct netent *getnetbyname(Netdb_name_t);
4891 struct netent *getnetent(void);
4893 struct netent *nent;
4895 if (which == OP_GNBYNAME){
4896 #ifdef HAS_GETNETBYNAME
4897 const char * const name = POPpbytex;
4898 nent = PerlSock_getnetbyname(name);
4900 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4903 else if (which == OP_GNBYADDR) {
4904 #ifdef HAS_GETNETBYADDR
4905 const int addrtype = POPi;
4906 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4907 nent = PerlSock_getnetbyaddr(addr, addrtype);
4909 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4913 #ifdef HAS_GETNETENT
4914 nent = PerlSock_getnetent();
4916 DIE(aTHX_ PL_no_sock_func, "getnetent");
4919 #ifdef HOST_NOT_FOUND
4921 #ifdef USE_REENTRANT_API
4922 # ifdef USE_GETNETENT_ERRNO
4923 h_errno = PL_reentrant_buffer->_getnetent_errno;
4926 STATUS_UNIX_SET(h_errno);
4931 if (GIMME != G_ARRAY) {
4932 PUSHs(sv = sv_newmortal());
4934 if (which == OP_GNBYNAME)
4935 sv_setiv(sv, (IV)nent->n_net);
4937 sv_setpv(sv, nent->n_name);
4943 mPUSHs(newSVpv(nent->n_name, 0));
4944 PUSHs(space_join_names_mortal(nent->n_aliases));
4945 mPUSHi(nent->n_addrtype);
4946 mPUSHi(nent->n_net);
4951 DIE(aTHX_ PL_no_sock_func, "getnetent");
4957 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4959 I32 which = PL_op->op_type;
4961 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4962 struct protoent *getprotobyname(Netdb_name_t);
4963 struct protoent *getprotobynumber(int);
4964 struct protoent *getprotoent(void);
4966 struct protoent *pent;
4968 if (which == OP_GPBYNAME) {
4969 #ifdef HAS_GETPROTOBYNAME
4970 const char* const name = POPpbytex;
4971 pent = PerlSock_getprotobyname(name);
4973 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4976 else if (which == OP_GPBYNUMBER) {
4977 #ifdef HAS_GETPROTOBYNUMBER
4978 const int number = POPi;
4979 pent = PerlSock_getprotobynumber(number);
4981 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4985 #ifdef HAS_GETPROTOENT
4986 pent = PerlSock_getprotoent();
4988 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4992 if (GIMME != G_ARRAY) {
4993 PUSHs(sv = sv_newmortal());
4995 if (which == OP_GPBYNAME)
4996 sv_setiv(sv, (IV)pent->p_proto);
4998 sv_setpv(sv, pent->p_name);
5004 mPUSHs(newSVpv(pent->p_name, 0));
5005 PUSHs(space_join_names_mortal(pent->p_aliases));
5006 mPUSHi(pent->p_proto);
5011 DIE(aTHX_ PL_no_sock_func, "getprotoent");
5017 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
5019 I32 which = PL_op->op_type;
5021 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
5022 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
5023 struct servent *getservbyport(int, Netdb_name_t);
5024 struct servent *getservent(void);
5026 struct servent *sent;
5028 if (which == OP_GSBYNAME) {
5029 #ifdef HAS_GETSERVBYNAME
5030 const char * const proto = POPpbytex;
5031 const char * const name = POPpbytex;
5032 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5034 DIE(aTHX_ PL_no_sock_func, "getservbyname");
5037 else if (which == OP_GSBYPORT) {
5038 #ifdef HAS_GETSERVBYPORT
5039 const char * const proto = POPpbytex;
5040 unsigned short port = (unsigned short)POPu;
5042 port = PerlSock_htons(port);
5044 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5046 DIE(aTHX_ PL_no_sock_func, "getservbyport");
5050 #ifdef HAS_GETSERVENT
5051 sent = PerlSock_getservent();
5053 DIE(aTHX_ PL_no_sock_func, "getservent");
5057 if (GIMME != G_ARRAY) {
5058 PUSHs(sv = sv_newmortal());
5060 if (which == OP_GSBYNAME) {
5062 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5064 sv_setiv(sv, (IV)(sent->s_port));
5068 sv_setpv(sv, sent->s_name);
5074 mPUSHs(newSVpv(sent->s_name, 0));
5075 PUSHs(space_join_names_mortal(sent->s_aliases));
5077 mPUSHi(PerlSock_ntohs(sent->s_port));
5079 mPUSHi(sent->s_port);
5081 mPUSHs(newSVpv(sent->s_proto, 0));
5086 DIE(aTHX_ PL_no_sock_func, "getservent");
5092 #ifdef HAS_SETHOSTENT
5094 PerlSock_sethostent(TOPi);
5097 DIE(aTHX_ PL_no_sock_func, "sethostent");
5103 #ifdef HAS_SETNETENT
5105 (void)PerlSock_setnetent(TOPi);
5108 DIE(aTHX_ PL_no_sock_func, "setnetent");
5114 #ifdef HAS_SETPROTOENT
5116 (void)PerlSock_setprotoent(TOPi);
5119 DIE(aTHX_ PL_no_sock_func, "setprotoent");
5125 #ifdef HAS_SETSERVENT
5127 (void)PerlSock_setservent(TOPi);
5130 DIE(aTHX_ PL_no_sock_func, "setservent");
5136 #ifdef HAS_ENDHOSTENT
5138 PerlSock_endhostent();
5142 DIE(aTHX_ PL_no_sock_func, "endhostent");
5148 #ifdef HAS_ENDNETENT
5150 PerlSock_endnetent();
5154 DIE(aTHX_ PL_no_sock_func, "endnetent");
5160 #ifdef HAS_ENDPROTOENT
5162 PerlSock_endprotoent();
5166 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5172 #ifdef HAS_ENDSERVENT
5174 PerlSock_endservent();
5178 DIE(aTHX_ PL_no_sock_func, "endservent");
5186 I32 which = PL_op->op_type;
5188 struct passwd *pwent = NULL;
5190 * We currently support only the SysV getsp* shadow password interface.
5191 * The interface is declared in <shadow.h> and often one needs to link
5192 * with -lsecurity or some such.
5193 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5196 * AIX getpwnam() is clever enough to return the encrypted password
5197 * only if the caller (euid?) is root.
5199 * There are at least three other shadow password APIs. Many platforms
5200 * seem to contain more than one interface for accessing the shadow
5201 * password databases, possibly for compatibility reasons.
5202 * The getsp*() is by far he simplest one, the other two interfaces
5203 * are much more complicated, but also very similar to each other.
5208 * struct pr_passwd *getprpw*();
5209 * The password is in
5210 * char getprpw*(...).ufld.fd_encrypt[]
5211 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5216 * struct es_passwd *getespw*();
5217 * The password is in
5218 * char *(getespw*(...).ufld.fd_encrypt)
5219 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5222 * struct userpw *getuserpw();
5223 * The password is in
5224 * char *(getuserpw(...)).spw_upw_passwd
5225 * (but the de facto standard getpwnam() should work okay)
5227 * Mention I_PROT here so that Configure probes for it.
5229 * In HP-UX for getprpw*() the manual page claims that one should include
5230 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5231 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5232 * and pp_sys.c already includes <shadow.h> if there is such.
5234 * Note that <sys/security.h> is already probed for, but currently
5235 * it is only included in special cases.
5237 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5238 * be preferred interface, even though also the getprpw*() interface
5239 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5240 * One also needs to call set_auth_parameters() in main() before
5241 * doing anything else, whether one is using getespw*() or getprpw*().
5243 * Note that accessing the shadow databases can be magnitudes
5244 * slower than accessing the standard databases.
5249 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5250 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5251 * the pw_comment is left uninitialized. */
5252 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5258 const char* const name = POPpbytex;
5259 pwent = getpwnam(name);
5265 pwent = getpwuid(uid);
5269 # ifdef HAS_GETPWENT
5271 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5272 if (pwent) pwent = getpwnam(pwent->pw_name);
5275 DIE(aTHX_ PL_no_func, "getpwent");
5281 if (GIMME != G_ARRAY) {
5282 PUSHs(sv = sv_newmortal());
5284 if (which == OP_GPWNAM)
5285 # if Uid_t_sign <= 0
5286 sv_setiv(sv, (IV)pwent->pw_uid);
5288 sv_setuv(sv, (UV)pwent->pw_uid);
5291 sv_setpv(sv, pwent->pw_name);
5297 mPUSHs(newSVpv(pwent->pw_name, 0));
5301 /* If we have getspnam(), we try to dig up the shadow
5302 * password. If we are underprivileged, the shadow
5303 * interface will set the errno to EACCES or similar,
5304 * and return a null pointer. If this happens, we will
5305 * use the dummy password (usually "*" or "x") from the
5306 * standard password database.
5308 * In theory we could skip the shadow call completely
5309 * if euid != 0 but in practice we cannot know which
5310 * security measures are guarding the shadow databases
5311 * on a random platform.
5313 * Resist the urge to use additional shadow interfaces.
5314 * Divert the urge to writing an extension instead.
5317 /* Some AIX setups falsely(?) detect some getspnam(), which
5318 * has a different API than the Solaris/IRIX one. */
5319 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5322 const struct spwd * const spwent = getspnam(pwent->pw_name);
5323 /* Save and restore errno so that
5324 * underprivileged attempts seem
5325 * to have never made the unsccessful
5326 * attempt to retrieve the shadow password. */
5328 if (spwent && spwent->sp_pwdp)
5329 sv_setpv(sv, spwent->sp_pwdp);
5333 if (!SvPOK(sv)) /* Use the standard password, then. */
5334 sv_setpv(sv, pwent->pw_passwd);
5337 # ifndef INCOMPLETE_TAINTS
5338 /* passwd is tainted because user himself can diddle with it.
5339 * admittedly not much and in a very limited way, but nevertheless. */
5343 # if Uid_t_sign <= 0
5344 mPUSHi(pwent->pw_uid);
5346 mPUSHu(pwent->pw_uid);
5349 # if Uid_t_sign <= 0
5350 mPUSHi(pwent->pw_gid);
5352 mPUSHu(pwent->pw_gid);
5354 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5355 * because of the poor interface of the Perl getpw*(),
5356 * not because there's some standard/convention saying so.
5357 * A better interface would have been to return a hash,
5358 * but we are accursed by our history, alas. --jhi. */
5360 mPUSHi(pwent->pw_change);
5363 mPUSHi(pwent->pw_quota);
5366 mPUSHs(newSVpv(pwent->pw_age, 0));
5368 /* I think that you can never get this compiled, but just in case. */
5369 PUSHs(sv_mortalcopy(&PL_sv_no));
5374 /* pw_class and pw_comment are mutually exclusive--.
5375 * see the above note for pw_change, pw_quota, and pw_age. */
5377 mPUSHs(newSVpv(pwent->pw_class, 0));
5380 mPUSHs(newSVpv(pwent->pw_comment, 0));
5382 /* I think that you can never get this compiled, but just in case. */
5383 PUSHs(sv_mortalcopy(&PL_sv_no));
5388 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5390 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5392 # ifndef INCOMPLETE_TAINTS
5393 /* pw_gecos is tainted because user himself can diddle with it. */
5397 mPUSHs(newSVpv(pwent->pw_dir, 0));
5399 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5400 # ifndef INCOMPLETE_TAINTS
5401 /* pw_shell is tainted because user himself can diddle with it. */
5406 mPUSHi(pwent->pw_expire);
5411 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5417 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5422 DIE(aTHX_ PL_no_func, "setpwent");
5428 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5433 DIE(aTHX_ PL_no_func, "endpwent");
5441 const I32 which = PL_op->op_type;
5442 const struct group *grent;
5444 if (which == OP_GGRNAM) {
5445 const char* const name = POPpbytex;
5446 grent = (const struct group *)getgrnam(name);
5448 else if (which == OP_GGRGID) {
5449 const Gid_t gid = POPi;
5450 grent = (const struct group *)getgrgid(gid);
5454 grent = (struct group *)getgrent();
5456 DIE(aTHX_ PL_no_func, "getgrent");
5460 if (GIMME != G_ARRAY) {
5461 SV * const sv = sv_newmortal();
5465 if (which == OP_GGRNAM)
5467 sv_setiv(sv, (IV)grent->gr_gid);
5469 sv_setuv(sv, (UV)grent->gr_gid);
5472 sv_setpv(sv, grent->gr_name);
5478 mPUSHs(newSVpv(grent->gr_name, 0));
5481 mPUSHs(newSVpv(grent->gr_passwd, 0));
5483 PUSHs(sv_mortalcopy(&PL_sv_no));
5487 mPUSHi(grent->gr_gid);
5489 mPUSHu(grent->gr_gid);
5492 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5493 /* In UNICOS/mk (_CRAYMPP) the multithreading
5494 * versions (getgrnam_r, getgrgid_r)
5495 * seem to return an illegal pointer
5496 * as the group members list, gr_mem.
5497 * getgrent() doesn't even have a _r version
5498 * but the gr_mem is poisonous anyway.
5499 * So yes, you cannot get the list of group
5500 * members if building multithreaded in UNICOS/mk. */
5501 PUSHs(space_join_names_mortal(grent->gr_mem));
5507 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5513 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5518 DIE(aTHX_ PL_no_func, "setgrent");
5524 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5529 DIE(aTHX_ PL_no_func, "endgrent");
5539 if (!(tmps = PerlProc_getlogin()))
5541 sv_setpv_mg(TARG, tmps);
5545 DIE(aTHX_ PL_no_func, "getlogin");
5549 /* Miscellaneous. */
5554 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5555 register I32 items = SP - MARK;
5556 unsigned long a[20];
5561 while (++MARK <= SP) {
5562 if (SvTAINTED(*MARK)) {
5568 TAINT_PROPER("syscall");
5571 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5572 * or where sizeof(long) != sizeof(char*). But such machines will
5573 * not likely have syscall implemented either, so who cares?
5575 while (++MARK <= SP) {
5576 if (SvNIOK(*MARK) || !i)
5577 a[i++] = SvIV(*MARK);
5578 else if (*MARK == &PL_sv_undef)
5581 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5587 DIE(aTHX_ "Too many args to syscall");
5589 DIE(aTHX_ "Too few args to syscall");
5591 retval = syscall(a[0]);
5594 retval = syscall(a[0],a[1]);
5597 retval = syscall(a[0],a[1],a[2]);
5600 retval = syscall(a[0],a[1],a[2],a[3]);
5603 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5606 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5609 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5612 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5616 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5619 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5622 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5626 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5630 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5634 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5635 a[10],a[11],a[12],a[13]);
5637 #endif /* atarist */
5643 DIE(aTHX_ PL_no_func, "syscall");
5647 #ifdef FCNTL_EMULATE_FLOCK
5649 /* XXX Emulate flock() with fcntl().
5650 What's really needed is a good file locking module.
5654 fcntl_emulate_flock(int fd, int operation)
5659 switch (operation & ~LOCK_NB) {
5661 flock.l_type = F_RDLCK;
5664 flock.l_type = F_WRLCK;
5667 flock.l_type = F_UNLCK;
5673 flock.l_whence = SEEK_SET;
5674 flock.l_start = flock.l_len = (Off_t)0;
5676 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5677 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5678 errno = EWOULDBLOCK;
5682 #endif /* FCNTL_EMULATE_FLOCK */
5684 #ifdef LOCKF_EMULATE_FLOCK
5686 /* XXX Emulate flock() with lockf(). This is just to increase
5687 portability of scripts. The calls are not completely
5688 interchangeable. What's really needed is a good file
5692 /* The lockf() constants might have been defined in <unistd.h>.
5693 Unfortunately, <unistd.h> causes troubles on some mixed
5694 (BSD/POSIX) systems, such as SunOS 4.1.3.
5696 Further, the lockf() constants aren't POSIX, so they might not be
5697 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5698 just stick in the SVID values and be done with it. Sigh.
5702 # define F_ULOCK 0 /* Unlock a previously locked region */
5705 # define F_LOCK 1 /* Lock a region for exclusive use */
5708 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5711 # define F_TEST 3 /* Test a region for other processes locks */
5715 lockf_emulate_flock(int fd, int operation)
5721 /* flock locks entire file so for lockf we need to do the same */
5722 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5723 if (pos > 0) /* is seekable and needs to be repositioned */
5724 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5725 pos = -1; /* seek failed, so don't seek back afterwards */
5728 switch (operation) {
5730 /* LOCK_SH - get a shared lock */
5732 /* LOCK_EX - get an exclusive lock */
5734 i = lockf (fd, F_LOCK, 0);
5737 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5738 case LOCK_SH|LOCK_NB:
5739 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5740 case LOCK_EX|LOCK_NB:
5741 i = lockf (fd, F_TLOCK, 0);
5743 if ((errno == EAGAIN) || (errno == EACCES))
5744 errno = EWOULDBLOCK;
5747 /* LOCK_UN - unlock (non-blocking is a no-op) */
5749 case LOCK_UN|LOCK_NB:
5750 i = lockf (fd, F_ULOCK, 0);
5753 /* Default - can't decipher operation */
5760 if (pos > 0) /* need to restore position of the handle */
5761 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5766 #endif /* LOCKF_EMULATE_FLOCK */
5770 * c-indentation-style: bsd
5772 * indent-tabs-mode: t
5775 * ex: set ts=8 sts=4 sw=4 noet: