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) && !SvFAKE(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) && !SvFAKE(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) && !SvFAKE(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;
1353 if (!io || !(ofp = IoOFP(io)))
1356 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1357 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1359 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1360 PL_formtarget != PL_toptarget)
1364 if (!IoTOP_GV(io)) {
1367 if (!IoTOP_NAME(io)) {
1369 if (!IoFMT_NAME(io))
1370 IoFMT_NAME(io) = savepv(GvNAME(gv));
1371 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1372 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1373 if ((topgv && GvFORM(topgv)) ||
1374 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1375 IoTOP_NAME(io) = savesvpv(topname);
1377 IoTOP_NAME(io) = savepvs("top");
1379 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1380 if (!topgv || !GvFORM(topgv)) {
1381 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1384 IoTOP_GV(io) = topgv;
1386 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1387 I32 lines = IoLINES_LEFT(io);
1388 const char *s = SvPVX_const(PL_formtarget);
1389 if (lines <= 0) /* Yow, header didn't even fit!!! */
1391 while (lines-- > 0) {
1392 s = strchr(s, '\n');
1398 const STRLEN save = SvCUR(PL_formtarget);
1399 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1400 do_print(PL_formtarget, ofp);
1401 SvCUR_set(PL_formtarget, save);
1402 sv_chop(PL_formtarget, s);
1403 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1406 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1407 do_print(PL_formfeed, ofp);
1408 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1410 PL_formtarget = PL_toptarget;
1411 IoFLAGS(io) |= IOf_DIDTOP;
1414 DIE(aTHX_ "bad top format reference");
1417 SV * const sv = sv_newmortal();
1419 gv_efullname4(sv, fgv, NULL, FALSE);
1420 name = SvPV_nolen_const(sv);
1422 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1424 DIE(aTHX_ "Undefined top format called");
1426 return doform(cv, gv, PL_op);
1430 POPBLOCK(cx,PL_curpm);
1432 retop = cx->blk_sub.retop;
1437 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1439 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1440 else if (ckWARN(WARN_CLOSED))
1441 report_evil_fh(gv, io, PL_op->op_type);
1446 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1447 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1449 if (!do_print(PL_formtarget, fp))
1452 FmLINES(PL_formtarget) = 0;
1453 SvCUR_set(PL_formtarget, 0);
1454 *SvEND(PL_formtarget) = '\0';
1455 if (IoFLAGS(io) & IOf_FLUSH)
1456 (void)PerlIO_flush(fp);
1461 PL_formtarget = PL_bodytarget;
1463 PERL_UNUSED_VAR(newsp);
1464 PERL_UNUSED_VAR(gimme);
1470 dVAR; dSP; dMARK; dORIGMARK;
1476 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1478 if (gv && (io = GvIO(gv))) {
1479 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1481 if (MARK == ORIGMARK) {
1484 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1488 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1491 call_method("PRINTF", G_SCALAR);
1494 MARK = ORIGMARK + 1;
1502 if (!(io = GvIO(gv))) {
1503 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1504 report_evil_fh(gv, io, PL_op->op_type);
1505 SETERRNO(EBADF,RMS_IFI);
1508 else if (!(fp = IoOFP(io))) {
1509 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1511 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1512 else if (ckWARN(WARN_CLOSED))
1513 report_evil_fh(gv, io, PL_op->op_type);
1515 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1519 if (SvTAINTED(MARK[1]))
1520 TAINT_PROPER("printf");
1521 do_sprintf(sv, SP - MARK, MARK + 1);
1522 if (!do_print(sv, fp))
1525 if (IoFLAGS(io) & IOf_FLUSH)
1526 if (PerlIO_flush(fp) == EOF)
1537 PUSHs(&PL_sv_undef);
1545 const int perm = (MAXARG > 3) ? POPi : 0666;
1546 const int mode = POPi;
1547 SV * const sv = POPs;
1548 GV * const gv = MUTABLE_GV(POPs);
1551 /* Need TIEHANDLE method ? */
1552 const char * const tmps = SvPV_const(sv, len);
1553 /* FIXME? do_open should do const */
1554 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1555 IoLINES(GvIOp(gv)) = 0;
1559 PUSHs(&PL_sv_undef);
1566 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1572 Sock_size_t bufsize;
1580 bool charstart = FALSE;
1581 STRLEN charskip = 0;
1584 GV * const gv = MUTABLE_GV(*++MARK);
1585 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1586 && gv && (io = GvIO(gv)) )
1588 const MAGIC * mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1592 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1594 call_method("READ", G_SCALAR);
1608 sv_setpvs(bufsv, "");
1609 length = SvIVx(*++MARK);
1612 offset = SvIVx(*++MARK);
1616 if (!io || !IoIFP(io)) {
1617 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1618 report_evil_fh(gv, io, PL_op->op_type);
1619 SETERRNO(EBADF,RMS_IFI);
1622 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1623 buffer = SvPVutf8_force(bufsv, blen);
1624 /* UTF-8 may not have been set if they are all low bytes */
1629 buffer = SvPV_force(bufsv, blen);
1630 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1633 DIE(aTHX_ "Negative length");
1641 if (PL_op->op_type == OP_RECV) {
1642 char namebuf[MAXPATHLEN];
1643 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1644 bufsize = sizeof (struct sockaddr_in);
1646 bufsize = sizeof namebuf;
1648 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1652 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1653 /* 'offset' means 'flags' here */
1654 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1655 (struct sockaddr *)namebuf, &bufsize);
1658 /* MSG_TRUNC can give oversized count; quietly lose it */
1662 /* Bogus return without padding */
1663 bufsize = sizeof (struct sockaddr_in);
1665 SvCUR_set(bufsv, count);
1666 *SvEND(bufsv) = '\0';
1667 (void)SvPOK_only(bufsv);
1671 /* This should not be marked tainted if the fp is marked clean */
1672 if (!(IoFLAGS(io) & IOf_UNTAINT))
1673 SvTAINTED_on(bufsv);
1675 sv_setpvn(TARG, namebuf, bufsize);
1680 if (PL_op->op_type == OP_RECV)
1681 DIE(aTHX_ PL_no_sock_func, "recv");
1683 if (DO_UTF8(bufsv)) {
1684 /* offset adjust in characters not bytes */
1685 blen = sv_len_utf8(bufsv);
1688 if (-offset > (int)blen)
1689 DIE(aTHX_ "Offset outside string");
1692 if (DO_UTF8(bufsv)) {
1693 /* convert offset-as-chars to offset-as-bytes */
1694 if (offset >= (int)blen)
1695 offset += SvCUR(bufsv) - blen;
1697 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1700 bufsize = SvCUR(bufsv);
1701 /* Allocating length + offset + 1 isn't perfect in the case of reading
1702 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1704 (should be 2 * length + offset + 1, or possibly something longer if
1705 PL_encoding is true) */
1706 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1707 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1708 Zero(buffer+bufsize, offset-bufsize, char);
1710 buffer = buffer + offset;
1712 read_target = bufsv;
1714 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1715 concatenate it to the current buffer. */
1717 /* Truncate the existing buffer to the start of where we will be
1719 SvCUR_set(bufsv, offset);
1721 read_target = sv_newmortal();
1722 SvUPGRADE(read_target, SVt_PV);
1723 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1726 if (PL_op->op_type == OP_SYSREAD) {
1727 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1728 if (IoTYPE(io) == IoTYPE_SOCKET) {
1729 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1735 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1740 #ifdef HAS_SOCKET__bad_code_maybe
1741 if (IoTYPE(io) == IoTYPE_SOCKET) {
1742 char namebuf[MAXPATHLEN];
1743 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1744 bufsize = sizeof (struct sockaddr_in);
1746 bufsize = sizeof namebuf;
1748 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1749 (struct sockaddr *)namebuf, &bufsize);
1754 count = PerlIO_read(IoIFP(io), buffer, length);
1755 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1756 if (count == 0 && PerlIO_error(IoIFP(io)))
1760 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1761 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1764 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1765 *SvEND(read_target) = '\0';
1766 (void)SvPOK_only(read_target);
1767 if (fp_utf8 && !IN_BYTES) {
1768 /* Look at utf8 we got back and count the characters */
1769 const char *bend = buffer + count;
1770 while (buffer < bend) {
1772 skip = UTF8SKIP(buffer);
1775 if (buffer - charskip + skip > bend) {
1776 /* partial character - try for rest of it */
1777 length = skip - (bend-buffer);
1778 offset = bend - SvPVX_const(bufsv);
1790 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1791 provided amount read (count) was what was requested (length)
1793 if (got < wanted && count == length) {
1794 length = wanted - got;
1795 offset = bend - SvPVX_const(bufsv);
1798 /* return value is character count */
1802 else if (buffer_utf8) {
1803 /* Let svcatsv upgrade the bytes we read in to utf8.
1804 The buffer is a mortal so will be freed soon. */
1805 sv_catsv_nomg(bufsv, read_target);
1808 /* This should not be marked tainted if the fp is marked clean */
1809 if (!(IoFLAGS(io) & IOf_UNTAINT))
1810 SvTAINTED_on(bufsv);
1822 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1828 STRLEN orig_blen_bytes;
1829 const int op_type = PL_op->op_type;
1833 GV *const gv = MUTABLE_GV(*++MARK);
1834 if (PL_op->op_type == OP_SYSWRITE
1835 && gv && (io = GvIO(gv))) {
1836 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1840 if (MARK == SP - 1) {
1842 mXPUSHi(sv_len(sv));
1847 *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg);
1849 call_method("WRITE", G_SCALAR);
1865 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1867 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1868 if (io && IoIFP(io))
1869 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1871 report_evil_fh(gv, io, PL_op->op_type);
1873 SETERRNO(EBADF,RMS_IFI);
1877 /* Do this first to trigger any overloading. */
1878 buffer = SvPV_const(bufsv, blen);
1879 orig_blen_bytes = blen;
1880 doing_utf8 = DO_UTF8(bufsv);
1882 if (PerlIO_isutf8(IoIFP(io))) {
1883 if (!SvUTF8(bufsv)) {
1884 /* We don't modify the original scalar. */
1885 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1886 buffer = (char *) tmpbuf;
1890 else if (doing_utf8) {
1891 STRLEN tmplen = blen;
1892 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1895 buffer = (char *) tmpbuf;
1899 assert((char *)result == buffer);
1900 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1904 if (op_type == OP_SYSWRITE) {
1905 Size_t length = 0; /* This length is in characters. */
1911 /* The SV is bytes, and we've had to upgrade it. */
1912 blen_chars = orig_blen_bytes;
1914 /* The SV really is UTF-8. */
1915 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1916 /* Don't call sv_len_utf8 again because it will call magic
1917 or overloading a second time, and we might get back a
1918 different result. */
1919 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1921 /* It's safe, and it may well be cached. */
1922 blen_chars = sv_len_utf8(bufsv);
1930 length = blen_chars;
1932 #if Size_t_size > IVSIZE
1933 length = (Size_t)SvNVx(*++MARK);
1935 length = (Size_t)SvIVx(*++MARK);
1937 if ((SSize_t)length < 0) {
1939 DIE(aTHX_ "Negative length");
1944 offset = SvIVx(*++MARK);
1946 if (-offset > (IV)blen_chars) {
1948 DIE(aTHX_ "Offset outside string");
1950 offset += blen_chars;
1951 } else if (offset > (IV)blen_chars) {
1953 DIE(aTHX_ "Offset outside string");
1957 if (length > blen_chars - offset)
1958 length = blen_chars - offset;
1960 /* Here we convert length from characters to bytes. */
1961 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1962 /* Either we had to convert the SV, or the SV is magical, or
1963 the SV has overloading, in which case we can't or mustn't
1964 or mustn't call it again. */
1966 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1967 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1969 /* It's a real UTF-8 SV, and it's not going to change under
1970 us. Take advantage of any cache. */
1972 I32 len_I32 = length;
1974 /* Convert the start and end character positions to bytes.
1975 Remember that the second argument to sv_pos_u2b is relative
1977 sv_pos_u2b(bufsv, &start, &len_I32);
1984 buffer = buffer+offset;
1986 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1987 if (IoTYPE(io) == IoTYPE_SOCKET) {
1988 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1994 /* See the note at doio.c:do_print about filesize limits. --jhi */
1995 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2001 const int flags = SvIVx(*++MARK);
2004 char * const sockbuf = SvPVx(*++MARK, mlen);
2005 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
2006 flags, (struct sockaddr *)sockbuf, mlen);
2010 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
2015 DIE(aTHX_ PL_no_sock_func, "send");
2022 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2025 #if Size_t_size > IVSIZE
2045 * in Perl 5.12 and later, the additional parameter is a bitmask:
2048 * 2 = eof() <- ARGV magic
2050 * I'll rely on the compiler's trace flow analysis to decide whether to
2051 * actually assign this out here, or punt it into the only block where it is
2052 * used. Doing it out here is DRY on the condition logic.
2057 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2063 if (PL_op->op_flags & OPf_SPECIAL) {
2064 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2068 gv = PL_last_in_gv; /* eof */
2076 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2077 return tied_handle_method1("EOF", SP, io, mg, newSVuv(which));
2080 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2081 if (io && !IoIFP(io)) {
2082 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2084 IoFLAGS(io) &= ~IOf_START;
2085 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2087 sv_setpvs(GvSV(gv), "-");
2089 GvSV(gv) = newSVpvs("-");
2090 SvSETMAGIC(GvSV(gv));
2092 else if (!nextargv(gv))
2097 PUSHs(boolSV(do_eof(gv)));
2108 PL_last_in_gv = MUTABLE_GV(POPs);
2113 if (gv && (io = GvIO(gv))) {
2114 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2116 return tied_handle_method("TELL", SP, io, mg);
2121 SETERRNO(EBADF,RMS_IFI);
2126 #if LSEEKSIZE > IVSIZE
2127 PUSHn( do_tell(gv) );
2129 PUSHi( do_tell(gv) );
2137 const int whence = POPi;
2138 #if LSEEKSIZE > IVSIZE
2139 const Off_t offset = (Off_t)SvNVx(POPs);
2141 const Off_t offset = (Off_t)SvIVx(POPs);
2144 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2147 if (gv && (io = GvIO(gv))) {
2148 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2150 #if LSEEKSIZE > IVSIZE
2151 SV *const offset_sv = newSVnv((NV) offset);
2153 SV *const offset_sv = newSViv(offset);
2156 return tied_handle_method2("SEEK", SP, io, mg, offset_sv,
2161 if (PL_op->op_type == OP_SEEK)
2162 PUSHs(boolSV(do_seek(gv, offset, whence)));
2164 const Off_t sought = do_sysseek(gv, offset, whence);
2166 PUSHs(&PL_sv_undef);
2168 SV* const sv = sought ?
2169 #if LSEEKSIZE > IVSIZE
2174 : newSVpvn(zero_but_true, ZBTLEN);
2185 /* There seems to be no consensus on the length type of truncate()
2186 * and ftruncate(), both off_t and size_t have supporters. In
2187 * general one would think that when using large files, off_t is
2188 * at least as wide as size_t, so using an off_t should be okay. */
2189 /* XXX Configure probe for the length type of *truncate() needed XXX */
2192 #if Off_t_size > IVSIZE
2197 /* Checking for length < 0 is problematic as the type might or
2198 * might not be signed: if it is not, clever compilers will moan. */
2199 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2206 if (PL_op->op_flags & OPf_SPECIAL) {
2207 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2216 TAINT_PROPER("truncate");
2217 if (!(fp = IoIFP(io))) {
2223 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2225 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2232 SV * const sv = POPs;
2235 if (isGV_with_GP(sv)) {
2236 tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */
2237 goto do_ftruncate_gv;
2239 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2240 tmpgv = MUTABLE_GV(SvRV(sv)); /* \*main::FRED for example */
2241 goto do_ftruncate_gv;
2243 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2244 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2245 goto do_ftruncate_io;
2248 name = SvPV_nolen_const(sv);
2249 TAINT_PROPER("truncate");
2251 if (truncate(name, len) < 0)
2255 const int tmpfd = PerlLIO_open(name, O_RDWR);
2260 if (my_chsize(tmpfd, len) < 0)
2262 PerlLIO_close(tmpfd);
2271 SETERRNO(EBADF,RMS_IFI);
2279 SV * const argsv = POPs;
2280 const unsigned int func = POPu;
2281 const int optype = PL_op->op_type;
2282 GV * const gv = MUTABLE_GV(POPs);
2283 IO * const io = gv ? GvIOn(gv) : NULL;
2287 if (!io || !argsv || !IoIFP(io)) {
2288 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2289 report_evil_fh(gv, io, PL_op->op_type);
2290 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2294 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2297 s = SvPV_force(argsv, len);
2298 need = IOCPARM_LEN(func);
2300 s = Sv_Grow(argsv, need + 1);
2301 SvCUR_set(argsv, need);
2304 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2307 retval = SvIV(argsv);
2308 s = INT2PTR(char*,retval); /* ouch */
2311 TAINT_PROPER(PL_op_desc[optype]);
2313 if (optype == OP_IOCTL)
2315 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2317 DIE(aTHX_ "ioctl is not implemented");
2321 DIE(aTHX_ "fcntl is not implemented");
2323 #if defined(OS2) && defined(__EMX__)
2324 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2326 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2330 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2332 if (s[SvCUR(argsv)] != 17)
2333 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2335 s[SvCUR(argsv)] = 0; /* put our null back */
2336 SvSETMAGIC(argsv); /* Assume it has changed */
2345 PUSHp(zero_but_true, ZBTLEN);
2358 const int argtype = POPi;
2359 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
2361 if (gv && (io = GvIO(gv)))
2367 /* XXX Looks to me like io is always NULL at this point */
2369 (void)PerlIO_flush(fp);
2370 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2373 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2374 report_evil_fh(gv, io, PL_op->op_type);
2376 SETERRNO(EBADF,RMS_IFI);
2381 DIE(aTHX_ PL_no_func, "flock()");
2391 const int protocol = POPi;
2392 const int type = POPi;
2393 const int domain = POPi;
2394 GV * const gv = MUTABLE_GV(POPs);
2395 register IO * const io = gv ? GvIOn(gv) : NULL;
2399 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2400 report_evil_fh(gv, io, PL_op->op_type);
2401 if (io && IoIFP(io))
2402 do_close(gv, FALSE);
2403 SETERRNO(EBADF,LIB_INVARG);
2408 do_close(gv, FALSE);
2410 TAINT_PROPER("socket");
2411 fd = PerlSock_socket(domain, type, protocol);
2414 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2415 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2416 IoTYPE(io) = IoTYPE_SOCKET;
2417 if (!IoIFP(io) || !IoOFP(io)) {
2418 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2419 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2420 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2423 #if defined(HAS_FCNTL) && defined(F_SETFD)
2424 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2428 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2433 DIE(aTHX_ PL_no_sock_func, "socket");
2439 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2441 const int protocol = POPi;
2442 const int type = POPi;
2443 const int domain = POPi;
2444 GV * const gv2 = MUTABLE_GV(POPs);
2445 GV * const gv1 = MUTABLE_GV(POPs);
2446 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2447 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2450 if (!gv1 || !gv2 || !io1 || !io2) {
2451 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2453 report_evil_fh(gv1, io1, PL_op->op_type);
2455 report_evil_fh(gv1, io2, PL_op->op_type);
2457 if (io1 && IoIFP(io1))
2458 do_close(gv1, FALSE);
2459 if (io2 && IoIFP(io2))
2460 do_close(gv2, FALSE);
2465 do_close(gv1, FALSE);
2467 do_close(gv2, FALSE);
2469 TAINT_PROPER("socketpair");
2470 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2472 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2473 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2474 IoTYPE(io1) = IoTYPE_SOCKET;
2475 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2476 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2477 IoTYPE(io2) = IoTYPE_SOCKET;
2478 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2479 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2480 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2481 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2482 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2483 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2484 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2487 #if defined(HAS_FCNTL) && defined(F_SETFD)
2488 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2489 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2494 DIE(aTHX_ PL_no_sock_func, "socketpair");
2502 SV * const addrsv = POPs;
2503 /* OK, so on what platform does bind modify addr? */
2505 GV * const gv = MUTABLE_GV(POPs);
2506 register IO * const io = GvIOn(gv);
2509 if (!io || !IoIFP(io))
2512 addr = SvPV_const(addrsv, len);
2513 TAINT_PROPER("bind");
2514 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2520 if (ckWARN(WARN_CLOSED))
2521 report_evil_fh(gv, io, PL_op->op_type);
2522 SETERRNO(EBADF,SS_IVCHAN);
2525 DIE(aTHX_ PL_no_sock_func, "bind");
2533 SV * const addrsv = POPs;
2534 GV * const gv = MUTABLE_GV(POPs);
2535 register IO * const io = GvIOn(gv);
2539 if (!io || !IoIFP(io))
2542 addr = SvPV_const(addrsv, len);
2543 TAINT_PROPER("connect");
2544 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2550 if (ckWARN(WARN_CLOSED))
2551 report_evil_fh(gv, io, PL_op->op_type);
2552 SETERRNO(EBADF,SS_IVCHAN);
2555 DIE(aTHX_ PL_no_sock_func, "connect");
2563 const int backlog = POPi;
2564 GV * const gv = MUTABLE_GV(POPs);
2565 register IO * const io = gv ? GvIOn(gv) : NULL;
2567 if (!gv || !io || !IoIFP(io))
2570 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2576 if (ckWARN(WARN_CLOSED))
2577 report_evil_fh(gv, io, PL_op->op_type);
2578 SETERRNO(EBADF,SS_IVCHAN);
2581 DIE(aTHX_ PL_no_sock_func, "listen");
2591 char namebuf[MAXPATHLEN];
2592 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2593 Sock_size_t len = sizeof (struct sockaddr_in);
2595 Sock_size_t len = sizeof namebuf;
2597 GV * const ggv = MUTABLE_GV(POPs);
2598 GV * const ngv = MUTABLE_GV(POPs);
2607 if (!gstio || !IoIFP(gstio))
2611 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2614 /* Some platforms indicate zero length when an AF_UNIX client is
2615 * not bound. Simulate a non-zero-length sockaddr structure in
2617 namebuf[0] = 0; /* sun_len */
2618 namebuf[1] = AF_UNIX; /* sun_family */
2626 do_close(ngv, FALSE);
2627 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2628 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2629 IoTYPE(nstio) = IoTYPE_SOCKET;
2630 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2631 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2632 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2633 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2636 #if defined(HAS_FCNTL) && defined(F_SETFD)
2637 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2641 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2642 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2644 #ifdef __SCO_VERSION__
2645 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2648 PUSHp(namebuf, len);
2652 if (ckWARN(WARN_CLOSED))
2653 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2654 SETERRNO(EBADF,SS_IVCHAN);
2660 DIE(aTHX_ PL_no_sock_func, "accept");
2668 const int how = POPi;
2669 GV * const gv = MUTABLE_GV(POPs);
2670 register IO * const io = GvIOn(gv);
2672 if (!io || !IoIFP(io))
2675 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2679 if (ckWARN(WARN_CLOSED))
2680 report_evil_fh(gv, io, PL_op->op_type);
2681 SETERRNO(EBADF,SS_IVCHAN);
2684 DIE(aTHX_ PL_no_sock_func, "shutdown");
2692 const int optype = PL_op->op_type;
2693 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2694 const unsigned int optname = (unsigned int) POPi;
2695 const unsigned int lvl = (unsigned int) POPi;
2696 GV * const gv = MUTABLE_GV(POPs);
2697 register IO * const io = GvIOn(gv);
2701 if (!io || !IoIFP(io))
2704 fd = PerlIO_fileno(IoIFP(io));
2708 (void)SvPOK_only(sv);
2712 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2719 #if defined(__SYMBIAN32__)
2720 # define SETSOCKOPT_OPTION_VALUE_T void *
2722 # define SETSOCKOPT_OPTION_VALUE_T const char *
2724 /* XXX TODO: We need to have a proper type (a Configure probe,
2725 * etc.) for what the C headers think of the third argument of
2726 * setsockopt(), the option_value read-only buffer: is it
2727 * a "char *", or a "void *", const or not. Some compilers
2728 * don't take kindly to e.g. assuming that "char *" implicitly
2729 * promotes to a "void *", or to explicitly promoting/demoting
2730 * consts to non/vice versa. The "const void *" is the SUS
2731 * definition, but that does not fly everywhere for the above
2733 SETSOCKOPT_OPTION_VALUE_T buf;
2737 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2741 aint = (int)SvIV(sv);
2742 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2745 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2754 if (ckWARN(WARN_CLOSED))
2755 report_evil_fh(gv, io, optype);
2756 SETERRNO(EBADF,SS_IVCHAN);
2761 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2769 const int optype = PL_op->op_type;
2770 GV * const gv = MUTABLE_GV(POPs);
2771 register IO * const io = GvIOn(gv);
2776 if (!io || !IoIFP(io))
2779 sv = sv_2mortal(newSV(257));
2780 (void)SvPOK_only(sv);
2784 fd = PerlIO_fileno(IoIFP(io));
2786 case OP_GETSOCKNAME:
2787 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2790 case OP_GETPEERNAME:
2791 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2793 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2795 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";
2796 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2797 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2798 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2799 sizeof(u_short) + sizeof(struct in_addr))) {
2806 #ifdef BOGUS_GETNAME_RETURN
2807 /* Interactive Unix, getpeername() and getsockname()
2808 does not return valid namelen */
2809 if (len == BOGUS_GETNAME_RETURN)
2810 len = sizeof(struct sockaddr);
2818 if (ckWARN(WARN_CLOSED))
2819 report_evil_fh(gv, io, optype);
2820 SETERRNO(EBADF,SS_IVCHAN);
2825 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2840 if (PL_op->op_flags & OPf_REF) {
2842 if (PL_op->op_type == OP_LSTAT) {
2843 if (gv != PL_defgv) {
2844 do_fstat_warning_check:
2845 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2846 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2847 } else if (PL_laststype != OP_LSTAT)
2848 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2852 if (gv != PL_defgv) {
2853 PL_laststype = OP_STAT;
2855 sv_setpvs(PL_statname, "");
2862 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2863 } else if (IoDIRP(io)) {
2865 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2867 PL_laststatval = -1;
2873 if (PL_laststatval < 0) {
2874 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2875 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2880 SV* const sv = POPs;
2881 if (isGV_with_GP(sv)) {
2882 gv = MUTABLE_GV(sv);
2884 } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2885 gv = MUTABLE_GV(SvRV(sv));
2886 if (PL_op->op_type == OP_LSTAT)
2887 goto do_fstat_warning_check;
2889 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2890 io = MUTABLE_IO(SvRV(sv));
2891 if (PL_op->op_type == OP_LSTAT)
2892 goto do_fstat_warning_check;
2893 goto do_fstat_have_io;
2896 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2898 PL_laststype = PL_op->op_type;
2899 if (PL_op->op_type == OP_LSTAT)
2900 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2902 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2903 if (PL_laststatval < 0) {
2904 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2905 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2911 if (gimme != G_ARRAY) {
2912 if (gimme != G_VOID)
2913 XPUSHs(boolSV(max));
2919 mPUSHi(PL_statcache.st_dev);
2920 mPUSHi(PL_statcache.st_ino);
2921 mPUSHu(PL_statcache.st_mode);
2922 mPUSHu(PL_statcache.st_nlink);
2923 #if Uid_t_size > IVSIZE
2924 mPUSHn(PL_statcache.st_uid);
2926 # if Uid_t_sign <= 0
2927 mPUSHi(PL_statcache.st_uid);
2929 mPUSHu(PL_statcache.st_uid);
2932 #if Gid_t_size > IVSIZE
2933 mPUSHn(PL_statcache.st_gid);
2935 # if Gid_t_sign <= 0
2936 mPUSHi(PL_statcache.st_gid);
2938 mPUSHu(PL_statcache.st_gid);
2941 #ifdef USE_STAT_RDEV
2942 mPUSHi(PL_statcache.st_rdev);
2944 PUSHs(newSVpvs_flags("", SVs_TEMP));
2946 #if Off_t_size > IVSIZE
2947 mPUSHn(PL_statcache.st_size);
2949 mPUSHi(PL_statcache.st_size);
2952 mPUSHn(PL_statcache.st_atime);
2953 mPUSHn(PL_statcache.st_mtime);
2954 mPUSHn(PL_statcache.st_ctime);
2956 mPUSHi(PL_statcache.st_atime);
2957 mPUSHi(PL_statcache.st_mtime);
2958 mPUSHi(PL_statcache.st_ctime);
2960 #ifdef USE_STAT_BLOCKS
2961 mPUSHu(PL_statcache.st_blksize);
2962 mPUSHu(PL_statcache.st_blocks);
2964 PUSHs(newSVpvs_flags("", SVs_TEMP));
2965 PUSHs(newSVpvs_flags("", SVs_TEMP));
2971 #define tryAMAGICftest_MG(chr) STMT_START { \
2972 if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
2973 && S_try_amagic_ftest(aTHX_ chr)) \
2978 S_try_amagic_ftest(pTHX_ char chr) {
2981 SV* const arg = TOPs;
2986 if ((PL_op->op_flags & OPf_KIDS)
2989 const char tmpchr = chr;
2991 SV * const tmpsv = amagic_call(arg,
2992 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2993 ftest_amg, AMGf_unary);
3000 next = PL_op->op_next;
3001 if (next->op_type >= OP_FTRREAD &&
3002 next->op_type <= OP_FTBINARY &&
3003 next->op_private & OPpFT_STACKED
3006 /* leave the object alone */
3018 /* This macro is used by the stacked filetest operators :
3019 * if the previous filetest failed, short-circuit and pass its value.
3020 * Else, discard it from the stack and continue. --rgs
3022 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
3023 if (!SvTRUE(TOPs)) { RETURN; } \
3024 else { (void)POPs; PUTBACK; } \
3031 /* Not const, because things tweak this below. Not bool, because there's
3032 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
3033 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3034 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3035 /* Giving some sort of initial value silences compilers. */
3037 int access_mode = R_OK;
3039 int access_mode = 0;
3042 /* access_mode is never used, but leaving use_access in makes the
3043 conditional compiling below much clearer. */
3046 int stat_mode = S_IRUSR;
3048 bool effective = FALSE;
3052 switch (PL_op->op_type) {
3053 case OP_FTRREAD: opchar = 'R'; break;
3054 case OP_FTRWRITE: opchar = 'W'; break;
3055 case OP_FTREXEC: opchar = 'X'; break;
3056 case OP_FTEREAD: opchar = 'r'; break;
3057 case OP_FTEWRITE: opchar = 'w'; break;
3058 case OP_FTEEXEC: opchar = 'x'; break;
3060 tryAMAGICftest_MG(opchar);
3062 STACKED_FTEST_CHECK;
3064 switch (PL_op->op_type) {
3066 #if !(defined(HAS_ACCESS) && defined(R_OK))
3072 #if defined(HAS_ACCESS) && defined(W_OK)
3077 stat_mode = S_IWUSR;
3081 #if defined(HAS_ACCESS) && defined(X_OK)
3086 stat_mode = S_IXUSR;
3090 #ifdef PERL_EFF_ACCESS
3093 stat_mode = S_IWUSR;
3097 #ifndef PERL_EFF_ACCESS
3104 #ifdef PERL_EFF_ACCESS
3109 stat_mode = S_IXUSR;
3115 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3116 const char *name = POPpx;
3118 # ifdef PERL_EFF_ACCESS
3119 result = PERL_EFF_ACCESS(name, access_mode);
3121 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3127 result = access(name, access_mode);
3129 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3140 result = my_stat_flags(0);
3144 if (cando(stat_mode, effective, &PL_statcache))
3153 const int op_type = PL_op->op_type;
3158 case OP_FTIS: opchar = 'e'; break;
3159 case OP_FTSIZE: opchar = 's'; break;
3160 case OP_FTMTIME: opchar = 'M'; break;
3161 case OP_FTCTIME: opchar = 'C'; break;
3162 case OP_FTATIME: opchar = 'A'; break;
3164 tryAMAGICftest_MG(opchar);
3166 STACKED_FTEST_CHECK;
3168 result = my_stat_flags(0);
3172 if (op_type == OP_FTIS)
3175 /* You can't dTARGET inside OP_FTIS, because you'll get
3176 "panic: pad_sv po" - the op is not flagged to have a target. */
3180 #if Off_t_size > IVSIZE
3181 PUSHn(PL_statcache.st_size);
3183 PUSHi(PL_statcache.st_size);
3187 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3190 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3193 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3207 switch (PL_op->op_type) {
3208 case OP_FTROWNED: opchar = 'O'; break;
3209 case OP_FTEOWNED: opchar = 'o'; break;
3210 case OP_FTZERO: opchar = 'z'; break;
3211 case OP_FTSOCK: opchar = 'S'; break;
3212 case OP_FTCHR: opchar = 'c'; break;
3213 case OP_FTBLK: opchar = 'b'; break;
3214 case OP_FTFILE: opchar = 'f'; break;
3215 case OP_FTDIR: opchar = 'd'; break;
3216 case OP_FTPIPE: opchar = 'p'; break;
3217 case OP_FTSUID: opchar = 'u'; break;
3218 case OP_FTSGID: opchar = 'g'; break;
3219 case OP_FTSVTX: opchar = 'k'; break;
3221 tryAMAGICftest_MG(opchar);
3223 STACKED_FTEST_CHECK;
3225 /* I believe that all these three are likely to be defined on most every
3226 system these days. */
3228 if(PL_op->op_type == OP_FTSUID) {
3229 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3235 if(PL_op->op_type == OP_FTSGID) {
3236 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3242 if(PL_op->op_type == OP_FTSVTX) {
3243 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3249 result = my_stat_flags(0);
3253 switch (PL_op->op_type) {
3255 if (PL_statcache.st_uid == PL_uid)
3259 if (PL_statcache.st_uid == PL_euid)
3263 if (PL_statcache.st_size == 0)
3267 if (S_ISSOCK(PL_statcache.st_mode))
3271 if (S_ISCHR(PL_statcache.st_mode))
3275 if (S_ISBLK(PL_statcache.st_mode))
3279 if (S_ISREG(PL_statcache.st_mode))
3283 if (S_ISDIR(PL_statcache.st_mode))
3287 if (S_ISFIFO(PL_statcache.st_mode))
3292 if (PL_statcache.st_mode & S_ISUID)
3298 if (PL_statcache.st_mode & S_ISGID)
3304 if (PL_statcache.st_mode & S_ISVTX)
3318 tryAMAGICftest_MG('l');
3319 result = my_lstat_flags(0);
3324 if (S_ISLNK(PL_statcache.st_mode))
3339 tryAMAGICftest_MG('t');
3341 STACKED_FTEST_CHECK;
3343 if (PL_op->op_flags & OPf_REF)
3345 else if (isGV_with_GP(TOPs))
3346 gv = MUTABLE_GV(POPs);
3347 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3348 gv = MUTABLE_GV(SvRV(POPs));
3351 name = SvPV_nomg(tmpsv, namelen);
3352 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3355 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3356 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3357 else if (tmpsv && SvOK(tmpsv)) {
3365 if (PerlLIO_isatty(fd))
3370 #if defined(atarist) /* this will work with atariST. Configure will
3371 make guesses for other systems. */
3372 # define FILE_base(f) ((f)->_base)
3373 # define FILE_ptr(f) ((f)->_ptr)
3374 # define FILE_cnt(f) ((f)->_cnt)
3375 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3386 register STDCHAR *s;
3392 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3394 STACKED_FTEST_CHECK;
3396 if (PL_op->op_flags & OPf_REF)
3398 else if (isGV_with_GP(TOPs))
3399 gv = MUTABLE_GV(POPs);
3400 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3401 gv = MUTABLE_GV(SvRV(POPs));
3407 if (gv == PL_defgv) {
3409 io = GvIO(PL_statgv);
3412 goto really_filename;
3417 PL_laststatval = -1;
3418 sv_setpvs(PL_statname, "");
3419 io = GvIO(PL_statgv);
3421 if (io && IoIFP(io)) {
3422 if (! PerlIO_has_base(IoIFP(io)))
3423 DIE(aTHX_ "-T and -B not implemented on filehandles");
3424 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3425 if (PL_laststatval < 0)
3427 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3428 if (PL_op->op_type == OP_FTTEXT)
3433 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3434 i = PerlIO_getc(IoIFP(io));
3436 (void)PerlIO_ungetc(IoIFP(io),i);
3438 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3440 len = PerlIO_get_bufsiz(IoIFP(io));
3441 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3442 /* sfio can have large buffers - limit to 512 */
3447 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3449 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3451 SETERRNO(EBADF,RMS_IFI);
3459 PL_laststype = OP_STAT;
3460 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3461 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3462 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3464 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3467 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3468 if (PL_laststatval < 0) {
3469 (void)PerlIO_close(fp);
3472 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3473 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3474 (void)PerlIO_close(fp);
3476 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3477 RETPUSHNO; /* special case NFS directories */
3478 RETPUSHYES; /* null file is anything */
3483 /* now scan s to look for textiness */
3484 /* XXX ASCII dependent code */
3486 #if defined(DOSISH) || defined(USEMYBINMODE)
3487 /* ignore trailing ^Z on short files */
3488 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3492 for (i = 0; i < len; i++, s++) {
3493 if (!*s) { /* null never allowed in text */
3498 else if (!(isPRINT(*s) || isSPACE(*s)))
3501 else if (*s & 128) {
3503 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3506 /* utf8 characters don't count as odd */
3507 if (UTF8_IS_START(*s)) {
3508 int ulen = UTF8SKIP(s);
3509 if (ulen < len - i) {
3511 for (j = 1; j < ulen; j++) {
3512 if (!UTF8_IS_CONTINUATION(s[j]))
3515 --ulen; /* loop does extra increment */
3525 *s != '\n' && *s != '\r' && *s != '\b' &&
3526 *s != '\t' && *s != '\f' && *s != 27)
3531 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3542 const char *tmps = NULL;
3546 SV * const sv = POPs;
3547 if (PL_op->op_flags & OPf_SPECIAL) {
3548 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3550 else if (isGV_with_GP(sv)) {
3551 gv = MUTABLE_GV(sv);
3553 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
3554 gv = MUTABLE_GV(SvRV(sv));
3557 tmps = SvPV_nolen_const(sv);
3561 if( !gv && (!tmps || !*tmps) ) {
3562 HV * const table = GvHVn(PL_envgv);
3565 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3566 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3568 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3573 deprecate("chdir('') or chdir(undef) as chdir()");
3574 tmps = SvPV_nolen_const(*svp);
3578 TAINT_PROPER("chdir");
3583 TAINT_PROPER("chdir");
3586 IO* const io = GvIO(gv);
3589 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3590 } else if (IoIFP(io)) {
3591 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3594 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3595 report_evil_fh(gv, io, PL_op->op_type);
3596 SETERRNO(EBADF, RMS_IFI);
3601 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3602 report_evil_fh(gv, io, PL_op->op_type);
3603 SETERRNO(EBADF,RMS_IFI);
3607 DIE(aTHX_ PL_no_func, "fchdir");
3611 PUSHi( PerlDir_chdir(tmps) >= 0 );
3613 /* Clear the DEFAULT element of ENV so we'll get the new value
3615 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3622 dVAR; dSP; dMARK; dTARGET;
3623 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3634 char * const tmps = POPpx;
3635 TAINT_PROPER("chroot");
3636 PUSHi( chroot(tmps) >= 0 );
3639 DIE(aTHX_ PL_no_func, "chroot");
3647 const char * const tmps2 = POPpconstx;
3648 const char * const tmps = SvPV_nolen_const(TOPs);
3649 TAINT_PROPER("rename");
3651 anum = PerlLIO_rename(tmps, tmps2);
3653 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3654 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3657 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3658 (void)UNLINK(tmps2);
3659 if (!(anum = link(tmps, tmps2)))
3660 anum = UNLINK(tmps);
3668 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3672 const int op_type = PL_op->op_type;
3676 if (op_type == OP_LINK)
3677 DIE(aTHX_ PL_no_func, "link");
3679 # ifndef HAS_SYMLINK
3680 if (op_type == OP_SYMLINK)
3681 DIE(aTHX_ PL_no_func, "symlink");
3685 const char * const tmps2 = POPpconstx;
3686 const char * const tmps = SvPV_nolen_const(TOPs);
3687 TAINT_PROPER(PL_op_desc[op_type]);
3689 # if defined(HAS_LINK)
3690 # if defined(HAS_SYMLINK)
3691 /* Both present - need to choose which. */
3692 (op_type == OP_LINK) ?
3693 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3695 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3696 PerlLIO_link(tmps, tmps2);
3699 # if defined(HAS_SYMLINK)
3700 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3701 symlink(tmps, tmps2);
3706 SETi( result >= 0 );
3713 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3724 char buf[MAXPATHLEN];
3727 #ifndef INCOMPLETE_TAINTS
3731 len = readlink(tmps, buf, sizeof(buf) - 1);
3738 RETSETUNDEF; /* just pretend it's a normal file */
3742 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3744 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3746 char * const save_filename = filename;
3751 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3753 PERL_ARGS_ASSERT_DOONELINER;
3755 Newx(cmdline, size, char);
3756 my_strlcpy(cmdline, cmd, size);
3757 my_strlcat(cmdline, " ", size);
3758 for (s = cmdline + strlen(cmdline); *filename; ) {
3762 if (s - cmdline < size)
3763 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3764 myfp = PerlProc_popen(cmdline, "r");
3768 SV * const tmpsv = sv_newmortal();
3769 /* Need to save/restore 'PL_rs' ?? */
3770 s = sv_gets(tmpsv, myfp, 0);
3771 (void)PerlProc_pclose(myfp);
3775 #ifdef HAS_SYS_ERRLIST
3780 /* you don't see this */
3781 const char * const errmsg =
3782 #ifdef HAS_SYS_ERRLIST
3790 if (instr(s, errmsg)) {
3797 #define EACCES EPERM
3799 if (instr(s, "cannot make"))
3800 SETERRNO(EEXIST,RMS_FEX);
3801 else if (instr(s, "existing file"))
3802 SETERRNO(EEXIST,RMS_FEX);
3803 else if (instr(s, "ile exists"))
3804 SETERRNO(EEXIST,RMS_FEX);
3805 else if (instr(s, "non-exist"))
3806 SETERRNO(ENOENT,RMS_FNF);
3807 else if (instr(s, "does not exist"))
3808 SETERRNO(ENOENT,RMS_FNF);
3809 else if (instr(s, "not empty"))
3810 SETERRNO(EBUSY,SS_DEVOFFLINE);
3811 else if (instr(s, "cannot access"))
3812 SETERRNO(EACCES,RMS_PRV);
3814 SETERRNO(EPERM,RMS_PRV);
3817 else { /* some mkdirs return no failure indication */
3818 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3819 if (PL_op->op_type == OP_RMDIR)
3824 SETERRNO(EACCES,RMS_PRV); /* a guess */
3833 /* This macro removes trailing slashes from a directory name.
3834 * Different operating and file systems take differently to
3835 * trailing slashes. According to POSIX 1003.1 1996 Edition
3836 * any number of trailing slashes should be allowed.
3837 * Thusly we snip them away so that even non-conforming
3838 * systems are happy.
3839 * We should probably do this "filtering" for all
3840 * the functions that expect (potentially) directory names:
3841 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3842 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3844 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3845 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3848 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3849 (tmps) = savepvn((tmps), (len)); \
3859 const int mode = (MAXARG > 1) ? POPi : 0777;
3861 TRIMSLASHES(tmps,len,copy);
3863 TAINT_PROPER("mkdir");
3865 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3869 SETi( dooneliner("mkdir", tmps) );
3870 oldumask = PerlLIO_umask(0);
3871 PerlLIO_umask(oldumask);
3872 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3887 TRIMSLASHES(tmps,len,copy);
3888 TAINT_PROPER("rmdir");
3890 SETi( PerlDir_rmdir(tmps) >= 0 );
3892 SETi( dooneliner("rmdir", tmps) );
3899 /* Directory calls. */
3903 #if defined(Direntry_t) && defined(HAS_READDIR)
3905 const char * const dirname = POPpconstx;
3906 GV * const gv = MUTABLE_GV(POPs);
3907 register IO * const io = GvIOn(gv);
3912 if ((IoIFP(io) || IoOFP(io)))
3913 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3914 "Opening filehandle %s also as a directory",
3917 PerlDir_close(IoDIRP(io));
3918 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3924 SETERRNO(EBADF,RMS_DIR);
3927 DIE(aTHX_ PL_no_dir_func, "opendir");
3933 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3934 DIE(aTHX_ PL_no_dir_func, "readdir");
3936 #if !defined(I_DIRENT) && !defined(VMS)
3937 Direntry_t *readdir (DIR *);
3943 const I32 gimme = GIMME;
3944 GV * const gv = MUTABLE_GV(POPs);
3945 register const Direntry_t *dp;
3946 register IO * const io = GvIOn(gv);
3948 if (!io || !IoDIRP(io)) {
3949 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3950 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3955 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3959 sv = newSVpvn(dp->d_name, dp->d_namlen);
3961 sv = newSVpv(dp->d_name, 0);
3963 #ifndef INCOMPLETE_TAINTS
3964 if (!(IoFLAGS(io) & IOf_UNTAINT))
3968 } while (gimme == G_ARRAY);
3970 if (!dp && gimme != G_ARRAY)
3977 SETERRNO(EBADF,RMS_ISI);
3978 if (GIMME == G_ARRAY)
3987 #if defined(HAS_TELLDIR) || defined(telldir)
3989 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3990 /* XXX netbsd still seemed to.
3991 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3992 --JHI 1999-Feb-02 */
3993 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3994 long telldir (DIR *);
3996 GV * const gv = MUTABLE_GV(POPs);
3997 register IO * const io = GvIOn(gv);
3999 if (!io || !IoDIRP(io)) {
4000 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4001 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
4005 PUSHi( PerlDir_tell(IoDIRP(io)) );
4009 SETERRNO(EBADF,RMS_ISI);
4012 DIE(aTHX_ PL_no_dir_func, "telldir");
4018 #if defined(HAS_SEEKDIR) || defined(seekdir)
4020 const long along = POPl;
4021 GV * const gv = MUTABLE_GV(POPs);
4022 register IO * const io = GvIOn(gv);
4024 if (!io || !IoDIRP(io)) {
4025 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4026 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
4029 (void)PerlDir_seek(IoDIRP(io), along);
4034 SETERRNO(EBADF,RMS_ISI);
4037 DIE(aTHX_ PL_no_dir_func, "seekdir");
4043 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4045 GV * const gv = MUTABLE_GV(POPs);
4046 register IO * const io = GvIOn(gv);
4048 if (!io || !IoDIRP(io)) {
4049 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4050 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
4053 (void)PerlDir_rewind(IoDIRP(io));
4057 SETERRNO(EBADF,RMS_ISI);
4060 DIE(aTHX_ PL_no_dir_func, "rewinddir");
4066 #if defined(Direntry_t) && defined(HAS_READDIR)
4068 GV * const gv = MUTABLE_GV(POPs);
4069 register IO * const io = GvIOn(gv);
4071 if (!io || !IoDIRP(io)) {
4072 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4073 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
4076 #ifdef VOID_CLOSEDIR
4077 PerlDir_close(IoDIRP(io));
4079 if (PerlDir_close(IoDIRP(io)) < 0) {
4080 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4089 SETERRNO(EBADF,RMS_IFI);
4092 DIE(aTHX_ PL_no_dir_func, "closedir");
4096 /* Process control. */
4105 PERL_FLUSHALL_FOR_CHILD;
4106 childpid = PerlProc_fork();
4110 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
4112 SvREADONLY_off(GvSV(tmpgv));
4113 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4114 SvREADONLY_on(GvSV(tmpgv));
4116 #ifdef THREADS_HAVE_PIDS
4117 PL_ppid = (IV)getppid();
4119 #ifdef PERL_USES_PL_PIDSTATUS
4120 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4126 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4131 PERL_FLUSHALL_FOR_CHILD;
4132 childpid = PerlProc_fork();
4138 DIE(aTHX_ PL_no_func, "fork");
4145 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4150 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4151 childpid = wait4pid(-1, &argflags, 0);
4153 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4158 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4159 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4160 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4162 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4167 DIE(aTHX_ PL_no_func, "wait");
4173 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4175 const int optype = POPi;
4176 const Pid_t pid = TOPi;
4180 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4181 result = wait4pid(pid, &argflags, optype);
4183 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4188 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4189 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4190 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4192 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4197 DIE(aTHX_ PL_no_func, "waitpid");
4203 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4204 #if defined(__LIBCATAMOUNT__)
4205 PL_statusvalue = -1;
4214 while (++MARK <= SP) {
4215 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4220 TAINT_PROPER("system");
4222 PERL_FLUSHALL_FOR_CHILD;
4223 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4229 if (PerlProc_pipe(pp) >= 0)
4231 while ((childpid = PerlProc_fork()) == -1) {
4232 if (errno != EAGAIN) {
4237 PerlLIO_close(pp[0]);
4238 PerlLIO_close(pp[1]);
4245 Sigsave_t ihand,qhand; /* place to save signals during system() */
4249 PerlLIO_close(pp[1]);
4251 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4252 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4255 result = wait4pid(childpid, &status, 0);
4256 } while (result == -1 && errno == EINTR);
4258 (void)rsignal_restore(SIGINT, &ihand);
4259 (void)rsignal_restore(SIGQUIT, &qhand);
4261 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4262 do_execfree(); /* free any memory child malloced on fork */
4269 while (n < sizeof(int)) {
4270 n1 = PerlLIO_read(pp[0],
4271 (void*)(((char*)&errkid)+n),
4277 PerlLIO_close(pp[0]);
4278 if (n) { /* Error */
4279 if (n != sizeof(int))
4280 DIE(aTHX_ "panic: kid popen errno read");
4281 errno = errkid; /* Propagate errno from kid */
4282 STATUS_NATIVE_CHILD_SET(-1);
4285 XPUSHi(STATUS_CURRENT);
4289 PerlLIO_close(pp[0]);
4290 #if defined(HAS_FCNTL) && defined(F_SETFD)
4291 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4294 if (PL_op->op_flags & OPf_STACKED) {
4295 SV * const really = *++MARK;
4296 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4298 else if (SP - MARK != 1)
4299 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4301 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4305 #else /* ! FORK or VMS or OS/2 */
4308 if (PL_op->op_flags & OPf_STACKED) {
4309 SV * const really = *++MARK;
4310 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4311 value = (I32)do_aspawn(really, MARK, SP);
4313 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4316 else if (SP - MARK != 1) {
4317 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4318 value = (I32)do_aspawn(NULL, MARK, SP);
4320 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4324 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4326 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4328 STATUS_NATIVE_CHILD_SET(value);
4331 XPUSHi(result ? value : STATUS_CURRENT);
4332 #endif /* !FORK or VMS or OS/2 */
4339 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4344 while (++MARK <= SP) {
4345 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4350 TAINT_PROPER("exec");
4352 PERL_FLUSHALL_FOR_CHILD;
4353 if (PL_op->op_flags & OPf_STACKED) {
4354 SV * const really = *++MARK;
4355 value = (I32)do_aexec(really, MARK, SP);
4357 else if (SP - MARK != 1)
4359 value = (I32)vms_do_aexec(NULL, MARK, SP);
4363 (void ) do_aspawn(NULL, MARK, SP);
4367 value = (I32)do_aexec(NULL, MARK, SP);
4372 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4375 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4378 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4392 # ifdef THREADS_HAVE_PIDS
4393 if (PL_ppid != 1 && getppid() == 1)
4394 /* maybe the parent process has died. Refresh ppid cache */
4398 XPUSHi( getppid() );
4402 DIE(aTHX_ PL_no_func, "getppid");
4411 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4414 pgrp = (I32)BSD_GETPGRP(pid);
4416 if (pid != 0 && pid != PerlProc_getpid())
4417 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4423 DIE(aTHX_ PL_no_func, "getpgrp()");
4443 TAINT_PROPER("setpgrp");
4445 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4447 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4448 || (pid != 0 && pid != PerlProc_getpid()))
4450 DIE(aTHX_ "setpgrp can't take arguments");
4452 SETi( setpgrp() >= 0 );
4453 #endif /* USE_BSDPGRP */
4456 DIE(aTHX_ PL_no_func, "setpgrp()");
4461 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4463 # define PRIORITY_WHICH_T(which) which
4468 #ifdef HAS_GETPRIORITY
4470 const int who = POPi;
4471 const int which = TOPi;
4472 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4475 DIE(aTHX_ PL_no_func, "getpriority()");
4481 #ifdef HAS_SETPRIORITY
4483 const int niceval = POPi;
4484 const int who = POPi;
4485 const int which = TOPi;
4486 TAINT_PROPER("setpriority");
4487 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4490 DIE(aTHX_ PL_no_func, "setpriority()");
4494 #undef PRIORITY_WHICH_T
4502 XPUSHn( time(NULL) );
4504 XPUSHi( time(NULL) );
4516 (void)PerlProc_times(&PL_timesbuf);
4518 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4519 /* struct tms, though same data */
4523 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4524 if (GIMME == G_ARRAY) {
4525 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4526 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4527 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4535 if (GIMME == G_ARRAY) {
4542 DIE(aTHX_ "times not implemented");
4544 #endif /* HAS_TIMES */
4547 /* The 32 bit int year limits the times we can represent to these
4548 boundaries with a few days wiggle room to account for time zone
4551 /* Sat Jan 3 00:00:00 -2147481748 */
4552 #define TIME_LOWER_BOUND -67768100567755200.0
4553 /* Sun Dec 29 12:00:00 2147483647 */
4554 #define TIME_UPPER_BOUND 67767976233316800.0
4563 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4564 static const char * const dayname[] =
4565 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4566 static const char * const monname[] =
4567 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4568 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4573 when = (Time64_T)now;
4576 NV input = Perl_floor(POPn);
4577 when = (Time64_T)input;
4578 if (when != input) {
4579 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4580 "%s(%.0" NVff ") too large", opname, input);
4584 if ( TIME_LOWER_BOUND > when ) {
4585 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4586 "%s(%.0" NVff ") too small", opname, when);
4589 else if( when > TIME_UPPER_BOUND ) {
4590 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4591 "%s(%.0" NVff ") too large", opname, when);
4595 if (PL_op->op_type == OP_LOCALTIME)
4596 err = S_localtime64_r(&when, &tmbuf);
4598 err = S_gmtime64_r(&when, &tmbuf);
4602 /* XXX %lld broken for quads */
4603 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4604 "%s(%.0" NVff ") failed", opname, when);
4607 if (GIMME != G_ARRAY) { /* scalar context */
4609 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4610 double year = (double)tmbuf.tm_year + 1900;
4617 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4618 dayname[tmbuf.tm_wday],
4619 monname[tmbuf.tm_mon],
4627 else { /* list context */
4633 mPUSHi(tmbuf.tm_sec);
4634 mPUSHi(tmbuf.tm_min);
4635 mPUSHi(tmbuf.tm_hour);
4636 mPUSHi(tmbuf.tm_mday);
4637 mPUSHi(tmbuf.tm_mon);
4638 mPUSHn(tmbuf.tm_year);
4639 mPUSHi(tmbuf.tm_wday);
4640 mPUSHi(tmbuf.tm_yday);
4641 mPUSHi(tmbuf.tm_isdst);
4652 anum = alarm((unsigned int)anum);
4658 DIE(aTHX_ PL_no_func, "alarm");
4669 (void)time(&lasttime);
4674 PerlProc_sleep((unsigned int)duration);
4677 XPUSHi(when - lasttime);
4681 /* Shared memory. */
4682 /* Merged with some message passing. */
4686 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4687 dVAR; dSP; dMARK; dTARGET;
4688 const int op_type = PL_op->op_type;
4693 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4696 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4699 value = (I32)(do_semop(MARK, SP) >= 0);
4702 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4718 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4719 dVAR; dSP; dMARK; dTARGET;
4720 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4727 DIE(aTHX_ "System V IPC is not implemented on this machine");
4733 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4734 dVAR; dSP; dMARK; dTARGET;
4735 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4743 PUSHp(zero_but_true, ZBTLEN);
4751 /* I can't const this further without getting warnings about the types of
4752 various arrays passed in from structures. */
4754 S_space_join_names_mortal(pTHX_ char *const *array)
4758 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4760 if (array && *array) {
4761 target = newSVpvs_flags("", SVs_TEMP);
4763 sv_catpv(target, *array);
4766 sv_catpvs(target, " ");
4769 target = sv_mortalcopy(&PL_sv_no);
4774 /* Get system info. */
4778 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4780 I32 which = PL_op->op_type;
4781 register char **elem;
4783 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4784 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4785 struct hostent *gethostbyname(Netdb_name_t);
4786 struct hostent *gethostent(void);
4788 struct hostent *hent = NULL;
4792 if (which == OP_GHBYNAME) {
4793 #ifdef HAS_GETHOSTBYNAME
4794 const char* const name = POPpbytex;
4795 hent = PerlSock_gethostbyname(name);
4797 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4800 else if (which == OP_GHBYADDR) {
4801 #ifdef HAS_GETHOSTBYADDR
4802 const int addrtype = POPi;
4803 SV * const addrsv = POPs;
4805 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4807 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4809 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4813 #ifdef HAS_GETHOSTENT
4814 hent = PerlSock_gethostent();
4816 DIE(aTHX_ PL_no_sock_func, "gethostent");
4819 #ifdef HOST_NOT_FOUND
4821 #ifdef USE_REENTRANT_API
4822 # ifdef USE_GETHOSTENT_ERRNO
4823 h_errno = PL_reentrant_buffer->_gethostent_errno;
4826 STATUS_UNIX_SET(h_errno);
4830 if (GIMME != G_ARRAY) {
4831 PUSHs(sv = sv_newmortal());
4833 if (which == OP_GHBYNAME) {
4835 sv_setpvn(sv, hent->h_addr, hent->h_length);
4838 sv_setpv(sv, (char*)hent->h_name);
4844 mPUSHs(newSVpv((char*)hent->h_name, 0));
4845 PUSHs(space_join_names_mortal(hent->h_aliases));
4846 mPUSHi(hent->h_addrtype);
4847 len = hent->h_length;
4850 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4851 mXPUSHp(*elem, len);
4855 mPUSHp(hent->h_addr, len);
4857 PUSHs(sv_mortalcopy(&PL_sv_no));
4862 DIE(aTHX_ PL_no_sock_func, "gethostent");
4868 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4870 I32 which = PL_op->op_type;
4872 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4873 struct netent *getnetbyaddr(Netdb_net_t, int);
4874 struct netent *getnetbyname(Netdb_name_t);
4875 struct netent *getnetent(void);
4877 struct netent *nent;
4879 if (which == OP_GNBYNAME){
4880 #ifdef HAS_GETNETBYNAME
4881 const char * const name = POPpbytex;
4882 nent = PerlSock_getnetbyname(name);
4884 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4887 else if (which == OP_GNBYADDR) {
4888 #ifdef HAS_GETNETBYADDR
4889 const int addrtype = POPi;
4890 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4891 nent = PerlSock_getnetbyaddr(addr, addrtype);
4893 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4897 #ifdef HAS_GETNETENT
4898 nent = PerlSock_getnetent();
4900 DIE(aTHX_ PL_no_sock_func, "getnetent");
4903 #ifdef HOST_NOT_FOUND
4905 #ifdef USE_REENTRANT_API
4906 # ifdef USE_GETNETENT_ERRNO
4907 h_errno = PL_reentrant_buffer->_getnetent_errno;
4910 STATUS_UNIX_SET(h_errno);
4915 if (GIMME != G_ARRAY) {
4916 PUSHs(sv = sv_newmortal());
4918 if (which == OP_GNBYNAME)
4919 sv_setiv(sv, (IV)nent->n_net);
4921 sv_setpv(sv, nent->n_name);
4927 mPUSHs(newSVpv(nent->n_name, 0));
4928 PUSHs(space_join_names_mortal(nent->n_aliases));
4929 mPUSHi(nent->n_addrtype);
4930 mPUSHi(nent->n_net);
4935 DIE(aTHX_ PL_no_sock_func, "getnetent");
4941 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4943 I32 which = PL_op->op_type;
4945 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4946 struct protoent *getprotobyname(Netdb_name_t);
4947 struct protoent *getprotobynumber(int);
4948 struct protoent *getprotoent(void);
4950 struct protoent *pent;
4952 if (which == OP_GPBYNAME) {
4953 #ifdef HAS_GETPROTOBYNAME
4954 const char* const name = POPpbytex;
4955 pent = PerlSock_getprotobyname(name);
4957 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4960 else if (which == OP_GPBYNUMBER) {
4961 #ifdef HAS_GETPROTOBYNUMBER
4962 const int number = POPi;
4963 pent = PerlSock_getprotobynumber(number);
4965 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4969 #ifdef HAS_GETPROTOENT
4970 pent = PerlSock_getprotoent();
4972 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4976 if (GIMME != G_ARRAY) {
4977 PUSHs(sv = sv_newmortal());
4979 if (which == OP_GPBYNAME)
4980 sv_setiv(sv, (IV)pent->p_proto);
4982 sv_setpv(sv, pent->p_name);
4988 mPUSHs(newSVpv(pent->p_name, 0));
4989 PUSHs(space_join_names_mortal(pent->p_aliases));
4990 mPUSHi(pent->p_proto);
4995 DIE(aTHX_ PL_no_sock_func, "getprotoent");
5001 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
5003 I32 which = PL_op->op_type;
5005 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
5006 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
5007 struct servent *getservbyport(int, Netdb_name_t);
5008 struct servent *getservent(void);
5010 struct servent *sent;
5012 if (which == OP_GSBYNAME) {
5013 #ifdef HAS_GETSERVBYNAME
5014 const char * const proto = POPpbytex;
5015 const char * const name = POPpbytex;
5016 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5018 DIE(aTHX_ PL_no_sock_func, "getservbyname");
5021 else if (which == OP_GSBYPORT) {
5022 #ifdef HAS_GETSERVBYPORT
5023 const char * const proto = POPpbytex;
5024 unsigned short port = (unsigned short)POPu;
5026 port = PerlSock_htons(port);
5028 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5030 DIE(aTHX_ PL_no_sock_func, "getservbyport");
5034 #ifdef HAS_GETSERVENT
5035 sent = PerlSock_getservent();
5037 DIE(aTHX_ PL_no_sock_func, "getservent");
5041 if (GIMME != G_ARRAY) {
5042 PUSHs(sv = sv_newmortal());
5044 if (which == OP_GSBYNAME) {
5046 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5048 sv_setiv(sv, (IV)(sent->s_port));
5052 sv_setpv(sv, sent->s_name);
5058 mPUSHs(newSVpv(sent->s_name, 0));
5059 PUSHs(space_join_names_mortal(sent->s_aliases));
5061 mPUSHi(PerlSock_ntohs(sent->s_port));
5063 mPUSHi(sent->s_port);
5065 mPUSHs(newSVpv(sent->s_proto, 0));
5070 DIE(aTHX_ PL_no_sock_func, "getservent");
5076 #ifdef HAS_SETHOSTENT
5078 PerlSock_sethostent(TOPi);
5081 DIE(aTHX_ PL_no_sock_func, "sethostent");
5087 #ifdef HAS_SETNETENT
5089 (void)PerlSock_setnetent(TOPi);
5092 DIE(aTHX_ PL_no_sock_func, "setnetent");
5098 #ifdef HAS_SETPROTOENT
5100 (void)PerlSock_setprotoent(TOPi);
5103 DIE(aTHX_ PL_no_sock_func, "setprotoent");
5109 #ifdef HAS_SETSERVENT
5111 (void)PerlSock_setservent(TOPi);
5114 DIE(aTHX_ PL_no_sock_func, "setservent");
5120 #ifdef HAS_ENDHOSTENT
5122 PerlSock_endhostent();
5126 DIE(aTHX_ PL_no_sock_func, "endhostent");
5132 #ifdef HAS_ENDNETENT
5134 PerlSock_endnetent();
5138 DIE(aTHX_ PL_no_sock_func, "endnetent");
5144 #ifdef HAS_ENDPROTOENT
5146 PerlSock_endprotoent();
5150 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5156 #ifdef HAS_ENDSERVENT
5158 PerlSock_endservent();
5162 DIE(aTHX_ PL_no_sock_func, "endservent");
5170 I32 which = PL_op->op_type;
5172 struct passwd *pwent = NULL;
5174 * We currently support only the SysV getsp* shadow password interface.
5175 * The interface is declared in <shadow.h> and often one needs to link
5176 * with -lsecurity or some such.
5177 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5180 * AIX getpwnam() is clever enough to return the encrypted password
5181 * only if the caller (euid?) is root.
5183 * There are at least three other shadow password APIs. Many platforms
5184 * seem to contain more than one interface for accessing the shadow
5185 * password databases, possibly for compatibility reasons.
5186 * The getsp*() is by far he simplest one, the other two interfaces
5187 * are much more complicated, but also very similar to each other.
5192 * struct pr_passwd *getprpw*();
5193 * The password is in
5194 * char getprpw*(...).ufld.fd_encrypt[]
5195 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5200 * struct es_passwd *getespw*();
5201 * The password is in
5202 * char *(getespw*(...).ufld.fd_encrypt)
5203 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5206 * struct userpw *getuserpw();
5207 * The password is in
5208 * char *(getuserpw(...)).spw_upw_passwd
5209 * (but the de facto standard getpwnam() should work okay)
5211 * Mention I_PROT here so that Configure probes for it.
5213 * In HP-UX for getprpw*() the manual page claims that one should include
5214 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5215 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5216 * and pp_sys.c already includes <shadow.h> if there is such.
5218 * Note that <sys/security.h> is already probed for, but currently
5219 * it is only included in special cases.
5221 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5222 * be preferred interface, even though also the getprpw*() interface
5223 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5224 * One also needs to call set_auth_parameters() in main() before
5225 * doing anything else, whether one is using getespw*() or getprpw*().
5227 * Note that accessing the shadow databases can be magnitudes
5228 * slower than accessing the standard databases.
5233 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5234 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5235 * the pw_comment is left uninitialized. */
5236 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5242 const char* const name = POPpbytex;
5243 pwent = getpwnam(name);
5249 pwent = getpwuid(uid);
5253 # ifdef HAS_GETPWENT
5255 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5256 if (pwent) pwent = getpwnam(pwent->pw_name);
5259 DIE(aTHX_ PL_no_func, "getpwent");
5265 if (GIMME != G_ARRAY) {
5266 PUSHs(sv = sv_newmortal());
5268 if (which == OP_GPWNAM)
5269 # if Uid_t_sign <= 0
5270 sv_setiv(sv, (IV)pwent->pw_uid);
5272 sv_setuv(sv, (UV)pwent->pw_uid);
5275 sv_setpv(sv, pwent->pw_name);
5281 mPUSHs(newSVpv(pwent->pw_name, 0));
5285 /* If we have getspnam(), we try to dig up the shadow
5286 * password. If we are underprivileged, the shadow
5287 * interface will set the errno to EACCES or similar,
5288 * and return a null pointer. If this happens, we will
5289 * use the dummy password (usually "*" or "x") from the
5290 * standard password database.
5292 * In theory we could skip the shadow call completely
5293 * if euid != 0 but in practice we cannot know which
5294 * security measures are guarding the shadow databases
5295 * on a random platform.
5297 * Resist the urge to use additional shadow interfaces.
5298 * Divert the urge to writing an extension instead.
5301 /* Some AIX setups falsely(?) detect some getspnam(), which
5302 * has a different API than the Solaris/IRIX one. */
5303 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5306 const struct spwd * const spwent = getspnam(pwent->pw_name);
5307 /* Save and restore errno so that
5308 * underprivileged attempts seem
5309 * to have never made the unsccessful
5310 * attempt to retrieve the shadow password. */
5312 if (spwent && spwent->sp_pwdp)
5313 sv_setpv(sv, spwent->sp_pwdp);
5317 if (!SvPOK(sv)) /* Use the standard password, then. */
5318 sv_setpv(sv, pwent->pw_passwd);
5321 # ifndef INCOMPLETE_TAINTS
5322 /* passwd is tainted because user himself can diddle with it.
5323 * admittedly not much and in a very limited way, but nevertheless. */
5327 # if Uid_t_sign <= 0
5328 mPUSHi(pwent->pw_uid);
5330 mPUSHu(pwent->pw_uid);
5333 # if Uid_t_sign <= 0
5334 mPUSHi(pwent->pw_gid);
5336 mPUSHu(pwent->pw_gid);
5338 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5339 * because of the poor interface of the Perl getpw*(),
5340 * not because there's some standard/convention saying so.
5341 * A better interface would have been to return a hash,
5342 * but we are accursed by our history, alas. --jhi. */
5344 mPUSHi(pwent->pw_change);
5347 mPUSHi(pwent->pw_quota);
5350 mPUSHs(newSVpv(pwent->pw_age, 0));
5352 /* I think that you can never get this compiled, but just in case. */
5353 PUSHs(sv_mortalcopy(&PL_sv_no));
5358 /* pw_class and pw_comment are mutually exclusive--.
5359 * see the above note for pw_change, pw_quota, and pw_age. */
5361 mPUSHs(newSVpv(pwent->pw_class, 0));
5364 mPUSHs(newSVpv(pwent->pw_comment, 0));
5366 /* I think that you can never get this compiled, but just in case. */
5367 PUSHs(sv_mortalcopy(&PL_sv_no));
5372 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5374 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5376 # ifndef INCOMPLETE_TAINTS
5377 /* pw_gecos is tainted because user himself can diddle with it. */
5381 mPUSHs(newSVpv(pwent->pw_dir, 0));
5383 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5384 # ifndef INCOMPLETE_TAINTS
5385 /* pw_shell is tainted because user himself can diddle with it. */
5390 mPUSHi(pwent->pw_expire);
5395 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5401 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5406 DIE(aTHX_ PL_no_func, "setpwent");
5412 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5417 DIE(aTHX_ PL_no_func, "endpwent");
5425 const I32 which = PL_op->op_type;
5426 const struct group *grent;
5428 if (which == OP_GGRNAM) {
5429 const char* const name = POPpbytex;
5430 grent = (const struct group *)getgrnam(name);
5432 else if (which == OP_GGRGID) {
5433 const Gid_t gid = POPi;
5434 grent = (const struct group *)getgrgid(gid);
5438 grent = (struct group *)getgrent();
5440 DIE(aTHX_ PL_no_func, "getgrent");
5444 if (GIMME != G_ARRAY) {
5445 SV * const sv = sv_newmortal();
5449 if (which == OP_GGRNAM)
5451 sv_setiv(sv, (IV)grent->gr_gid);
5453 sv_setuv(sv, (UV)grent->gr_gid);
5456 sv_setpv(sv, grent->gr_name);
5462 mPUSHs(newSVpv(grent->gr_name, 0));
5465 mPUSHs(newSVpv(grent->gr_passwd, 0));
5467 PUSHs(sv_mortalcopy(&PL_sv_no));
5471 mPUSHi(grent->gr_gid);
5473 mPUSHu(grent->gr_gid);
5476 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5477 /* In UNICOS/mk (_CRAYMPP) the multithreading
5478 * versions (getgrnam_r, getgrgid_r)
5479 * seem to return an illegal pointer
5480 * as the group members list, gr_mem.
5481 * getgrent() doesn't even have a _r version
5482 * but the gr_mem is poisonous anyway.
5483 * So yes, you cannot get the list of group
5484 * members if building multithreaded in UNICOS/mk. */
5485 PUSHs(space_join_names_mortal(grent->gr_mem));
5491 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5497 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5502 DIE(aTHX_ PL_no_func, "setgrent");
5508 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5513 DIE(aTHX_ PL_no_func, "endgrent");
5523 if (!(tmps = PerlProc_getlogin()))
5525 sv_setpv_mg(TARG, tmps);
5529 DIE(aTHX_ PL_no_func, "getlogin");
5533 /* Miscellaneous. */
5538 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5539 register I32 items = SP - MARK;
5540 unsigned long a[20];
5545 while (++MARK <= SP) {
5546 if (SvTAINTED(*MARK)) {
5552 TAINT_PROPER("syscall");
5555 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5556 * or where sizeof(long) != sizeof(char*). But such machines will
5557 * not likely have syscall implemented either, so who cares?
5559 while (++MARK <= SP) {
5560 if (SvNIOK(*MARK) || !i)
5561 a[i++] = SvIV(*MARK);
5562 else if (*MARK == &PL_sv_undef)
5565 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5571 DIE(aTHX_ "Too many args to syscall");
5573 DIE(aTHX_ "Too few args to syscall");
5575 retval = syscall(a[0]);
5578 retval = syscall(a[0],a[1]);
5581 retval = syscall(a[0],a[1],a[2]);
5584 retval = syscall(a[0],a[1],a[2],a[3]);
5587 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5590 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5593 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5596 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5600 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5603 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5606 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5610 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5614 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5618 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5619 a[10],a[11],a[12],a[13]);
5621 #endif /* atarist */
5627 DIE(aTHX_ PL_no_func, "syscall");
5631 #ifdef FCNTL_EMULATE_FLOCK
5633 /* XXX Emulate flock() with fcntl().
5634 What's really needed is a good file locking module.
5638 fcntl_emulate_flock(int fd, int operation)
5643 switch (operation & ~LOCK_NB) {
5645 flock.l_type = F_RDLCK;
5648 flock.l_type = F_WRLCK;
5651 flock.l_type = F_UNLCK;
5657 flock.l_whence = SEEK_SET;
5658 flock.l_start = flock.l_len = (Off_t)0;
5660 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5661 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5662 errno = EWOULDBLOCK;
5666 #endif /* FCNTL_EMULATE_FLOCK */
5668 #ifdef LOCKF_EMULATE_FLOCK
5670 /* XXX Emulate flock() with lockf(). This is just to increase
5671 portability of scripts. The calls are not completely
5672 interchangeable. What's really needed is a good file
5676 /* The lockf() constants might have been defined in <unistd.h>.
5677 Unfortunately, <unistd.h> causes troubles on some mixed
5678 (BSD/POSIX) systems, such as SunOS 4.1.3.
5680 Further, the lockf() constants aren't POSIX, so they might not be
5681 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5682 just stick in the SVID values and be done with it. Sigh.
5686 # define F_ULOCK 0 /* Unlock a previously locked region */
5689 # define F_LOCK 1 /* Lock a region for exclusive use */
5692 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5695 # define F_TEST 3 /* Test a region for other processes locks */
5699 lockf_emulate_flock(int fd, int operation)
5705 /* flock locks entire file so for lockf we need to do the same */
5706 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5707 if (pos > 0) /* is seekable and needs to be repositioned */
5708 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5709 pos = -1; /* seek failed, so don't seek back afterwards */
5712 switch (operation) {
5714 /* LOCK_SH - get a shared lock */
5716 /* LOCK_EX - get an exclusive lock */
5718 i = lockf (fd, F_LOCK, 0);
5721 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5722 case LOCK_SH|LOCK_NB:
5723 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5724 case LOCK_EX|LOCK_NB:
5725 i = lockf (fd, F_TLOCK, 0);
5727 if ((errno == EAGAIN) || (errno == EACCES))
5728 errno = EWOULDBLOCK;
5731 /* LOCK_UN - unlock (non-blocking is a no-op) */
5733 case LOCK_UN|LOCK_NB:
5734 i = lockf (fd, F_ULOCK, 0);
5737 /* Default - can't decipher operation */
5744 if (pos > 0) /* need to restore position of the handle */
5745 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5750 #endif /* LOCKF_EMULATE_FLOCK */
5754 * c-indentation-style: bsd
5756 * indent-tabs-mode: t
5759 * ex: set ts=8 sts=4 sw=4 noet: