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 methname = "TIEHANDLE";
831 how = PERL_MAGIC_tiedscalar;
832 /* For tied filehandles, we apply tiedscalar magic to the IO
833 slot of the GP rather than the GV itself. AMS 20010812 */
835 GvIOp(varsv) = newIO();
836 varsv = MUTABLE_SV(GvIOp(varsv));
841 methname = "TIESCALAR";
842 how = PERL_MAGIC_tiedscalar;
846 if (sv_isobject(*MARK)) { /* Calls GET magic. */
847 ENTER_with_name("call_TIE");
848 PUSHSTACKi(PERLSI_MAGIC);
850 EXTEND(SP,(I32)items);
854 call_method(methname, G_SCALAR);
857 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
858 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
859 * wrong error message, and worse case, supreme action at a distance.
860 * (Sorry obfuscation writers. You're not going to be given this one.)
863 const char *name = SvPV_nomg_const(*MARK, len);
864 stash = gv_stashpvn(name, len, 0);
865 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
866 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
867 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
869 ENTER_with_name("call_TIE");
870 PUSHSTACKi(PERLSI_MAGIC);
872 EXTEND(SP,(I32)items);
876 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
882 if (sv_isobject(sv)) {
883 sv_unmagic(varsv, how);
884 /* Croak if a self-tie on an aggregate is attempted. */
885 if (varsv == SvRV(sv) &&
886 (SvTYPE(varsv) == SVt_PVAV ||
887 SvTYPE(varsv) == SVt_PVHV))
889 "Self-ties of arrays and hashes are not supported");
890 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
892 LEAVE_with_name("call_TIE");
893 SP = PL_stack_base + markoff;
903 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
904 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
906 if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
909 if ((mg = SvTIED_mg(sv, how))) {
910 SV * const obj = SvRV(SvTIED_obj(sv, mg));
912 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
914 if (gv && isGV(gv) && (cv = GvCV(gv))) {
916 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
917 mXPUSHi(SvREFCNT(obj) - 1);
919 ENTER_with_name("call_UNTIE");
920 call_sv(MUTABLE_SV(cv), G_VOID);
921 LEAVE_with_name("call_UNTIE");
924 else if (mg && SvREFCNT(obj) > 1) {
925 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
926 "untie attempted while %"UVuf" inner references still exist",
927 (UV)SvREFCNT(obj) - 1 ) ;
931 sv_unmagic(sv, how) ;
941 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
942 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
944 if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
947 if ((mg = SvTIED_mg(sv, how))) {
948 SV *osv = SvTIED_obj(sv, mg);
949 if (osv == mg->mg_obj)
950 osv = sv_mortalcopy(osv);
964 HV * const hv = MUTABLE_HV(POPs);
965 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
966 stash = gv_stashsv(sv, 0);
967 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
969 require_pv("AnyDBM_File.pm");
971 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
972 DIE(aTHX_ "No dbm on this machine");
982 mPUSHu(O_RDWR|O_CREAT);
987 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
990 if (!sv_isobject(TOPs)) {
998 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1002 if (sv_isobject(TOPs)) {
1003 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1004 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1021 struct timeval timebuf;
1022 struct timeval *tbuf = &timebuf;
1025 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1030 # if BYTEORDER & 0xf0000
1031 # define ORDERBYTE (0x88888888 - BYTEORDER)
1033 # define ORDERBYTE (0x4444 - BYTEORDER)
1039 for (i = 1; i <= 3; i++) {
1040 SV * const sv = SP[i];
1043 if (SvREADONLY(sv)) {
1045 sv_force_normal_flags(sv, 0);
1046 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1047 Perl_croak_no_modify(aTHX);
1050 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1051 SvPV_force_nolen(sv); /* force string conversion */
1058 /* little endians can use vecs directly */
1059 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1066 masksize = NFDBITS / NBBY;
1068 masksize = sizeof(long); /* documented int, everyone seems to use long */
1070 Zero(&fd_sets[0], 4, char*);
1073 # if SELECT_MIN_BITS == 1
1074 growsize = sizeof(fd_set);
1076 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1077 # undef SELECT_MIN_BITS
1078 # define SELECT_MIN_BITS __FD_SETSIZE
1080 /* If SELECT_MIN_BITS is greater than one we most probably will want
1081 * to align the sizes with SELECT_MIN_BITS/8 because for example
1082 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1083 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1084 * on (sets/tests/clears bits) is 32 bits. */
1085 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1093 timebuf.tv_sec = (long)value;
1094 value -= (NV)timebuf.tv_sec;
1095 timebuf.tv_usec = (long)(value * 1000000.0);
1100 for (i = 1; i <= 3; i++) {
1102 if (!SvOK(sv) || SvCUR(sv) == 0) {
1109 Sv_Grow(sv, growsize);
1113 while (++j <= growsize) {
1117 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1119 Newx(fd_sets[i], growsize, char);
1120 for (offset = 0; offset < growsize; offset += masksize) {
1121 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1122 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1125 fd_sets[i] = SvPVX(sv);
1129 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1130 /* Can't make just the (void*) conditional because that would be
1131 * cpp #if within cpp macro, and not all compilers like that. */
1132 nfound = PerlSock_select(
1134 (Select_fd_set_t) fd_sets[1],
1135 (Select_fd_set_t) fd_sets[2],
1136 (Select_fd_set_t) fd_sets[3],
1137 (void*) tbuf); /* Workaround for compiler bug. */
1139 nfound = PerlSock_select(
1141 (Select_fd_set_t) fd_sets[1],
1142 (Select_fd_set_t) fd_sets[2],
1143 (Select_fd_set_t) fd_sets[3],
1146 for (i = 1; i <= 3; i++) {
1149 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1151 for (offset = 0; offset < growsize; offset += masksize) {
1152 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1153 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1155 Safefree(fd_sets[i]);
1162 if (GIMME == G_ARRAY && tbuf) {
1163 value = (NV)(timebuf.tv_sec) +
1164 (NV)(timebuf.tv_usec) / 1000000.0;
1169 DIE(aTHX_ "select not implemented");
1174 =for apidoc setdefout
1176 Sets PL_defoutgv, the default file handle for output, to the passed in
1177 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1178 count of the passed in typeglob is increased by one, and the reference count
1179 of the typeglob that PL_defoutgv points to is decreased by one.
1185 Perl_setdefout(pTHX_ GV *gv)
1188 SvREFCNT_inc_simple_void(gv);
1189 SvREFCNT_dec(PL_defoutgv);
1197 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1198 GV * egv = GvEGVx(PL_defoutgv);
1202 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1204 XPUSHs(&PL_sv_undef);
1206 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1207 if (gvp && *gvp == egv) {
1208 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1212 mXPUSHs(newRV(MUTABLE_SV(egv)));
1217 if (!GvIO(newdefout))
1218 gv_IOadd(newdefout);
1219 setdefout(newdefout);
1229 GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs);
1234 if (gv && (io = GvIO(gv))) {
1235 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1237 const U32 gimme = GIMME_V;
1238 S_tied_handle_method(aTHX_ "GETC", SP, io, mg, gimme);
1239 if (gimme == G_SCALAR) {
1241 SvSetMagicSV_nosteal(TARG, TOPs);
1246 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1247 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1248 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1249 report_evil_fh(gv, io, PL_op->op_type);
1250 SETERRNO(EBADF,RMS_IFI);
1254 sv_setpvs(TARG, " ");
1255 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1256 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1257 /* Find out how many bytes the char needs */
1258 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1261 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1262 SvCUR_set(TARG,1+len);
1271 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1274 register PERL_CONTEXT *cx;
1275 const I32 gimme = GIMME_V;
1277 PERL_ARGS_ASSERT_DOFORM;
1279 if (cv && CvCLONE(cv))
1280 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1285 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1286 PUSHFORMAT(cx, retop);
1288 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1290 setdefout(gv); /* locally select filehandle so $% et al work */
1309 gv = MUTABLE_GV(POPs);
1323 goto not_a_format_reference;
1328 tmpsv = sv_newmortal();
1329 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1330 name = SvPV_nolen_const(tmpsv);
1332 DIE(aTHX_ "Undefined format \"%s\" called", name);
1334 not_a_format_reference:
1335 DIE(aTHX_ "Not a format reference");
1337 IoFLAGS(io) &= ~IOf_DIDTOP;
1338 return doform(cv,gv,PL_op->op_next);
1344 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1345 register IO * const io = GvIOp(gv);
1350 register PERL_CONTEXT *cx;
1352 if (!io || !(ofp = IoOFP(io)))
1355 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1356 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1358 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1359 PL_formtarget != PL_toptarget)
1363 if (!IoTOP_GV(io)) {
1366 if (!IoTOP_NAME(io)) {
1368 if (!IoFMT_NAME(io))
1369 IoFMT_NAME(io) = savepv(GvNAME(gv));
1370 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1371 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1372 if ((topgv && GvFORM(topgv)) ||
1373 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1374 IoTOP_NAME(io) = savesvpv(topname);
1376 IoTOP_NAME(io) = savepvs("top");
1378 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1379 if (!topgv || !GvFORM(topgv)) {
1380 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1383 IoTOP_GV(io) = topgv;
1385 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1386 I32 lines = IoLINES_LEFT(io);
1387 const char *s = SvPVX_const(PL_formtarget);
1388 if (lines <= 0) /* Yow, header didn't even fit!!! */
1390 while (lines-- > 0) {
1391 s = strchr(s, '\n');
1397 const STRLEN save = SvCUR(PL_formtarget);
1398 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1399 do_print(PL_formtarget, ofp);
1400 SvCUR_set(PL_formtarget, save);
1401 sv_chop(PL_formtarget, s);
1402 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1405 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1406 do_print(PL_formfeed, ofp);
1407 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1409 PL_formtarget = PL_toptarget;
1410 IoFLAGS(io) |= IOf_DIDTOP;
1413 DIE(aTHX_ "bad top format reference");
1416 SV * const sv = sv_newmortal();
1418 gv_efullname4(sv, fgv, NULL, FALSE);
1419 name = SvPV_nolen_const(sv);
1421 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1423 DIE(aTHX_ "Undefined top format called");
1425 return doform(cv, gv, PL_op);
1429 POPBLOCK(cx,PL_curpm);
1435 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1437 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1438 else if (ckWARN(WARN_CLOSED))
1439 report_evil_fh(gv, io, PL_op->op_type);
1444 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1445 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1447 if (!do_print(PL_formtarget, fp))
1450 FmLINES(PL_formtarget) = 0;
1451 SvCUR_set(PL_formtarget, 0);
1452 *SvEND(PL_formtarget) = '\0';
1453 if (IoFLAGS(io) & IOf_FLUSH)
1454 (void)PerlIO_flush(fp);
1459 PL_formtarget = PL_bodytarget;
1461 PERL_UNUSED_VAR(newsp);
1462 PERL_UNUSED_VAR(gimme);
1463 return cx->blk_sub.retop;
1468 dVAR; dSP; dMARK; dORIGMARK;
1474 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1476 if (gv && (io = GvIO(gv))) {
1477 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1479 if (MARK == ORIGMARK) {
1482 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1486 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1489 call_method("PRINTF", G_SCALAR);
1492 MARK = ORIGMARK + 1;
1500 if (!(io = GvIO(gv))) {
1501 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1502 report_evil_fh(gv, io, PL_op->op_type);
1503 SETERRNO(EBADF,RMS_IFI);
1506 else if (!(fp = IoOFP(io))) {
1507 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1509 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1510 else if (ckWARN(WARN_CLOSED))
1511 report_evil_fh(gv, io, PL_op->op_type);
1513 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1517 if (SvTAINTED(MARK[1]))
1518 TAINT_PROPER("printf");
1519 do_sprintf(sv, SP - MARK, MARK + 1);
1520 if (!do_print(sv, fp))
1523 if (IoFLAGS(io) & IOf_FLUSH)
1524 if (PerlIO_flush(fp) == EOF)
1535 PUSHs(&PL_sv_undef);
1543 const int perm = (MAXARG > 3) ? POPi : 0666;
1544 const int mode = POPi;
1545 SV * const sv = POPs;
1546 GV * const gv = MUTABLE_GV(POPs);
1549 /* Need TIEHANDLE method ? */
1550 const char * const tmps = SvPV_const(sv, len);
1551 /* FIXME? do_open should do const */
1552 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1553 IoLINES(GvIOp(gv)) = 0;
1557 PUSHs(&PL_sv_undef);
1564 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1570 Sock_size_t bufsize;
1578 bool charstart = FALSE;
1579 STRLEN charskip = 0;
1582 GV * const gv = MUTABLE_GV(*++MARK);
1583 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1584 && gv && (io = GvIO(gv)) )
1586 const MAGIC * mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1590 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1592 call_method("READ", G_SCALAR);
1606 sv_setpvs(bufsv, "");
1607 length = SvIVx(*++MARK);
1610 offset = SvIVx(*++MARK);
1614 if (!io || !IoIFP(io)) {
1615 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1616 report_evil_fh(gv, io, PL_op->op_type);
1617 SETERRNO(EBADF,RMS_IFI);
1620 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1621 buffer = SvPVutf8_force(bufsv, blen);
1622 /* UTF-8 may not have been set if they are all low bytes */
1627 buffer = SvPV_force(bufsv, blen);
1628 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1631 DIE(aTHX_ "Negative length");
1639 if (PL_op->op_type == OP_RECV) {
1640 char namebuf[MAXPATHLEN];
1641 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1642 bufsize = sizeof (struct sockaddr_in);
1644 bufsize = sizeof namebuf;
1646 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1650 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1651 /* 'offset' means 'flags' here */
1652 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1653 (struct sockaddr *)namebuf, &bufsize);
1657 /* Bogus return without padding */
1658 bufsize = sizeof (struct sockaddr_in);
1660 SvCUR_set(bufsv, count);
1661 *SvEND(bufsv) = '\0';
1662 (void)SvPOK_only(bufsv);
1666 /* This should not be marked tainted if the fp is marked clean */
1667 if (!(IoFLAGS(io) & IOf_UNTAINT))
1668 SvTAINTED_on(bufsv);
1670 sv_setpvn(TARG, namebuf, bufsize);
1675 if (PL_op->op_type == OP_RECV)
1676 DIE(aTHX_ PL_no_sock_func, "recv");
1678 if (DO_UTF8(bufsv)) {
1679 /* offset adjust in characters not bytes */
1680 blen = sv_len_utf8(bufsv);
1683 if (-offset > (int)blen)
1684 DIE(aTHX_ "Offset outside string");
1687 if (DO_UTF8(bufsv)) {
1688 /* convert offset-as-chars to offset-as-bytes */
1689 if (offset >= (int)blen)
1690 offset += SvCUR(bufsv) - blen;
1692 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1695 bufsize = SvCUR(bufsv);
1696 /* Allocating length + offset + 1 isn't perfect in the case of reading
1697 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1699 (should be 2 * length + offset + 1, or possibly something longer if
1700 PL_encoding is true) */
1701 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1702 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1703 Zero(buffer+bufsize, offset-bufsize, char);
1705 buffer = buffer + offset;
1707 read_target = bufsv;
1709 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1710 concatenate it to the current buffer. */
1712 /* Truncate the existing buffer to the start of where we will be
1714 SvCUR_set(bufsv, offset);
1716 read_target = sv_newmortal();
1717 SvUPGRADE(read_target, SVt_PV);
1718 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1721 if (PL_op->op_type == OP_SYSREAD) {
1722 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1723 if (IoTYPE(io) == IoTYPE_SOCKET) {
1724 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1730 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1735 #ifdef HAS_SOCKET__bad_code_maybe
1736 if (IoTYPE(io) == IoTYPE_SOCKET) {
1737 char namebuf[MAXPATHLEN];
1738 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1739 bufsize = sizeof (struct sockaddr_in);
1741 bufsize = sizeof namebuf;
1743 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1744 (struct sockaddr *)namebuf, &bufsize);
1749 count = PerlIO_read(IoIFP(io), buffer, length);
1750 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1751 if (count == 0 && PerlIO_error(IoIFP(io)))
1755 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1756 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1759 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1760 *SvEND(read_target) = '\0';
1761 (void)SvPOK_only(read_target);
1762 if (fp_utf8 && !IN_BYTES) {
1763 /* Look at utf8 we got back and count the characters */
1764 const char *bend = buffer + count;
1765 while (buffer < bend) {
1767 skip = UTF8SKIP(buffer);
1770 if (buffer - charskip + skip > bend) {
1771 /* partial character - try for rest of it */
1772 length = skip - (bend-buffer);
1773 offset = bend - SvPVX_const(bufsv);
1785 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1786 provided amount read (count) was what was requested (length)
1788 if (got < wanted && count == length) {
1789 length = wanted - got;
1790 offset = bend - SvPVX_const(bufsv);
1793 /* return value is character count */
1797 else if (buffer_utf8) {
1798 /* Let svcatsv upgrade the bytes we read in to utf8.
1799 The buffer is a mortal so will be freed soon. */
1800 sv_catsv_nomg(bufsv, read_target);
1803 /* This should not be marked tainted if the fp is marked clean */
1804 if (!(IoFLAGS(io) & IOf_UNTAINT))
1805 SvTAINTED_on(bufsv);
1817 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1823 STRLEN orig_blen_bytes;
1824 const int op_type = PL_op->op_type;
1828 GV *const gv = MUTABLE_GV(*++MARK);
1829 if (PL_op->op_type == OP_SYSWRITE
1830 && gv && (io = GvIO(gv))) {
1831 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1835 if (MARK == SP - 1) {
1837 mXPUSHi(sv_len(sv));
1842 *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg);
1844 call_method("WRITE", G_SCALAR);
1860 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1862 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1863 if (io && IoIFP(io))
1864 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1866 report_evil_fh(gv, io, PL_op->op_type);
1868 SETERRNO(EBADF,RMS_IFI);
1872 /* Do this first to trigger any overloading. */
1873 buffer = SvPV_const(bufsv, blen);
1874 orig_blen_bytes = blen;
1875 doing_utf8 = DO_UTF8(bufsv);
1877 if (PerlIO_isutf8(IoIFP(io))) {
1878 if (!SvUTF8(bufsv)) {
1879 /* We don't modify the original scalar. */
1880 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1881 buffer = (char *) tmpbuf;
1885 else if (doing_utf8) {
1886 STRLEN tmplen = blen;
1887 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1890 buffer = (char *) tmpbuf;
1894 assert((char *)result == buffer);
1895 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1899 if (op_type == OP_SYSWRITE) {
1900 Size_t length = 0; /* This length is in characters. */
1906 /* The SV is bytes, and we've had to upgrade it. */
1907 blen_chars = orig_blen_bytes;
1909 /* The SV really is UTF-8. */
1910 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1911 /* Don't call sv_len_utf8 again because it will call magic
1912 or overloading a second time, and we might get back a
1913 different result. */
1914 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1916 /* It's safe, and it may well be cached. */
1917 blen_chars = sv_len_utf8(bufsv);
1925 length = blen_chars;
1927 #if Size_t_size > IVSIZE
1928 length = (Size_t)SvNVx(*++MARK);
1930 length = (Size_t)SvIVx(*++MARK);
1932 if ((SSize_t)length < 0) {
1934 DIE(aTHX_ "Negative length");
1939 offset = SvIVx(*++MARK);
1941 if (-offset > (IV)blen_chars) {
1943 DIE(aTHX_ "Offset outside string");
1945 offset += blen_chars;
1946 } else if (offset > (IV)blen_chars) {
1948 DIE(aTHX_ "Offset outside string");
1952 if (length > blen_chars - offset)
1953 length = blen_chars - offset;
1955 /* Here we convert length from characters to bytes. */
1956 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1957 /* Either we had to convert the SV, or the SV is magical, or
1958 the SV has overloading, in which case we can't or mustn't
1959 or mustn't call it again. */
1961 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1962 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1964 /* It's a real UTF-8 SV, and it's not going to change under
1965 us. Take advantage of any cache. */
1967 I32 len_I32 = length;
1969 /* Convert the start and end character positions to bytes.
1970 Remember that the second argument to sv_pos_u2b is relative
1972 sv_pos_u2b(bufsv, &start, &len_I32);
1979 buffer = buffer+offset;
1981 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1982 if (IoTYPE(io) == IoTYPE_SOCKET) {
1983 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1989 /* See the note at doio.c:do_print about filesize limits. --jhi */
1990 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1996 const int flags = SvIVx(*++MARK);
1999 char * const sockbuf = SvPVx(*++MARK, mlen);
2000 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
2001 flags, (struct sockaddr *)sockbuf, mlen);
2005 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
2010 DIE(aTHX_ PL_no_sock_func, "send");
2017 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2020 #if Size_t_size > IVSIZE
2040 * in Perl 5.12 and later, the additional parameter is a bitmask:
2043 * 2 = eof() <- ARGV magic
2045 * I'll rely on the compiler's trace flow analysis to decide whether to
2046 * actually assign this out here, or punt it into the only block where it is
2047 * used. Doing it out here is DRY on the condition logic.
2052 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2058 if (PL_op->op_flags & OPf_SPECIAL) {
2059 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2063 gv = PL_last_in_gv; /* eof */
2071 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2072 return tied_handle_method1("EOF", SP, io, mg, newSVuv(which));
2075 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2076 if (io && !IoIFP(io)) {
2077 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2079 IoFLAGS(io) &= ~IOf_START;
2080 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2082 sv_setpvs(GvSV(gv), "-");
2084 GvSV(gv) = newSVpvs("-");
2085 SvSETMAGIC(GvSV(gv));
2087 else if (!nextargv(gv))
2092 PUSHs(boolSV(do_eof(gv)));
2103 PL_last_in_gv = MUTABLE_GV(POPs);
2108 if (gv && (io = GvIO(gv))) {
2109 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2111 return tied_handle_method("TELL", SP, io, mg);
2116 SETERRNO(EBADF,RMS_IFI);
2121 #if LSEEKSIZE > IVSIZE
2122 PUSHn( do_tell(gv) );
2124 PUSHi( do_tell(gv) );
2132 const int whence = POPi;
2133 #if LSEEKSIZE > IVSIZE
2134 const Off_t offset = (Off_t)SvNVx(POPs);
2136 const Off_t offset = (Off_t)SvIVx(POPs);
2139 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2142 if (gv && (io = GvIO(gv))) {
2143 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2145 #if LSEEKSIZE > IVSIZE
2146 SV *const offset_sv = newSVnv((NV) offset);
2148 SV *const offset_sv = newSViv(offset);
2151 return tied_handle_method2("SEEK", SP, io, mg, offset_sv,
2156 if (PL_op->op_type == OP_SEEK)
2157 PUSHs(boolSV(do_seek(gv, offset, whence)));
2159 const Off_t sought = do_sysseek(gv, offset, whence);
2161 PUSHs(&PL_sv_undef);
2163 SV* const sv = sought ?
2164 #if LSEEKSIZE > IVSIZE
2169 : newSVpvn(zero_but_true, ZBTLEN);
2180 /* There seems to be no consensus on the length type of truncate()
2181 * and ftruncate(), both off_t and size_t have supporters. In
2182 * general one would think that when using large files, off_t is
2183 * at least as wide as size_t, so using an off_t should be okay. */
2184 /* XXX Configure probe for the length type of *truncate() needed XXX */
2187 #if Off_t_size > IVSIZE
2192 /* Checking for length < 0 is problematic as the type might or
2193 * might not be signed: if it is not, clever compilers will moan. */
2194 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2201 if (PL_op->op_flags & OPf_SPECIAL) {
2202 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2211 TAINT_PROPER("truncate");
2212 if (!(fp = IoIFP(io))) {
2218 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2220 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2227 SV * const sv = POPs;
2230 if (isGV_with_GP(sv)) {
2231 tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */
2232 goto do_ftruncate_gv;
2234 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2235 tmpgv = MUTABLE_GV(SvRV(sv)); /* \*main::FRED for example */
2236 goto do_ftruncate_gv;
2238 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2239 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2240 goto do_ftruncate_io;
2243 name = SvPV_nolen_const(sv);
2244 TAINT_PROPER("truncate");
2246 if (truncate(name, len) < 0)
2250 const int tmpfd = PerlLIO_open(name, O_RDWR);
2255 if (my_chsize(tmpfd, len) < 0)
2257 PerlLIO_close(tmpfd);
2266 SETERRNO(EBADF,RMS_IFI);
2274 SV * const argsv = POPs;
2275 const unsigned int func = POPu;
2276 const int optype = PL_op->op_type;
2277 GV * const gv = MUTABLE_GV(POPs);
2278 IO * const io = gv ? GvIOn(gv) : NULL;
2282 if (!io || !argsv || !IoIFP(io)) {
2283 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2284 report_evil_fh(gv, io, PL_op->op_type);
2285 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2289 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2292 s = SvPV_force(argsv, len);
2293 need = IOCPARM_LEN(func);
2295 s = Sv_Grow(argsv, need + 1);
2296 SvCUR_set(argsv, need);
2299 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2302 retval = SvIV(argsv);
2303 s = INT2PTR(char*,retval); /* ouch */
2306 TAINT_PROPER(PL_op_desc[optype]);
2308 if (optype == OP_IOCTL)
2310 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2312 DIE(aTHX_ "ioctl is not implemented");
2316 DIE(aTHX_ "fcntl is not implemented");
2318 #if defined(OS2) && defined(__EMX__)
2319 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2321 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2325 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2327 if (s[SvCUR(argsv)] != 17)
2328 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2330 s[SvCUR(argsv)] = 0; /* put our null back */
2331 SvSETMAGIC(argsv); /* Assume it has changed */
2340 PUSHp(zero_but_true, ZBTLEN);
2353 const int argtype = POPi;
2354 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
2356 if (gv && (io = GvIO(gv)))
2362 /* XXX Looks to me like io is always NULL at this point */
2364 (void)PerlIO_flush(fp);
2365 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2368 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2369 report_evil_fh(gv, io, PL_op->op_type);
2371 SETERRNO(EBADF,RMS_IFI);
2376 DIE(aTHX_ PL_no_func, "flock()");
2386 const int protocol = POPi;
2387 const int type = POPi;
2388 const int domain = POPi;
2389 GV * const gv = MUTABLE_GV(POPs);
2390 register IO * const io = gv ? GvIOn(gv) : NULL;
2394 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2395 report_evil_fh(gv, io, PL_op->op_type);
2396 if (io && IoIFP(io))
2397 do_close(gv, FALSE);
2398 SETERRNO(EBADF,LIB_INVARG);
2403 do_close(gv, FALSE);
2405 TAINT_PROPER("socket");
2406 fd = PerlSock_socket(domain, type, protocol);
2409 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2410 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2411 IoTYPE(io) = IoTYPE_SOCKET;
2412 if (!IoIFP(io) || !IoOFP(io)) {
2413 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2414 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2415 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2418 #if defined(HAS_FCNTL) && defined(F_SETFD)
2419 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2423 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2428 DIE(aTHX_ PL_no_sock_func, "socket");
2434 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2436 const int protocol = POPi;
2437 const int type = POPi;
2438 const int domain = POPi;
2439 GV * const gv2 = MUTABLE_GV(POPs);
2440 GV * const gv1 = MUTABLE_GV(POPs);
2441 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2442 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2445 if (!gv1 || !gv2 || !io1 || !io2) {
2446 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2448 report_evil_fh(gv1, io1, PL_op->op_type);
2450 report_evil_fh(gv1, io2, PL_op->op_type);
2452 if (io1 && IoIFP(io1))
2453 do_close(gv1, FALSE);
2454 if (io2 && IoIFP(io2))
2455 do_close(gv2, FALSE);
2460 do_close(gv1, FALSE);
2462 do_close(gv2, FALSE);
2464 TAINT_PROPER("socketpair");
2465 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2467 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2468 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2469 IoTYPE(io1) = IoTYPE_SOCKET;
2470 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2471 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2472 IoTYPE(io2) = IoTYPE_SOCKET;
2473 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2474 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2475 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2476 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2477 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2478 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2479 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2482 #if defined(HAS_FCNTL) && defined(F_SETFD)
2483 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2484 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2489 DIE(aTHX_ PL_no_sock_func, "socketpair");
2497 SV * const addrsv = POPs;
2498 /* OK, so on what platform does bind modify addr? */
2500 GV * const gv = MUTABLE_GV(POPs);
2501 register IO * const io = GvIOn(gv);
2504 if (!io || !IoIFP(io))
2507 addr = SvPV_const(addrsv, len);
2508 TAINT_PROPER("bind");
2509 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2515 if (ckWARN(WARN_CLOSED))
2516 report_evil_fh(gv, io, PL_op->op_type);
2517 SETERRNO(EBADF,SS_IVCHAN);
2520 DIE(aTHX_ PL_no_sock_func, "bind");
2528 SV * const addrsv = POPs;
2529 GV * const gv = MUTABLE_GV(POPs);
2530 register IO * const io = GvIOn(gv);
2534 if (!io || !IoIFP(io))
2537 addr = SvPV_const(addrsv, len);
2538 TAINT_PROPER("connect");
2539 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2545 if (ckWARN(WARN_CLOSED))
2546 report_evil_fh(gv, io, PL_op->op_type);
2547 SETERRNO(EBADF,SS_IVCHAN);
2550 DIE(aTHX_ PL_no_sock_func, "connect");
2558 const int backlog = POPi;
2559 GV * const gv = MUTABLE_GV(POPs);
2560 register IO * const io = gv ? GvIOn(gv) : NULL;
2562 if (!gv || !io || !IoIFP(io))
2565 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2571 if (ckWARN(WARN_CLOSED))
2572 report_evil_fh(gv, io, PL_op->op_type);
2573 SETERRNO(EBADF,SS_IVCHAN);
2576 DIE(aTHX_ PL_no_sock_func, "listen");
2586 char namebuf[MAXPATHLEN];
2587 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2588 Sock_size_t len = sizeof (struct sockaddr_in);
2590 Sock_size_t len = sizeof namebuf;
2592 GV * const ggv = MUTABLE_GV(POPs);
2593 GV * const ngv = MUTABLE_GV(POPs);
2602 if (!gstio || !IoIFP(gstio))
2606 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2609 /* Some platforms indicate zero length when an AF_UNIX client is
2610 * not bound. Simulate a non-zero-length sockaddr structure in
2612 namebuf[0] = 0; /* sun_len */
2613 namebuf[1] = AF_UNIX; /* sun_family */
2621 do_close(ngv, FALSE);
2622 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2623 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2624 IoTYPE(nstio) = IoTYPE_SOCKET;
2625 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2626 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2627 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2628 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2631 #if defined(HAS_FCNTL) && defined(F_SETFD)
2632 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2636 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2637 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2639 #ifdef __SCO_VERSION__
2640 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2643 PUSHp(namebuf, len);
2647 if (ckWARN(WARN_CLOSED))
2648 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2649 SETERRNO(EBADF,SS_IVCHAN);
2655 DIE(aTHX_ PL_no_sock_func, "accept");
2663 const int how = POPi;
2664 GV * const gv = MUTABLE_GV(POPs);
2665 register IO * const io = GvIOn(gv);
2667 if (!io || !IoIFP(io))
2670 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2674 if (ckWARN(WARN_CLOSED))
2675 report_evil_fh(gv, io, PL_op->op_type);
2676 SETERRNO(EBADF,SS_IVCHAN);
2679 DIE(aTHX_ PL_no_sock_func, "shutdown");
2687 const int optype = PL_op->op_type;
2688 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2689 const unsigned int optname = (unsigned int) POPi;
2690 const unsigned int lvl = (unsigned int) POPi;
2691 GV * const gv = MUTABLE_GV(POPs);
2692 register IO * const io = GvIOn(gv);
2696 if (!io || !IoIFP(io))
2699 fd = PerlIO_fileno(IoIFP(io));
2703 (void)SvPOK_only(sv);
2707 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2714 #if defined(__SYMBIAN32__)
2715 # define SETSOCKOPT_OPTION_VALUE_T void *
2717 # define SETSOCKOPT_OPTION_VALUE_T const char *
2719 /* XXX TODO: We need to have a proper type (a Configure probe,
2720 * etc.) for what the C headers think of the third argument of
2721 * setsockopt(), the option_value read-only buffer: is it
2722 * a "char *", or a "void *", const or not. Some compilers
2723 * don't take kindly to e.g. assuming that "char *" implicitly
2724 * promotes to a "void *", or to explicitly promoting/demoting
2725 * consts to non/vice versa. The "const void *" is the SUS
2726 * definition, but that does not fly everywhere for the above
2728 SETSOCKOPT_OPTION_VALUE_T buf;
2732 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2736 aint = (int)SvIV(sv);
2737 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2740 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2749 if (ckWARN(WARN_CLOSED))
2750 report_evil_fh(gv, io, optype);
2751 SETERRNO(EBADF,SS_IVCHAN);
2756 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2764 const int optype = PL_op->op_type;
2765 GV * const gv = MUTABLE_GV(POPs);
2766 register IO * const io = GvIOn(gv);
2771 if (!io || !IoIFP(io))
2774 sv = sv_2mortal(newSV(257));
2775 (void)SvPOK_only(sv);
2779 fd = PerlIO_fileno(IoIFP(io));
2781 case OP_GETSOCKNAME:
2782 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2785 case OP_GETPEERNAME:
2786 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2788 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2790 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";
2791 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2792 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2793 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2794 sizeof(u_short) + sizeof(struct in_addr))) {
2801 #ifdef BOGUS_GETNAME_RETURN
2802 /* Interactive Unix, getpeername() and getsockname()
2803 does not return valid namelen */
2804 if (len == BOGUS_GETNAME_RETURN)
2805 len = sizeof(struct sockaddr);
2813 if (ckWARN(WARN_CLOSED))
2814 report_evil_fh(gv, io, optype);
2815 SETERRNO(EBADF,SS_IVCHAN);
2820 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2835 if (PL_op->op_flags & OPf_REF) {
2837 if (PL_op->op_type == OP_LSTAT) {
2838 if (gv != PL_defgv) {
2839 do_fstat_warning_check:
2840 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2841 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2842 } else if (PL_laststype != OP_LSTAT)
2843 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2847 if (gv != PL_defgv) {
2848 PL_laststype = OP_STAT;
2850 sv_setpvs(PL_statname, "");
2857 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2858 } else if (IoDIRP(io)) {
2860 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2862 PL_laststatval = -1;
2868 if (PL_laststatval < 0) {
2869 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2870 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2875 SV* const sv = POPs;
2876 if (isGV_with_GP(sv)) {
2877 gv = MUTABLE_GV(sv);
2879 } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2880 gv = MUTABLE_GV(SvRV(sv));
2881 if (PL_op->op_type == OP_LSTAT)
2882 goto do_fstat_warning_check;
2884 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2885 io = MUTABLE_IO(SvRV(sv));
2886 if (PL_op->op_type == OP_LSTAT)
2887 goto do_fstat_warning_check;
2888 goto do_fstat_have_io;
2891 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2893 PL_laststype = PL_op->op_type;
2894 if (PL_op->op_type == OP_LSTAT)
2895 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2897 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2898 if (PL_laststatval < 0) {
2899 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2900 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2906 if (gimme != G_ARRAY) {
2907 if (gimme != G_VOID)
2908 XPUSHs(boolSV(max));
2914 mPUSHi(PL_statcache.st_dev);
2915 mPUSHi(PL_statcache.st_ino);
2916 mPUSHu(PL_statcache.st_mode);
2917 mPUSHu(PL_statcache.st_nlink);
2918 #if Uid_t_size > IVSIZE
2919 mPUSHn(PL_statcache.st_uid);
2921 # if Uid_t_sign <= 0
2922 mPUSHi(PL_statcache.st_uid);
2924 mPUSHu(PL_statcache.st_uid);
2927 #if Gid_t_size > IVSIZE
2928 mPUSHn(PL_statcache.st_gid);
2930 # if Gid_t_sign <= 0
2931 mPUSHi(PL_statcache.st_gid);
2933 mPUSHu(PL_statcache.st_gid);
2936 #ifdef USE_STAT_RDEV
2937 mPUSHi(PL_statcache.st_rdev);
2939 PUSHs(newSVpvs_flags("", SVs_TEMP));
2941 #if Off_t_size > IVSIZE
2942 mPUSHn(PL_statcache.st_size);
2944 mPUSHi(PL_statcache.st_size);
2947 mPUSHn(PL_statcache.st_atime);
2948 mPUSHn(PL_statcache.st_mtime);
2949 mPUSHn(PL_statcache.st_ctime);
2951 mPUSHi(PL_statcache.st_atime);
2952 mPUSHi(PL_statcache.st_mtime);
2953 mPUSHi(PL_statcache.st_ctime);
2955 #ifdef USE_STAT_BLOCKS
2956 mPUSHu(PL_statcache.st_blksize);
2957 mPUSHu(PL_statcache.st_blocks);
2959 PUSHs(newSVpvs_flags("", SVs_TEMP));
2960 PUSHs(newSVpvs_flags("", SVs_TEMP));
2966 #define tryAMAGICftest_MG(chr) STMT_START { \
2967 if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
2968 && S_try_amagic_ftest(aTHX_ chr)) \
2973 S_try_amagic_ftest(pTHX_ char chr) {
2976 SV* const arg = TOPs;
2981 if ((PL_op->op_flags & OPf_KIDS)
2984 const char tmpchr = chr;
2986 SV * const tmpsv = amagic_call(arg,
2987 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2988 ftest_amg, AMGf_unary);
2995 next = PL_op->op_next;
2996 if (next->op_type >= OP_FTRREAD &&
2997 next->op_type <= OP_FTBINARY &&
2998 next->op_private & OPpFT_STACKED
3001 /* leave the object alone */
3013 /* This macro is used by the stacked filetest operators :
3014 * if the previous filetest failed, short-circuit and pass its value.
3015 * Else, discard it from the stack and continue. --rgs
3017 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
3018 if (!SvTRUE(TOPs)) { RETURN; } \
3019 else { (void)POPs; PUTBACK; } \
3026 /* Not const, because things tweak this below. Not bool, because there's
3027 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
3028 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3029 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3030 /* Giving some sort of initial value silences compilers. */
3032 int access_mode = R_OK;
3034 int access_mode = 0;
3037 /* access_mode is never used, but leaving use_access in makes the
3038 conditional compiling below much clearer. */
3041 int stat_mode = S_IRUSR;
3043 bool effective = FALSE;
3047 switch (PL_op->op_type) {
3048 case OP_FTRREAD: opchar = 'R'; break;
3049 case OP_FTRWRITE: opchar = 'W'; break;
3050 case OP_FTREXEC: opchar = 'X'; break;
3051 case OP_FTEREAD: opchar = 'r'; break;
3052 case OP_FTEWRITE: opchar = 'w'; break;
3053 case OP_FTEEXEC: opchar = 'x'; break;
3055 tryAMAGICftest_MG(opchar);
3057 STACKED_FTEST_CHECK;
3059 switch (PL_op->op_type) {
3061 #if !(defined(HAS_ACCESS) && defined(R_OK))
3067 #if defined(HAS_ACCESS) && defined(W_OK)
3072 stat_mode = S_IWUSR;
3076 #if defined(HAS_ACCESS) && defined(X_OK)
3081 stat_mode = S_IXUSR;
3085 #ifdef PERL_EFF_ACCESS
3088 stat_mode = S_IWUSR;
3092 #ifndef PERL_EFF_ACCESS
3099 #ifdef PERL_EFF_ACCESS
3104 stat_mode = S_IXUSR;
3110 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3111 const char *name = POPpx;
3113 # ifdef PERL_EFF_ACCESS
3114 result = PERL_EFF_ACCESS(name, access_mode);
3116 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3122 result = access(name, access_mode);
3124 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3135 result = my_stat_flags(0);
3139 if (cando(stat_mode, effective, &PL_statcache))
3148 const int op_type = PL_op->op_type;
3153 case OP_FTIS: opchar = 'e'; break;
3154 case OP_FTSIZE: opchar = 's'; break;
3155 case OP_FTMTIME: opchar = 'M'; break;
3156 case OP_FTCTIME: opchar = 'C'; break;
3157 case OP_FTATIME: opchar = 'A'; break;
3159 tryAMAGICftest_MG(opchar);
3161 STACKED_FTEST_CHECK;
3163 result = my_stat_flags(0);
3167 if (op_type == OP_FTIS)
3170 /* You can't dTARGET inside OP_FTIS, because you'll get
3171 "panic: pad_sv po" - the op is not flagged to have a target. */
3175 #if Off_t_size > IVSIZE
3176 PUSHn(PL_statcache.st_size);
3178 PUSHi(PL_statcache.st_size);
3182 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3185 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3188 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3202 switch (PL_op->op_type) {
3203 case OP_FTROWNED: opchar = 'O'; break;
3204 case OP_FTEOWNED: opchar = 'o'; break;
3205 case OP_FTZERO: opchar = 'z'; break;
3206 case OP_FTSOCK: opchar = 'S'; break;
3207 case OP_FTCHR: opchar = 'c'; break;
3208 case OP_FTBLK: opchar = 'b'; break;
3209 case OP_FTFILE: opchar = 'f'; break;
3210 case OP_FTDIR: opchar = 'd'; break;
3211 case OP_FTPIPE: opchar = 'p'; break;
3212 case OP_FTSUID: opchar = 'u'; break;
3213 case OP_FTSGID: opchar = 'g'; break;
3214 case OP_FTSVTX: opchar = 'k'; break;
3216 tryAMAGICftest_MG(opchar);
3218 STACKED_FTEST_CHECK;
3220 /* I believe that all these three are likely to be defined on most every
3221 system these days. */
3223 if(PL_op->op_type == OP_FTSUID) {
3224 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3230 if(PL_op->op_type == OP_FTSGID) {
3231 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3237 if(PL_op->op_type == OP_FTSVTX) {
3238 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3244 result = my_stat_flags(0);
3248 switch (PL_op->op_type) {
3250 if (PL_statcache.st_uid == PL_uid)
3254 if (PL_statcache.st_uid == PL_euid)
3258 if (PL_statcache.st_size == 0)
3262 if (S_ISSOCK(PL_statcache.st_mode))
3266 if (S_ISCHR(PL_statcache.st_mode))
3270 if (S_ISBLK(PL_statcache.st_mode))
3274 if (S_ISREG(PL_statcache.st_mode))
3278 if (S_ISDIR(PL_statcache.st_mode))
3282 if (S_ISFIFO(PL_statcache.st_mode))
3287 if (PL_statcache.st_mode & S_ISUID)
3293 if (PL_statcache.st_mode & S_ISGID)
3299 if (PL_statcache.st_mode & S_ISVTX)
3313 tryAMAGICftest_MG('l');
3314 result = my_lstat_flags(0);
3319 if (S_ISLNK(PL_statcache.st_mode))
3334 tryAMAGICftest_MG('t');
3336 STACKED_FTEST_CHECK;
3338 if (PL_op->op_flags & OPf_REF)
3340 else if (isGV_with_GP(TOPs))
3341 gv = MUTABLE_GV(POPs);
3342 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3343 gv = MUTABLE_GV(SvRV(POPs));
3346 name = SvPV_nomg(tmpsv, namelen);
3347 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3350 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3351 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3352 else if (tmpsv && SvOK(tmpsv)) {
3360 if (PerlLIO_isatty(fd))
3365 #if defined(atarist) /* this will work with atariST. Configure will
3366 make guesses for other systems. */
3367 # define FILE_base(f) ((f)->_base)
3368 # define FILE_ptr(f) ((f)->_ptr)
3369 # define FILE_cnt(f) ((f)->_cnt)
3370 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3381 register STDCHAR *s;
3387 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3389 STACKED_FTEST_CHECK;
3391 if (PL_op->op_flags & OPf_REF)
3393 else if (isGV_with_GP(TOPs))
3394 gv = MUTABLE_GV(POPs);
3395 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3396 gv = MUTABLE_GV(SvRV(POPs));
3402 if (gv == PL_defgv) {
3404 io = GvIO(PL_statgv);
3407 goto really_filename;
3412 PL_laststatval = -1;
3413 sv_setpvs(PL_statname, "");
3414 io = GvIO(PL_statgv);
3416 if (io && IoIFP(io)) {
3417 if (! PerlIO_has_base(IoIFP(io)))
3418 DIE(aTHX_ "-T and -B not implemented on filehandles");
3419 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3420 if (PL_laststatval < 0)
3422 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3423 if (PL_op->op_type == OP_FTTEXT)
3428 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3429 i = PerlIO_getc(IoIFP(io));
3431 (void)PerlIO_ungetc(IoIFP(io),i);
3433 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3435 len = PerlIO_get_bufsiz(IoIFP(io));
3436 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3437 /* sfio can have large buffers - limit to 512 */
3442 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3444 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3446 SETERRNO(EBADF,RMS_IFI);
3454 PL_laststype = OP_STAT;
3455 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3456 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3457 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3459 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3462 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3463 if (PL_laststatval < 0) {
3464 (void)PerlIO_close(fp);
3467 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3468 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3469 (void)PerlIO_close(fp);
3471 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3472 RETPUSHNO; /* special case NFS directories */
3473 RETPUSHYES; /* null file is anything */
3478 /* now scan s to look for textiness */
3479 /* XXX ASCII dependent code */
3481 #if defined(DOSISH) || defined(USEMYBINMODE)
3482 /* ignore trailing ^Z on short files */
3483 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3487 for (i = 0; i < len; i++, s++) {
3488 if (!*s) { /* null never allowed in text */
3493 else if (!(isPRINT(*s) || isSPACE(*s)))
3496 else if (*s & 128) {
3498 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3501 /* utf8 characters don't count as odd */
3502 if (UTF8_IS_START(*s)) {
3503 int ulen = UTF8SKIP(s);
3504 if (ulen < len - i) {
3506 for (j = 1; j < ulen; j++) {
3507 if (!UTF8_IS_CONTINUATION(s[j]))
3510 --ulen; /* loop does extra increment */
3520 *s != '\n' && *s != '\r' && *s != '\b' &&
3521 *s != '\t' && *s != '\f' && *s != 27)
3526 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3537 const char *tmps = NULL;
3541 SV * const sv = POPs;
3542 if (PL_op->op_flags & OPf_SPECIAL) {
3543 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3545 else if (isGV_with_GP(sv)) {
3546 gv = MUTABLE_GV(sv);
3548 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
3549 gv = MUTABLE_GV(SvRV(sv));
3552 tmps = SvPV_nolen_const(sv);
3556 if( !gv && (!tmps || !*tmps) ) {
3557 HV * const table = GvHVn(PL_envgv);
3560 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3561 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3563 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3568 deprecate("chdir('') or chdir(undef) as chdir()");
3569 tmps = SvPV_nolen_const(*svp);
3573 TAINT_PROPER("chdir");
3578 TAINT_PROPER("chdir");
3581 IO* const io = GvIO(gv);
3584 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3585 } else if (IoIFP(io)) {
3586 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3589 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3590 report_evil_fh(gv, io, PL_op->op_type);
3591 SETERRNO(EBADF, RMS_IFI);
3596 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3597 report_evil_fh(gv, io, PL_op->op_type);
3598 SETERRNO(EBADF,RMS_IFI);
3602 DIE(aTHX_ PL_no_func, "fchdir");
3606 PUSHi( PerlDir_chdir(tmps) >= 0 );
3608 /* Clear the DEFAULT element of ENV so we'll get the new value
3610 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3617 dVAR; dSP; dMARK; dTARGET;
3618 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3629 char * const tmps = POPpx;
3630 TAINT_PROPER("chroot");
3631 PUSHi( chroot(tmps) >= 0 );
3634 DIE(aTHX_ PL_no_func, "chroot");
3642 const char * const tmps2 = POPpconstx;
3643 const char * const tmps = SvPV_nolen_const(TOPs);
3644 TAINT_PROPER("rename");
3646 anum = PerlLIO_rename(tmps, tmps2);
3648 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3649 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3652 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3653 (void)UNLINK(tmps2);
3654 if (!(anum = link(tmps, tmps2)))
3655 anum = UNLINK(tmps);
3663 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3667 const int op_type = PL_op->op_type;
3671 if (op_type == OP_LINK)
3672 DIE(aTHX_ PL_no_func, "link");
3674 # ifndef HAS_SYMLINK
3675 if (op_type == OP_SYMLINK)
3676 DIE(aTHX_ PL_no_func, "symlink");
3680 const char * const tmps2 = POPpconstx;
3681 const char * const tmps = SvPV_nolen_const(TOPs);
3682 TAINT_PROPER(PL_op_desc[op_type]);
3684 # if defined(HAS_LINK)
3685 # if defined(HAS_SYMLINK)
3686 /* Both present - need to choose which. */
3687 (op_type == OP_LINK) ?
3688 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3690 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3691 PerlLIO_link(tmps, tmps2);
3694 # if defined(HAS_SYMLINK)
3695 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3696 symlink(tmps, tmps2);
3701 SETi( result >= 0 );
3708 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3719 char buf[MAXPATHLEN];
3722 #ifndef INCOMPLETE_TAINTS
3726 len = readlink(tmps, buf, sizeof(buf) - 1);
3733 RETSETUNDEF; /* just pretend it's a normal file */
3737 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3739 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3741 char * const save_filename = filename;
3746 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3748 PERL_ARGS_ASSERT_DOONELINER;
3750 Newx(cmdline, size, char);
3751 my_strlcpy(cmdline, cmd, size);
3752 my_strlcat(cmdline, " ", size);
3753 for (s = cmdline + strlen(cmdline); *filename; ) {
3757 if (s - cmdline < size)
3758 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3759 myfp = PerlProc_popen(cmdline, "r");
3763 SV * const tmpsv = sv_newmortal();
3764 /* Need to save/restore 'PL_rs' ?? */
3765 s = sv_gets(tmpsv, myfp, 0);
3766 (void)PerlProc_pclose(myfp);
3770 #ifdef HAS_SYS_ERRLIST
3775 /* you don't see this */
3776 const char * const errmsg =
3777 #ifdef HAS_SYS_ERRLIST
3785 if (instr(s, errmsg)) {
3792 #define EACCES EPERM
3794 if (instr(s, "cannot make"))
3795 SETERRNO(EEXIST,RMS_FEX);
3796 else if (instr(s, "existing file"))
3797 SETERRNO(EEXIST,RMS_FEX);
3798 else if (instr(s, "ile exists"))
3799 SETERRNO(EEXIST,RMS_FEX);
3800 else if (instr(s, "non-exist"))
3801 SETERRNO(ENOENT,RMS_FNF);
3802 else if (instr(s, "does not exist"))
3803 SETERRNO(ENOENT,RMS_FNF);
3804 else if (instr(s, "not empty"))
3805 SETERRNO(EBUSY,SS_DEVOFFLINE);
3806 else if (instr(s, "cannot access"))
3807 SETERRNO(EACCES,RMS_PRV);
3809 SETERRNO(EPERM,RMS_PRV);
3812 else { /* some mkdirs return no failure indication */
3813 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3814 if (PL_op->op_type == OP_RMDIR)
3819 SETERRNO(EACCES,RMS_PRV); /* a guess */
3828 /* This macro removes trailing slashes from a directory name.
3829 * Different operating and file systems take differently to
3830 * trailing slashes. According to POSIX 1003.1 1996 Edition
3831 * any number of trailing slashes should be allowed.
3832 * Thusly we snip them away so that even non-conforming
3833 * systems are happy.
3834 * We should probably do this "filtering" for all
3835 * the functions that expect (potentially) directory names:
3836 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3837 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3839 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3840 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3843 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3844 (tmps) = savepvn((tmps), (len)); \
3854 const int mode = (MAXARG > 1) ? POPi : 0777;
3856 TRIMSLASHES(tmps,len,copy);
3858 TAINT_PROPER("mkdir");
3860 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3864 SETi( dooneliner("mkdir", tmps) );
3865 oldumask = PerlLIO_umask(0);
3866 PerlLIO_umask(oldumask);
3867 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3882 TRIMSLASHES(tmps,len,copy);
3883 TAINT_PROPER("rmdir");
3885 SETi( PerlDir_rmdir(tmps) >= 0 );
3887 SETi( dooneliner("rmdir", tmps) );
3894 /* Directory calls. */
3898 #if defined(Direntry_t) && defined(HAS_READDIR)
3900 const char * const dirname = POPpconstx;
3901 GV * const gv = MUTABLE_GV(POPs);
3902 register IO * const io = GvIOn(gv);
3907 if ((IoIFP(io) || IoOFP(io)))
3908 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3909 "Opening filehandle %s also as a directory",
3912 PerlDir_close(IoDIRP(io));
3913 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3919 SETERRNO(EBADF,RMS_DIR);
3922 DIE(aTHX_ PL_no_dir_func, "opendir");
3928 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3929 DIE(aTHX_ PL_no_dir_func, "readdir");
3931 #if !defined(I_DIRENT) && !defined(VMS)
3932 Direntry_t *readdir (DIR *);
3938 const I32 gimme = GIMME;
3939 GV * const gv = MUTABLE_GV(POPs);
3940 register const Direntry_t *dp;
3941 register IO * const io = GvIOn(gv);
3943 if (!io || !IoDIRP(io)) {
3944 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3945 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3950 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3954 sv = newSVpvn(dp->d_name, dp->d_namlen);
3956 sv = newSVpv(dp->d_name, 0);
3958 #ifndef INCOMPLETE_TAINTS
3959 if (!(IoFLAGS(io) & IOf_UNTAINT))
3963 } while (gimme == G_ARRAY);
3965 if (!dp && gimme != G_ARRAY)
3972 SETERRNO(EBADF,RMS_ISI);
3973 if (GIMME == G_ARRAY)
3982 #if defined(HAS_TELLDIR) || defined(telldir)
3984 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3985 /* XXX netbsd still seemed to.
3986 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3987 --JHI 1999-Feb-02 */
3988 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3989 long telldir (DIR *);
3991 GV * const gv = MUTABLE_GV(POPs);
3992 register IO * const io = GvIOn(gv);
3994 if (!io || !IoDIRP(io)) {
3995 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3996 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
4000 PUSHi( PerlDir_tell(IoDIRP(io)) );
4004 SETERRNO(EBADF,RMS_ISI);
4007 DIE(aTHX_ PL_no_dir_func, "telldir");
4013 #if defined(HAS_SEEKDIR) || defined(seekdir)
4015 const long along = POPl;
4016 GV * const gv = MUTABLE_GV(POPs);
4017 register IO * const io = GvIOn(gv);
4019 if (!io || !IoDIRP(io)) {
4020 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4021 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
4024 (void)PerlDir_seek(IoDIRP(io), along);
4029 SETERRNO(EBADF,RMS_ISI);
4032 DIE(aTHX_ PL_no_dir_func, "seekdir");
4038 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4040 GV * const gv = MUTABLE_GV(POPs);
4041 register IO * const io = GvIOn(gv);
4043 if (!io || !IoDIRP(io)) {
4044 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4045 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
4048 (void)PerlDir_rewind(IoDIRP(io));
4052 SETERRNO(EBADF,RMS_ISI);
4055 DIE(aTHX_ PL_no_dir_func, "rewinddir");
4061 #if defined(Direntry_t) && defined(HAS_READDIR)
4063 GV * const gv = MUTABLE_GV(POPs);
4064 register IO * const io = GvIOn(gv);
4066 if (!io || !IoDIRP(io)) {
4067 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4068 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
4071 #ifdef VOID_CLOSEDIR
4072 PerlDir_close(IoDIRP(io));
4074 if (PerlDir_close(IoDIRP(io)) < 0) {
4075 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4084 SETERRNO(EBADF,RMS_IFI);
4087 DIE(aTHX_ PL_no_dir_func, "closedir");
4091 /* Process control. */
4100 PERL_FLUSHALL_FOR_CHILD;
4101 childpid = PerlProc_fork();
4105 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
4107 SvREADONLY_off(GvSV(tmpgv));
4108 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4109 SvREADONLY_on(GvSV(tmpgv));
4111 #ifdef THREADS_HAVE_PIDS
4112 PL_ppid = (IV)getppid();
4114 #ifdef PERL_USES_PL_PIDSTATUS
4115 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4121 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4126 PERL_FLUSHALL_FOR_CHILD;
4127 childpid = PerlProc_fork();
4133 DIE(aTHX_ PL_no_func, "fork");
4140 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4145 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4146 childpid = wait4pid(-1, &argflags, 0);
4148 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4153 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4154 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4155 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4157 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4162 DIE(aTHX_ PL_no_func, "wait");
4168 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4170 const int optype = POPi;
4171 const Pid_t pid = TOPi;
4175 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4176 result = wait4pid(pid, &argflags, optype);
4178 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4183 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4184 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4185 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4187 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4192 DIE(aTHX_ PL_no_func, "waitpid");
4198 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4199 #if defined(__LIBCATAMOUNT__)
4200 PL_statusvalue = -1;
4209 while (++MARK <= SP) {
4210 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4215 TAINT_PROPER("system");
4217 PERL_FLUSHALL_FOR_CHILD;
4218 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4224 if (PerlProc_pipe(pp) >= 0)
4226 while ((childpid = PerlProc_fork()) == -1) {
4227 if (errno != EAGAIN) {
4232 PerlLIO_close(pp[0]);
4233 PerlLIO_close(pp[1]);
4240 Sigsave_t ihand,qhand; /* place to save signals during system() */
4244 PerlLIO_close(pp[1]);
4246 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4247 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4250 result = wait4pid(childpid, &status, 0);
4251 } while (result == -1 && errno == EINTR);
4253 (void)rsignal_restore(SIGINT, &ihand);
4254 (void)rsignal_restore(SIGQUIT, &qhand);
4256 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4257 do_execfree(); /* free any memory child malloced on fork */
4264 while (n < sizeof(int)) {
4265 n1 = PerlLIO_read(pp[0],
4266 (void*)(((char*)&errkid)+n),
4272 PerlLIO_close(pp[0]);
4273 if (n) { /* Error */
4274 if (n != sizeof(int))
4275 DIE(aTHX_ "panic: kid popen errno read");
4276 errno = errkid; /* Propagate errno from kid */
4277 STATUS_NATIVE_CHILD_SET(-1);
4280 XPUSHi(STATUS_CURRENT);
4284 PerlLIO_close(pp[0]);
4285 #if defined(HAS_FCNTL) && defined(F_SETFD)
4286 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4289 if (PL_op->op_flags & OPf_STACKED) {
4290 SV * const really = *++MARK;
4291 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4293 else if (SP - MARK != 1)
4294 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4296 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4300 #else /* ! FORK or VMS or OS/2 */
4303 if (PL_op->op_flags & OPf_STACKED) {
4304 SV * const really = *++MARK;
4305 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4306 value = (I32)do_aspawn(really, MARK, SP);
4308 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4311 else if (SP - MARK != 1) {
4312 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4313 value = (I32)do_aspawn(NULL, MARK, SP);
4315 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4319 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4321 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4323 STATUS_NATIVE_CHILD_SET(value);
4326 XPUSHi(result ? value : STATUS_CURRENT);
4327 #endif /* !FORK or VMS or OS/2 */
4334 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4339 while (++MARK <= SP) {
4340 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4345 TAINT_PROPER("exec");
4347 PERL_FLUSHALL_FOR_CHILD;
4348 if (PL_op->op_flags & OPf_STACKED) {
4349 SV * const really = *++MARK;
4350 value = (I32)do_aexec(really, MARK, SP);
4352 else if (SP - MARK != 1)
4354 value = (I32)vms_do_aexec(NULL, MARK, SP);
4358 (void ) do_aspawn(NULL, MARK, SP);
4362 value = (I32)do_aexec(NULL, MARK, SP);
4367 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4370 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4373 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4387 # ifdef THREADS_HAVE_PIDS
4388 if (PL_ppid != 1 && getppid() == 1)
4389 /* maybe the parent process has died. Refresh ppid cache */
4393 XPUSHi( getppid() );
4397 DIE(aTHX_ PL_no_func, "getppid");
4406 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4409 pgrp = (I32)BSD_GETPGRP(pid);
4411 if (pid != 0 && pid != PerlProc_getpid())
4412 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4418 DIE(aTHX_ PL_no_func, "getpgrp()");
4438 TAINT_PROPER("setpgrp");
4440 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4442 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4443 || (pid != 0 && pid != PerlProc_getpid()))
4445 DIE(aTHX_ "setpgrp can't take arguments");
4447 SETi( setpgrp() >= 0 );
4448 #endif /* USE_BSDPGRP */
4451 DIE(aTHX_ PL_no_func, "setpgrp()");
4456 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4458 # define PRIORITY_WHICH_T(which) which
4463 #ifdef HAS_GETPRIORITY
4465 const int who = POPi;
4466 const int which = TOPi;
4467 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4470 DIE(aTHX_ PL_no_func, "getpriority()");
4476 #ifdef HAS_SETPRIORITY
4478 const int niceval = POPi;
4479 const int who = POPi;
4480 const int which = TOPi;
4481 TAINT_PROPER("setpriority");
4482 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4485 DIE(aTHX_ PL_no_func, "setpriority()");
4489 #undef PRIORITY_WHICH_T
4497 XPUSHn( time(NULL) );
4499 XPUSHi( time(NULL) );
4511 (void)PerlProc_times(&PL_timesbuf);
4513 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4514 /* struct tms, though same data */
4518 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4519 if (GIMME == G_ARRAY) {
4520 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4521 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4522 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4530 if (GIMME == G_ARRAY) {
4537 DIE(aTHX_ "times not implemented");
4539 #endif /* HAS_TIMES */
4542 /* The 32 bit int year limits the times we can represent to these
4543 boundaries with a few days wiggle room to account for time zone
4546 /* Sat Jan 3 00:00:00 -2147481748 */
4547 #define TIME_LOWER_BOUND -67768100567755200.0
4548 /* Sun Dec 29 12:00:00 2147483647 */
4549 #define TIME_UPPER_BOUND 67767976233316800.0
4558 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4559 static const char * const dayname[] =
4560 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4561 static const char * const monname[] =
4562 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4563 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4568 when = (Time64_T)now;
4571 NV input = Perl_floor(POPn);
4572 when = (Time64_T)input;
4573 if (when != input) {
4574 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4575 "%s(%.0" NVff ") too large", opname, input);
4579 if ( TIME_LOWER_BOUND > when ) {
4580 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4581 "%s(%.0" NVff ") too small", opname, when);
4584 else if( when > TIME_UPPER_BOUND ) {
4585 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4586 "%s(%.0" NVff ") too large", opname, when);
4590 if (PL_op->op_type == OP_LOCALTIME)
4591 err = S_localtime64_r(&when, &tmbuf);
4593 err = S_gmtime64_r(&when, &tmbuf);
4597 /* XXX %lld broken for quads */
4598 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4599 "%s(%.0" NVff ") failed", opname, when);
4602 if (GIMME != G_ARRAY) { /* scalar context */
4604 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4605 double year = (double)tmbuf.tm_year + 1900;
4612 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4613 dayname[tmbuf.tm_wday],
4614 monname[tmbuf.tm_mon],
4622 else { /* list context */
4628 mPUSHi(tmbuf.tm_sec);
4629 mPUSHi(tmbuf.tm_min);
4630 mPUSHi(tmbuf.tm_hour);
4631 mPUSHi(tmbuf.tm_mday);
4632 mPUSHi(tmbuf.tm_mon);
4633 mPUSHn(tmbuf.tm_year);
4634 mPUSHi(tmbuf.tm_wday);
4635 mPUSHi(tmbuf.tm_yday);
4636 mPUSHi(tmbuf.tm_isdst);
4647 anum = alarm((unsigned int)anum);
4653 DIE(aTHX_ PL_no_func, "alarm");
4664 (void)time(&lasttime);
4669 PerlProc_sleep((unsigned int)duration);
4672 XPUSHi(when - lasttime);
4676 /* Shared memory. */
4677 /* Merged with some message passing. */
4681 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4682 dVAR; dSP; dMARK; dTARGET;
4683 const int op_type = PL_op->op_type;
4688 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4691 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4694 value = (I32)(do_semop(MARK, SP) >= 0);
4697 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4713 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4714 dVAR; dSP; dMARK; dTARGET;
4715 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4722 DIE(aTHX_ "System V IPC is not implemented on this machine");
4728 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4729 dVAR; dSP; dMARK; dTARGET;
4730 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4738 PUSHp(zero_but_true, ZBTLEN);
4746 /* I can't const this further without getting warnings about the types of
4747 various arrays passed in from structures. */
4749 S_space_join_names_mortal(pTHX_ char *const *array)
4753 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4755 if (array && *array) {
4756 target = newSVpvs_flags("", SVs_TEMP);
4758 sv_catpv(target, *array);
4761 sv_catpvs(target, " ");
4764 target = sv_mortalcopy(&PL_sv_no);
4769 /* Get system info. */
4773 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4775 I32 which = PL_op->op_type;
4776 register char **elem;
4778 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4779 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4780 struct hostent *gethostbyname(Netdb_name_t);
4781 struct hostent *gethostent(void);
4783 struct hostent *hent = NULL;
4787 if (which == OP_GHBYNAME) {
4788 #ifdef HAS_GETHOSTBYNAME
4789 const char* const name = POPpbytex;
4790 hent = PerlSock_gethostbyname(name);
4792 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4795 else if (which == OP_GHBYADDR) {
4796 #ifdef HAS_GETHOSTBYADDR
4797 const int addrtype = POPi;
4798 SV * const addrsv = POPs;
4800 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4802 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4804 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4808 #ifdef HAS_GETHOSTENT
4809 hent = PerlSock_gethostent();
4811 DIE(aTHX_ PL_no_sock_func, "gethostent");
4814 #ifdef HOST_NOT_FOUND
4816 #ifdef USE_REENTRANT_API
4817 # ifdef USE_GETHOSTENT_ERRNO
4818 h_errno = PL_reentrant_buffer->_gethostent_errno;
4821 STATUS_UNIX_SET(h_errno);
4825 if (GIMME != G_ARRAY) {
4826 PUSHs(sv = sv_newmortal());
4828 if (which == OP_GHBYNAME) {
4830 sv_setpvn(sv, hent->h_addr, hent->h_length);
4833 sv_setpv(sv, (char*)hent->h_name);
4839 mPUSHs(newSVpv((char*)hent->h_name, 0));
4840 PUSHs(space_join_names_mortal(hent->h_aliases));
4841 mPUSHi(hent->h_addrtype);
4842 len = hent->h_length;
4845 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4846 mXPUSHp(*elem, len);
4850 mPUSHp(hent->h_addr, len);
4852 PUSHs(sv_mortalcopy(&PL_sv_no));
4857 DIE(aTHX_ PL_no_sock_func, "gethostent");
4863 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4865 I32 which = PL_op->op_type;
4867 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4868 struct netent *getnetbyaddr(Netdb_net_t, int);
4869 struct netent *getnetbyname(Netdb_name_t);
4870 struct netent *getnetent(void);
4872 struct netent *nent;
4874 if (which == OP_GNBYNAME){
4875 #ifdef HAS_GETNETBYNAME
4876 const char * const name = POPpbytex;
4877 nent = PerlSock_getnetbyname(name);
4879 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4882 else if (which == OP_GNBYADDR) {
4883 #ifdef HAS_GETNETBYADDR
4884 const int addrtype = POPi;
4885 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4886 nent = PerlSock_getnetbyaddr(addr, addrtype);
4888 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4892 #ifdef HAS_GETNETENT
4893 nent = PerlSock_getnetent();
4895 DIE(aTHX_ PL_no_sock_func, "getnetent");
4898 #ifdef HOST_NOT_FOUND
4900 #ifdef USE_REENTRANT_API
4901 # ifdef USE_GETNETENT_ERRNO
4902 h_errno = PL_reentrant_buffer->_getnetent_errno;
4905 STATUS_UNIX_SET(h_errno);
4910 if (GIMME != G_ARRAY) {
4911 PUSHs(sv = sv_newmortal());
4913 if (which == OP_GNBYNAME)
4914 sv_setiv(sv, (IV)nent->n_net);
4916 sv_setpv(sv, nent->n_name);
4922 mPUSHs(newSVpv(nent->n_name, 0));
4923 PUSHs(space_join_names_mortal(nent->n_aliases));
4924 mPUSHi(nent->n_addrtype);
4925 mPUSHi(nent->n_net);
4930 DIE(aTHX_ PL_no_sock_func, "getnetent");
4936 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4938 I32 which = PL_op->op_type;
4940 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4941 struct protoent *getprotobyname(Netdb_name_t);
4942 struct protoent *getprotobynumber(int);
4943 struct protoent *getprotoent(void);
4945 struct protoent *pent;
4947 if (which == OP_GPBYNAME) {
4948 #ifdef HAS_GETPROTOBYNAME
4949 const char* const name = POPpbytex;
4950 pent = PerlSock_getprotobyname(name);
4952 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4955 else if (which == OP_GPBYNUMBER) {
4956 #ifdef HAS_GETPROTOBYNUMBER
4957 const int number = POPi;
4958 pent = PerlSock_getprotobynumber(number);
4960 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4964 #ifdef HAS_GETPROTOENT
4965 pent = PerlSock_getprotoent();
4967 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4971 if (GIMME != G_ARRAY) {
4972 PUSHs(sv = sv_newmortal());
4974 if (which == OP_GPBYNAME)
4975 sv_setiv(sv, (IV)pent->p_proto);
4977 sv_setpv(sv, pent->p_name);
4983 mPUSHs(newSVpv(pent->p_name, 0));
4984 PUSHs(space_join_names_mortal(pent->p_aliases));
4985 mPUSHi(pent->p_proto);
4990 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4996 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4998 I32 which = PL_op->op_type;
5000 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
5001 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
5002 struct servent *getservbyport(int, Netdb_name_t);
5003 struct servent *getservent(void);
5005 struct servent *sent;
5007 if (which == OP_GSBYNAME) {
5008 #ifdef HAS_GETSERVBYNAME
5009 const char * const proto = POPpbytex;
5010 const char * const name = POPpbytex;
5011 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5013 DIE(aTHX_ PL_no_sock_func, "getservbyname");
5016 else if (which == OP_GSBYPORT) {
5017 #ifdef HAS_GETSERVBYPORT
5018 const char * const proto = POPpbytex;
5019 unsigned short port = (unsigned short)POPu;
5021 port = PerlSock_htons(port);
5023 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5025 DIE(aTHX_ PL_no_sock_func, "getservbyport");
5029 #ifdef HAS_GETSERVENT
5030 sent = PerlSock_getservent();
5032 DIE(aTHX_ PL_no_sock_func, "getservent");
5036 if (GIMME != G_ARRAY) {
5037 PUSHs(sv = sv_newmortal());
5039 if (which == OP_GSBYNAME) {
5041 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5043 sv_setiv(sv, (IV)(sent->s_port));
5047 sv_setpv(sv, sent->s_name);
5053 mPUSHs(newSVpv(sent->s_name, 0));
5054 PUSHs(space_join_names_mortal(sent->s_aliases));
5056 mPUSHi(PerlSock_ntohs(sent->s_port));
5058 mPUSHi(sent->s_port);
5060 mPUSHs(newSVpv(sent->s_proto, 0));
5065 DIE(aTHX_ PL_no_sock_func, "getservent");
5071 #ifdef HAS_SETHOSTENT
5073 PerlSock_sethostent(TOPi);
5076 DIE(aTHX_ PL_no_sock_func, "sethostent");
5082 #ifdef HAS_SETNETENT
5084 (void)PerlSock_setnetent(TOPi);
5087 DIE(aTHX_ PL_no_sock_func, "setnetent");
5093 #ifdef HAS_SETPROTOENT
5095 (void)PerlSock_setprotoent(TOPi);
5098 DIE(aTHX_ PL_no_sock_func, "setprotoent");
5104 #ifdef HAS_SETSERVENT
5106 (void)PerlSock_setservent(TOPi);
5109 DIE(aTHX_ PL_no_sock_func, "setservent");
5115 #ifdef HAS_ENDHOSTENT
5117 PerlSock_endhostent();
5121 DIE(aTHX_ PL_no_sock_func, "endhostent");
5127 #ifdef HAS_ENDNETENT
5129 PerlSock_endnetent();
5133 DIE(aTHX_ PL_no_sock_func, "endnetent");
5139 #ifdef HAS_ENDPROTOENT
5141 PerlSock_endprotoent();
5145 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5151 #ifdef HAS_ENDSERVENT
5153 PerlSock_endservent();
5157 DIE(aTHX_ PL_no_sock_func, "endservent");
5165 I32 which = PL_op->op_type;
5167 struct passwd *pwent = NULL;
5169 * We currently support only the SysV getsp* shadow password interface.
5170 * The interface is declared in <shadow.h> and often one needs to link
5171 * with -lsecurity or some such.
5172 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5175 * AIX getpwnam() is clever enough to return the encrypted password
5176 * only if the caller (euid?) is root.
5178 * There are at least three other shadow password APIs. Many platforms
5179 * seem to contain more than one interface for accessing the shadow
5180 * password databases, possibly for compatibility reasons.
5181 * The getsp*() is by far he simplest one, the other two interfaces
5182 * are much more complicated, but also very similar to each other.
5187 * struct pr_passwd *getprpw*();
5188 * The password is in
5189 * char getprpw*(...).ufld.fd_encrypt[]
5190 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5195 * struct es_passwd *getespw*();
5196 * The password is in
5197 * char *(getespw*(...).ufld.fd_encrypt)
5198 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5201 * struct userpw *getuserpw();
5202 * The password is in
5203 * char *(getuserpw(...)).spw_upw_passwd
5204 * (but the de facto standard getpwnam() should work okay)
5206 * Mention I_PROT here so that Configure probes for it.
5208 * In HP-UX for getprpw*() the manual page claims that one should include
5209 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5210 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5211 * and pp_sys.c already includes <shadow.h> if there is such.
5213 * Note that <sys/security.h> is already probed for, but currently
5214 * it is only included in special cases.
5216 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5217 * be preferred interface, even though also the getprpw*() interface
5218 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5219 * One also needs to call set_auth_parameters() in main() before
5220 * doing anything else, whether one is using getespw*() or getprpw*().
5222 * Note that accessing the shadow databases can be magnitudes
5223 * slower than accessing the standard databases.
5228 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5229 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5230 * the pw_comment is left uninitialized. */
5231 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5237 const char* const name = POPpbytex;
5238 pwent = getpwnam(name);
5244 pwent = getpwuid(uid);
5248 # ifdef HAS_GETPWENT
5250 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5251 if (pwent) pwent = getpwnam(pwent->pw_name);
5254 DIE(aTHX_ PL_no_func, "getpwent");
5260 if (GIMME != G_ARRAY) {
5261 PUSHs(sv = sv_newmortal());
5263 if (which == OP_GPWNAM)
5264 # if Uid_t_sign <= 0
5265 sv_setiv(sv, (IV)pwent->pw_uid);
5267 sv_setuv(sv, (UV)pwent->pw_uid);
5270 sv_setpv(sv, pwent->pw_name);
5276 mPUSHs(newSVpv(pwent->pw_name, 0));
5280 /* If we have getspnam(), we try to dig up the shadow
5281 * password. If we are underprivileged, the shadow
5282 * interface will set the errno to EACCES or similar,
5283 * and return a null pointer. If this happens, we will
5284 * use the dummy password (usually "*" or "x") from the
5285 * standard password database.
5287 * In theory we could skip the shadow call completely
5288 * if euid != 0 but in practice we cannot know which
5289 * security measures are guarding the shadow databases
5290 * on a random platform.
5292 * Resist the urge to use additional shadow interfaces.
5293 * Divert the urge to writing an extension instead.
5296 /* Some AIX setups falsely(?) detect some getspnam(), which
5297 * has a different API than the Solaris/IRIX one. */
5298 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5301 const struct spwd * const spwent = getspnam(pwent->pw_name);
5302 /* Save and restore errno so that
5303 * underprivileged attempts seem
5304 * to have never made the unsccessful
5305 * attempt to retrieve the shadow password. */
5307 if (spwent && spwent->sp_pwdp)
5308 sv_setpv(sv, spwent->sp_pwdp);
5312 if (!SvPOK(sv)) /* Use the standard password, then. */
5313 sv_setpv(sv, pwent->pw_passwd);
5316 # ifndef INCOMPLETE_TAINTS
5317 /* passwd is tainted because user himself can diddle with it.
5318 * admittedly not much and in a very limited way, but nevertheless. */
5322 # if Uid_t_sign <= 0
5323 mPUSHi(pwent->pw_uid);
5325 mPUSHu(pwent->pw_uid);
5328 # if Uid_t_sign <= 0
5329 mPUSHi(pwent->pw_gid);
5331 mPUSHu(pwent->pw_gid);
5333 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5334 * because of the poor interface of the Perl getpw*(),
5335 * not because there's some standard/convention saying so.
5336 * A better interface would have been to return a hash,
5337 * but we are accursed by our history, alas. --jhi. */
5339 mPUSHi(pwent->pw_change);
5342 mPUSHi(pwent->pw_quota);
5345 mPUSHs(newSVpv(pwent->pw_age, 0));
5347 /* I think that you can never get this compiled, but just in case. */
5348 PUSHs(sv_mortalcopy(&PL_sv_no));
5353 /* pw_class and pw_comment are mutually exclusive--.
5354 * see the above note for pw_change, pw_quota, and pw_age. */
5356 mPUSHs(newSVpv(pwent->pw_class, 0));
5359 mPUSHs(newSVpv(pwent->pw_comment, 0));
5361 /* I think that you can never get this compiled, but just in case. */
5362 PUSHs(sv_mortalcopy(&PL_sv_no));
5367 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5369 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5371 # ifndef INCOMPLETE_TAINTS
5372 /* pw_gecos is tainted because user himself can diddle with it. */
5376 mPUSHs(newSVpv(pwent->pw_dir, 0));
5378 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5379 # ifndef INCOMPLETE_TAINTS
5380 /* pw_shell is tainted because user himself can diddle with it. */
5385 mPUSHi(pwent->pw_expire);
5390 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5396 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5401 DIE(aTHX_ PL_no_func, "setpwent");
5407 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5412 DIE(aTHX_ PL_no_func, "endpwent");
5420 const I32 which = PL_op->op_type;
5421 const struct group *grent;
5423 if (which == OP_GGRNAM) {
5424 const char* const name = POPpbytex;
5425 grent = (const struct group *)getgrnam(name);
5427 else if (which == OP_GGRGID) {
5428 const Gid_t gid = POPi;
5429 grent = (const struct group *)getgrgid(gid);
5433 grent = (struct group *)getgrent();
5435 DIE(aTHX_ PL_no_func, "getgrent");
5439 if (GIMME != G_ARRAY) {
5440 SV * const sv = sv_newmortal();
5444 if (which == OP_GGRNAM)
5446 sv_setiv(sv, (IV)grent->gr_gid);
5448 sv_setuv(sv, (UV)grent->gr_gid);
5451 sv_setpv(sv, grent->gr_name);
5457 mPUSHs(newSVpv(grent->gr_name, 0));
5460 mPUSHs(newSVpv(grent->gr_passwd, 0));
5462 PUSHs(sv_mortalcopy(&PL_sv_no));
5466 mPUSHi(grent->gr_gid);
5468 mPUSHu(grent->gr_gid);
5471 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5472 /* In UNICOS/mk (_CRAYMPP) the multithreading
5473 * versions (getgrnam_r, getgrgid_r)
5474 * seem to return an illegal pointer
5475 * as the group members list, gr_mem.
5476 * getgrent() doesn't even have a _r version
5477 * but the gr_mem is poisonous anyway.
5478 * So yes, you cannot get the list of group
5479 * members if building multithreaded in UNICOS/mk. */
5480 PUSHs(space_join_names_mortal(grent->gr_mem));
5486 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5492 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5497 DIE(aTHX_ PL_no_func, "setgrent");
5503 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5508 DIE(aTHX_ PL_no_func, "endgrent");
5518 if (!(tmps = PerlProc_getlogin()))
5520 PUSHp(tmps, strlen(tmps));
5523 DIE(aTHX_ PL_no_func, "getlogin");
5527 /* Miscellaneous. */
5532 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5533 register I32 items = SP - MARK;
5534 unsigned long a[20];
5539 while (++MARK <= SP) {
5540 if (SvTAINTED(*MARK)) {
5546 TAINT_PROPER("syscall");
5549 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5550 * or where sizeof(long) != sizeof(char*). But such machines will
5551 * not likely have syscall implemented either, so who cares?
5553 while (++MARK <= SP) {
5554 if (SvNIOK(*MARK) || !i)
5555 a[i++] = SvIV(*MARK);
5556 else if (*MARK == &PL_sv_undef)
5559 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5565 DIE(aTHX_ "Too many args to syscall");
5567 DIE(aTHX_ "Too few args to syscall");
5569 retval = syscall(a[0]);
5572 retval = syscall(a[0],a[1]);
5575 retval = syscall(a[0],a[1],a[2]);
5578 retval = syscall(a[0],a[1],a[2],a[3]);
5581 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5584 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5587 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5590 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5594 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5597 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5600 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5604 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5608 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5612 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5613 a[10],a[11],a[12],a[13]);
5615 #endif /* atarist */
5621 DIE(aTHX_ PL_no_func, "syscall");
5625 #ifdef FCNTL_EMULATE_FLOCK
5627 /* XXX Emulate flock() with fcntl().
5628 What's really needed is a good file locking module.
5632 fcntl_emulate_flock(int fd, int operation)
5637 switch (operation & ~LOCK_NB) {
5639 flock.l_type = F_RDLCK;
5642 flock.l_type = F_WRLCK;
5645 flock.l_type = F_UNLCK;
5651 flock.l_whence = SEEK_SET;
5652 flock.l_start = flock.l_len = (Off_t)0;
5654 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5655 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5656 errno = EWOULDBLOCK;
5660 #endif /* FCNTL_EMULATE_FLOCK */
5662 #ifdef LOCKF_EMULATE_FLOCK
5664 /* XXX Emulate flock() with lockf(). This is just to increase
5665 portability of scripts. The calls are not completely
5666 interchangeable. What's really needed is a good file
5670 /* The lockf() constants might have been defined in <unistd.h>.
5671 Unfortunately, <unistd.h> causes troubles on some mixed
5672 (BSD/POSIX) systems, such as SunOS 4.1.3.
5674 Further, the lockf() constants aren't POSIX, so they might not be
5675 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5676 just stick in the SVID values and be done with it. Sigh.
5680 # define F_ULOCK 0 /* Unlock a previously locked region */
5683 # define F_LOCK 1 /* Lock a region for exclusive use */
5686 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5689 # define F_TEST 3 /* Test a region for other processes locks */
5693 lockf_emulate_flock(int fd, int operation)
5699 /* flock locks entire file so for lockf we need to do the same */
5700 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5701 if (pos > 0) /* is seekable and needs to be repositioned */
5702 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5703 pos = -1; /* seek failed, so don't seek back afterwards */
5706 switch (operation) {
5708 /* LOCK_SH - get a shared lock */
5710 /* LOCK_EX - get an exclusive lock */
5712 i = lockf (fd, F_LOCK, 0);
5715 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5716 case LOCK_SH|LOCK_NB:
5717 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5718 case LOCK_EX|LOCK_NB:
5719 i = lockf (fd, F_TLOCK, 0);
5721 if ((errno == EAGAIN) || (errno == EACCES))
5722 errno = EWOULDBLOCK;
5725 /* LOCK_UN - unlock (non-blocking is a no-op) */
5727 case LOCK_UN|LOCK_NB:
5728 i = lockf (fd, F_ULOCK, 0);
5731 /* Default - can't decipher operation */
5738 if (pos > 0) /* need to restore position of the handle */
5739 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5744 #endif /* LOCKF_EMULATE_FLOCK */
5748 * c-indentation-style: bsd
5750 * indent-tabs-mode: t
5753 * ex: set ts=8 sts=4 sw=4 noet: