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);
507 GV * const gv = MUTABLE_GV(*++MARK);
510 DIE(aTHX_ PL_no_usym, "filehandle");
512 if ((io = GvIOp(gv))) {
514 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
517 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
518 "Opening dirhandle %s also as a file",
521 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
523 /* Method's args are same as ours ... */
524 /* ... except handle is replaced by the object */
525 *MARK-- = SvTIED_obj(MUTABLE_SV(io), mg);
528 ENTER_with_name("call_OPEN");
529 call_method("OPEN", G_SCALAR);
530 LEAVE_with_name("call_OPEN");
543 tmps = SvPV_const(sv, len);
544 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
547 PUSHi( (I32)PL_forkprocess );
548 else if (PL_forkprocess == 0) /* we are a new child */
555 /* These are private to this function, which is private to this file.
556 Use 0x04 rather than the next available bit, to help the compiler if the
557 architecture can generate more efficient instructions. */
558 #define MORTALIZE_NOT_NEEDED 0x04
559 #define TIED_HANDLE_ARGC_SHIFT 3
562 S_tied_handle_method(pTHX_ const char *const methname, SV **sp,
563 IO *const io, MAGIC *const mg, const U32 flags, ...)
565 U32 argc = flags >> TIED_HANDLE_ARGC_SHIFT;
567 PERL_ARGS_ASSERT_TIED_HANDLE_METHOD;
569 /* Ensure that our flag bits do not overlap. */
570 assert((MORTALIZE_NOT_NEEDED & G_WANT) == 0);
571 assert((G_WANT >> TIED_HANDLE_ARGC_SHIFT) == 0);
574 PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
576 const U32 mortalize_not_needed = flags & MORTALIZE_NOT_NEEDED;
578 va_start(args, flags);
580 SV *const arg = va_arg(args, SV *);
581 if(mortalize_not_needed)
590 ENTER_with_name("call_tied_handle_method");
591 call_method(methname, flags & G_WANT);
592 LEAVE_with_name("call_tied_handle_method");
596 #define tied_handle_method(a,b,c,d) \
597 S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR)
598 #define tied_handle_method1(a,b,c,d,e) \
599 S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR | (1 << TIED_HANDLE_ARGC_SHIFT),e)
600 #define tied_handle_method2(a,b,c,d,e,f) \
601 S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR | (2 << TIED_HANDLE_ARGC_SHIFT), e,f)
606 GV * const gv = (MAXARG == 0) ? PL_defoutgv : MUTABLE_GV(POPs);
612 IO * const io = GvIO(gv);
614 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
616 return tied_handle_method("CLOSE", SP, io, mg);
620 PUSHs(boolSV(do_close(gv, TRUE)));
633 GV * const wgv = MUTABLE_GV(POPs);
634 GV * const rgv = MUTABLE_GV(POPs);
639 if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
640 DIE(aTHX_ PL_no_usym, "filehandle");
645 do_close(rgv, FALSE);
647 do_close(wgv, FALSE);
649 if (PerlProc_pipe(fd) < 0)
652 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
653 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
654 IoOFP(rstio) = IoIFP(rstio);
655 IoIFP(wstio) = IoOFP(wstio);
656 IoTYPE(rstio) = IoTYPE_RDONLY;
657 IoTYPE(wstio) = IoTYPE_WRONLY;
659 if (!IoIFP(rstio) || !IoOFP(wstio)) {
661 PerlIO_close(IoIFP(rstio));
663 PerlLIO_close(fd[0]);
665 PerlIO_close(IoOFP(wstio));
667 PerlLIO_close(fd[1]);
670 #if defined(HAS_FCNTL) && defined(F_SETFD)
671 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
672 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
679 DIE(aTHX_ PL_no_func, "pipe");
694 gv = MUTABLE_GV(POPs);
696 if (gv && (io = GvIO(gv))
697 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
699 return tied_handle_method("FILENO", SP, io, mg);
702 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
703 /* Can't do this because people seem to do things like
704 defined(fileno($foo)) to check whether $foo is a valid fh.
705 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
706 report_evil_fh(gv, io, PL_op->op_type);
711 PUSHi(PerlIO_fileno(fp));
724 anum = PerlLIO_umask(022);
725 /* setting it to 022 between the two calls to umask avoids
726 * to have a window where the umask is set to 0 -- meaning
727 * that another thread could create world-writeable files. */
729 (void)PerlLIO_umask(anum);
732 anum = PerlLIO_umask(POPi);
733 TAINT_PROPER("umask");
736 /* Only DIE if trying to restrict permissions on "user" (self).
737 * Otherwise it's harmless and more useful to just return undef
738 * since 'group' and 'other' concepts probably don't exist here. */
739 if (MAXARG >= 1 && (POPi & 0700))
740 DIE(aTHX_ "umask not implemented");
741 XPUSHs(&PL_sv_undef);
760 gv = MUTABLE_GV(POPs);
762 if (gv && (io = GvIO(gv))) {
763 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
765 /* This takes advantage of the implementation of the varargs
766 function, which I don't think that the optimiser will be able to
767 figure out. Although, as it's a static function, in theory it
769 return S_tied_handle_method(aTHX_ "BINMODE", SP, io, mg,
770 G_SCALAR|MORTALIZE_NOT_NEEDED
772 ? (1 << TIED_HANDLE_ARGC_SHIFT) : 0),
777 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
778 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
779 report_evil_fh(gv, io, PL_op->op_type);
780 SETERRNO(EBADF,RMS_IFI);
787 const char *d = NULL;
790 d = SvPV_const(discp, len);
791 mode = mode_from_discipline(d, len);
792 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
793 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
794 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
815 const I32 markoff = MARK - PL_stack_base;
816 const char *methname;
817 int how = PERL_MAGIC_tied;
821 switch(SvTYPE(varsv)) {
823 methname = "TIEHASH";
824 HvEITER_set(MUTABLE_HV(varsv), 0);
827 methname = "TIEARRAY";
830 if (isGV_with_GP(varsv)) {
831 methname = "TIEHANDLE";
832 how = PERL_MAGIC_tiedscalar;
833 /* For tied filehandles, we apply tiedscalar magic to the IO
834 slot of the GP rather than the GV itself. AMS 20010812 */
836 GvIOp(varsv) = newIO();
837 varsv = MUTABLE_SV(GvIOp(varsv));
842 methname = "TIESCALAR";
843 how = PERL_MAGIC_tiedscalar;
847 if (sv_isobject(*MARK)) { /* Calls GET magic. */
848 ENTER_with_name("call_TIE");
849 PUSHSTACKi(PERLSI_MAGIC);
851 EXTEND(SP,(I32)items);
855 call_method(methname, G_SCALAR);
858 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
859 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
860 * wrong error message, and worse case, supreme action at a distance.
861 * (Sorry obfuscation writers. You're not going to be given this one.)
864 const char *name = SvPV_nomg_const(*MARK, len);
865 stash = gv_stashpvn(name, len, 0);
866 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
867 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
868 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
870 ENTER_with_name("call_TIE");
871 PUSHSTACKi(PERLSI_MAGIC);
873 EXTEND(SP,(I32)items);
877 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
883 if (sv_isobject(sv)) {
884 sv_unmagic(varsv, how);
885 /* Croak if a self-tie on an aggregate is attempted. */
886 if (varsv == SvRV(sv) &&
887 (SvTYPE(varsv) == SVt_PVAV ||
888 SvTYPE(varsv) == SVt_PVHV))
890 "Self-ties of arrays and hashes are not supported");
891 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
893 LEAVE_with_name("call_TIE");
894 SP = PL_stack_base + markoff;
904 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
905 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
907 if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
910 if ((mg = SvTIED_mg(sv, how))) {
911 SV * const obj = SvRV(SvTIED_obj(sv, mg));
913 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
915 if (gv && isGV(gv) && (cv = GvCV(gv))) {
917 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
918 mXPUSHi(SvREFCNT(obj) - 1);
920 ENTER_with_name("call_UNTIE");
921 call_sv(MUTABLE_SV(cv), G_VOID);
922 LEAVE_with_name("call_UNTIE");
925 else if (mg && SvREFCNT(obj) > 1) {
926 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
927 "untie attempted while %"UVuf" inner references still exist",
928 (UV)SvREFCNT(obj) - 1 ) ;
932 sv_unmagic(sv, how) ;
942 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
943 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
945 if (isGV_with_GP(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
948 if ((mg = SvTIED_mg(sv, how))) {
949 SV *osv = SvTIED_obj(sv, mg);
950 if (osv == mg->mg_obj)
951 osv = sv_mortalcopy(osv);
965 HV * const hv = MUTABLE_HV(POPs);
966 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
967 stash = gv_stashsv(sv, 0);
968 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
970 require_pv("AnyDBM_File.pm");
972 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
973 DIE(aTHX_ "No dbm on this machine");
983 mPUSHu(O_RDWR|O_CREAT);
988 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
991 if (!sv_isobject(TOPs)) {
999 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1003 if (sv_isobject(TOPs)) {
1004 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1005 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1022 struct timeval timebuf;
1023 struct timeval *tbuf = &timebuf;
1026 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1031 # if BYTEORDER & 0xf0000
1032 # define ORDERBYTE (0x88888888 - BYTEORDER)
1034 # define ORDERBYTE (0x4444 - BYTEORDER)
1040 for (i = 1; i <= 3; i++) {
1041 SV * const sv = SP[i];
1044 if (SvREADONLY(sv)) {
1046 sv_force_normal_flags(sv, 0);
1047 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1048 DIE(aTHX_ "%s", PL_no_modify);
1051 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1052 SvPV_force_nolen(sv); /* force string conversion */
1059 /* little endians can use vecs directly */
1060 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1067 masksize = NFDBITS / NBBY;
1069 masksize = sizeof(long); /* documented int, everyone seems to use long */
1071 Zero(&fd_sets[0], 4, char*);
1074 # if SELECT_MIN_BITS == 1
1075 growsize = sizeof(fd_set);
1077 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1078 # undef SELECT_MIN_BITS
1079 # define SELECT_MIN_BITS __FD_SETSIZE
1081 /* If SELECT_MIN_BITS is greater than one we most probably will want
1082 * to align the sizes with SELECT_MIN_BITS/8 because for example
1083 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1084 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1085 * on (sets/tests/clears bits) is 32 bits. */
1086 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1094 timebuf.tv_sec = (long)value;
1095 value -= (NV)timebuf.tv_sec;
1096 timebuf.tv_usec = (long)(value * 1000000.0);
1101 for (i = 1; i <= 3; i++) {
1103 if (!SvOK(sv) || SvCUR(sv) == 0) {
1110 Sv_Grow(sv, growsize);
1114 while (++j <= growsize) {
1118 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1120 Newx(fd_sets[i], growsize, char);
1121 for (offset = 0; offset < growsize; offset += masksize) {
1122 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1123 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1126 fd_sets[i] = SvPVX(sv);
1130 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1131 /* Can't make just the (void*) conditional because that would be
1132 * cpp #if within cpp macro, and not all compilers like that. */
1133 nfound = PerlSock_select(
1135 (Select_fd_set_t) fd_sets[1],
1136 (Select_fd_set_t) fd_sets[2],
1137 (Select_fd_set_t) fd_sets[3],
1138 (void*) tbuf); /* Workaround for compiler bug. */
1140 nfound = PerlSock_select(
1142 (Select_fd_set_t) fd_sets[1],
1143 (Select_fd_set_t) fd_sets[2],
1144 (Select_fd_set_t) fd_sets[3],
1147 for (i = 1; i <= 3; i++) {
1150 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1152 for (offset = 0; offset < growsize; offset += masksize) {
1153 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1154 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1156 Safefree(fd_sets[i]);
1163 if (GIMME == G_ARRAY && tbuf) {
1164 value = (NV)(timebuf.tv_sec) +
1165 (NV)(timebuf.tv_usec) / 1000000.0;
1170 DIE(aTHX_ "select not implemented");
1176 =for apidoc setdefout
1178 Sets PL_defoutgv, the default file handle for output, to the passed in
1179 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1180 count of the passed in typeglob is increased by one, and the reference count
1181 of the typeglob that PL_defoutgv points to is decreased by one.
1187 Perl_setdefout(pTHX_ GV *gv)
1190 SvREFCNT_inc_simple_void(gv);
1191 SvREFCNT_dec(PL_defoutgv);
1199 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1200 GV * egv = GvEGVx(PL_defoutgv);
1204 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1206 XPUSHs(&PL_sv_undef);
1208 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1209 if (gvp && *gvp == egv) {
1210 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1214 mXPUSHs(newRV(MUTABLE_SV(egv)));
1219 if (!GvIO(newdefout))
1220 gv_IOadd(newdefout);
1221 setdefout(newdefout);
1231 GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs);
1236 if (gv && (io = GvIO(gv))) {
1237 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1239 const U32 gimme = GIMME_V;
1240 S_tied_handle_method(aTHX_ "GETC", SP, io, mg, gimme);
1241 if (gimme == G_SCALAR) {
1243 SvSetMagicSV_nosteal(TARG, TOPs);
1248 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1249 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1250 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1251 report_evil_fh(gv, io, PL_op->op_type);
1252 SETERRNO(EBADF,RMS_IFI);
1256 sv_setpvs(TARG, " ");
1257 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1258 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1259 /* Find out how many bytes the char needs */
1260 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1263 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1264 SvCUR_set(TARG,1+len);
1273 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1276 register PERL_CONTEXT *cx;
1277 const I32 gimme = GIMME_V;
1279 PERL_ARGS_ASSERT_DOFORM;
1284 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1285 PUSHFORMAT(cx, retop);
1287 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1289 setdefout(gv); /* locally select filehandle so $% et al work */
1308 gv = MUTABLE_GV(POPs);
1322 goto not_a_format_reference;
1327 tmpsv = sv_newmortal();
1328 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1329 name = SvPV_nolen_const(tmpsv);
1331 DIE(aTHX_ "Undefined format \"%s\" called", name);
1333 not_a_format_reference:
1334 DIE(aTHX_ "Not a format reference");
1337 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1339 IoFLAGS(io) &= ~IOf_DIDTOP;
1340 return doform(cv,gv,PL_op->op_next);
1346 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1347 register IO * const io = GvIOp(gv);
1352 register PERL_CONTEXT *cx;
1354 if (!io || !(ofp = IoOFP(io)))
1357 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1358 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1360 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1361 PL_formtarget != PL_toptarget)
1365 if (!IoTOP_GV(io)) {
1368 if (!IoTOP_NAME(io)) {
1370 if (!IoFMT_NAME(io))
1371 IoFMT_NAME(io) = savepv(GvNAME(gv));
1372 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1373 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1374 if ((topgv && GvFORM(topgv)) ||
1375 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1376 IoTOP_NAME(io) = savesvpv(topname);
1378 IoTOP_NAME(io) = savepvs("top");
1380 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1381 if (!topgv || !GvFORM(topgv)) {
1382 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1385 IoTOP_GV(io) = topgv;
1387 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1388 I32 lines = IoLINES_LEFT(io);
1389 const char *s = SvPVX_const(PL_formtarget);
1390 if (lines <= 0) /* Yow, header didn't even fit!!! */
1392 while (lines-- > 0) {
1393 s = strchr(s, '\n');
1399 const STRLEN save = SvCUR(PL_formtarget);
1400 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1401 do_print(PL_formtarget, ofp);
1402 SvCUR_set(PL_formtarget, save);
1403 sv_chop(PL_formtarget, s);
1404 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1407 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1408 do_print(PL_formfeed, ofp);
1409 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1411 PL_formtarget = PL_toptarget;
1412 IoFLAGS(io) |= IOf_DIDTOP;
1415 DIE(aTHX_ "bad top format reference");
1418 SV * const sv = sv_newmortal();
1420 gv_efullname4(sv, fgv, NULL, FALSE);
1421 name = SvPV_nolen_const(sv);
1423 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1425 DIE(aTHX_ "Undefined top format called");
1427 if (cv && CvCLONE(cv))
1428 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1429 return doform(cv, gv, PL_op);
1433 POPBLOCK(cx,PL_curpm);
1439 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1441 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1442 else if (ckWARN(WARN_CLOSED))
1443 report_evil_fh(gv, io, PL_op->op_type);
1448 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1449 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1451 if (!do_print(PL_formtarget, fp))
1454 FmLINES(PL_formtarget) = 0;
1455 SvCUR_set(PL_formtarget, 0);
1456 *SvEND(PL_formtarget) = '\0';
1457 if (IoFLAGS(io) & IOf_FLUSH)
1458 (void)PerlIO_flush(fp);
1463 PL_formtarget = PL_bodytarget;
1465 PERL_UNUSED_VAR(newsp);
1466 PERL_UNUSED_VAR(gimme);
1467 return cx->blk_sub.retop;
1472 dVAR; dSP; dMARK; dORIGMARK;
1478 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1480 if (gv && (io = GvIO(gv))) {
1481 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1483 if (MARK == ORIGMARK) {
1486 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1490 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1493 call_method("PRINTF", G_SCALAR);
1496 MARK = ORIGMARK + 1;
1504 if (!(io = GvIO(gv))) {
1505 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1506 report_evil_fh(gv, io, PL_op->op_type);
1507 SETERRNO(EBADF,RMS_IFI);
1510 else if (!(fp = IoOFP(io))) {
1511 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1513 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1514 else if (ckWARN(WARN_CLOSED))
1515 report_evil_fh(gv, io, PL_op->op_type);
1517 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1521 if (SvTAINTED(MARK[1]))
1522 TAINT_PROPER("printf");
1523 do_sprintf(sv, SP - MARK, MARK + 1);
1524 if (!do_print(sv, fp))
1527 if (IoFLAGS(io) & IOf_FLUSH)
1528 if (PerlIO_flush(fp) == EOF)
1539 PUSHs(&PL_sv_undef);
1547 const int perm = (MAXARG > 3) ? POPi : 0666;
1548 const int mode = POPi;
1549 SV * const sv = POPs;
1550 GV * const gv = MUTABLE_GV(POPs);
1553 /* Need TIEHANDLE method ? */
1554 const char * const tmps = SvPV_const(sv, len);
1555 /* FIXME? do_open should do const */
1556 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1557 IoLINES(GvIOp(gv)) = 0;
1561 PUSHs(&PL_sv_undef);
1568 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1574 Sock_size_t bufsize;
1582 bool charstart = FALSE;
1583 STRLEN charskip = 0;
1586 GV * const gv = MUTABLE_GV(*++MARK);
1587 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1588 && gv && (io = GvIO(gv)) )
1590 const MAGIC * mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1594 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1596 call_method("READ", G_SCALAR);
1610 sv_setpvs(bufsv, "");
1611 length = SvIVx(*++MARK);
1614 offset = SvIVx(*++MARK);
1618 if (!io || !IoIFP(io)) {
1619 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1620 report_evil_fh(gv, io, PL_op->op_type);
1621 SETERRNO(EBADF,RMS_IFI);
1624 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1625 buffer = SvPVutf8_force(bufsv, blen);
1626 /* UTF-8 may not have been set if they are all low bytes */
1631 buffer = SvPV_force(bufsv, blen);
1632 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1635 DIE(aTHX_ "Negative length");
1643 if (PL_op->op_type == OP_RECV) {
1644 char namebuf[MAXPATHLEN];
1645 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1646 bufsize = sizeof (struct sockaddr_in);
1648 bufsize = sizeof namebuf;
1650 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1654 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1655 /* 'offset' means 'flags' here */
1656 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1657 (struct sockaddr *)namebuf, &bufsize);
1661 /* Bogus return without padding */
1662 bufsize = sizeof (struct sockaddr_in);
1664 SvCUR_set(bufsv, count);
1665 *SvEND(bufsv) = '\0';
1666 (void)SvPOK_only(bufsv);
1670 /* This should not be marked tainted if the fp is marked clean */
1671 if (!(IoFLAGS(io) & IOf_UNTAINT))
1672 SvTAINTED_on(bufsv);
1674 sv_setpvn(TARG, namebuf, bufsize);
1679 if (PL_op->op_type == OP_RECV)
1680 DIE(aTHX_ PL_no_sock_func, "recv");
1682 if (DO_UTF8(bufsv)) {
1683 /* offset adjust in characters not bytes */
1684 blen = sv_len_utf8(bufsv);
1687 if (-offset > (int)blen)
1688 DIE(aTHX_ "Offset outside string");
1691 if (DO_UTF8(bufsv)) {
1692 /* convert offset-as-chars to offset-as-bytes */
1693 if (offset >= (int)blen)
1694 offset += SvCUR(bufsv) - blen;
1696 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1699 bufsize = SvCUR(bufsv);
1700 /* Allocating length + offset + 1 isn't perfect in the case of reading
1701 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1703 (should be 2 * length + offset + 1, or possibly something longer if
1704 PL_encoding is true) */
1705 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1706 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1707 Zero(buffer+bufsize, offset-bufsize, char);
1709 buffer = buffer + offset;
1711 read_target = bufsv;
1713 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1714 concatenate it to the current buffer. */
1716 /* Truncate the existing buffer to the start of where we will be
1718 SvCUR_set(bufsv, offset);
1720 read_target = sv_newmortal();
1721 SvUPGRADE(read_target, SVt_PV);
1722 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1725 if (PL_op->op_type == OP_SYSREAD) {
1726 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1727 if (IoTYPE(io) == IoTYPE_SOCKET) {
1728 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1734 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1739 #ifdef HAS_SOCKET__bad_code_maybe
1740 if (IoTYPE(io) == IoTYPE_SOCKET) {
1741 char namebuf[MAXPATHLEN];
1742 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1743 bufsize = sizeof (struct sockaddr_in);
1745 bufsize = sizeof namebuf;
1747 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1748 (struct sockaddr *)namebuf, &bufsize);
1753 count = PerlIO_read(IoIFP(io), buffer, length);
1754 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1755 if (count == 0 && PerlIO_error(IoIFP(io)))
1759 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1760 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1763 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1764 *SvEND(read_target) = '\0';
1765 (void)SvPOK_only(read_target);
1766 if (fp_utf8 && !IN_BYTES) {
1767 /* Look at utf8 we got back and count the characters */
1768 const char *bend = buffer + count;
1769 while (buffer < bend) {
1771 skip = UTF8SKIP(buffer);
1774 if (buffer - charskip + skip > bend) {
1775 /* partial character - try for rest of it */
1776 length = skip - (bend-buffer);
1777 offset = bend - SvPVX_const(bufsv);
1789 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1790 provided amount read (count) was what was requested (length)
1792 if (got < wanted && count == length) {
1793 length = wanted - got;
1794 offset = bend - SvPVX_const(bufsv);
1797 /* return value is character count */
1801 else if (buffer_utf8) {
1802 /* Let svcatsv upgrade the bytes we read in to utf8.
1803 The buffer is a mortal so will be freed soon. */
1804 sv_catsv_nomg(bufsv, read_target);
1807 /* This should not be marked tainted if the fp is marked clean */
1808 if (!(IoFLAGS(io) & IOf_UNTAINT))
1809 SvTAINTED_on(bufsv);
1821 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1827 STRLEN orig_blen_bytes;
1828 const int op_type = PL_op->op_type;
1832 GV *const gv = MUTABLE_GV(*++MARK);
1833 if (PL_op->op_type == OP_SYSWRITE
1834 && gv && (io = GvIO(gv))) {
1835 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1839 if (MARK == SP - 1) {
1841 mXPUSHi(sv_len(sv));
1846 *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg);
1848 call_method("WRITE", G_SCALAR);
1864 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1866 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1867 if (io && IoIFP(io))
1868 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1870 report_evil_fh(gv, io, PL_op->op_type);
1872 SETERRNO(EBADF,RMS_IFI);
1876 /* Do this first to trigger any overloading. */
1877 buffer = SvPV_const(bufsv, blen);
1878 orig_blen_bytes = blen;
1879 doing_utf8 = DO_UTF8(bufsv);
1881 if (PerlIO_isutf8(IoIFP(io))) {
1882 if (!SvUTF8(bufsv)) {
1883 /* We don't modify the original scalar. */
1884 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1885 buffer = (char *) tmpbuf;
1889 else if (doing_utf8) {
1890 STRLEN tmplen = blen;
1891 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1894 buffer = (char *) tmpbuf;
1898 assert((char *)result == buffer);
1899 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1903 if (op_type == OP_SYSWRITE) {
1904 Size_t length = 0; /* This length is in characters. */
1910 /* The SV is bytes, and we've had to upgrade it. */
1911 blen_chars = orig_blen_bytes;
1913 /* The SV really is UTF-8. */
1914 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1915 /* Don't call sv_len_utf8 again because it will call magic
1916 or overloading a second time, and we might get back a
1917 different result. */
1918 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1920 /* It's safe, and it may well be cached. */
1921 blen_chars = sv_len_utf8(bufsv);
1929 length = blen_chars;
1931 #if Size_t_size > IVSIZE
1932 length = (Size_t)SvNVx(*++MARK);
1934 length = (Size_t)SvIVx(*++MARK);
1936 if ((SSize_t)length < 0) {
1938 DIE(aTHX_ "Negative length");
1943 offset = SvIVx(*++MARK);
1945 if (-offset > (IV)blen_chars) {
1947 DIE(aTHX_ "Offset outside string");
1949 offset += blen_chars;
1950 } else if (offset > (IV)blen_chars) {
1952 DIE(aTHX_ "Offset outside string");
1956 if (length > blen_chars - offset)
1957 length = blen_chars - offset;
1959 /* Here we convert length from characters to bytes. */
1960 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1961 /* Either we had to convert the SV, or the SV is magical, or
1962 the SV has overloading, in which case we can't or mustn't
1963 or mustn't call it again. */
1965 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1966 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1968 /* It's a real UTF-8 SV, and it's not going to change under
1969 us. Take advantage of any cache. */
1971 I32 len_I32 = length;
1973 /* Convert the start and end character positions to bytes.
1974 Remember that the second argument to sv_pos_u2b is relative
1976 sv_pos_u2b(bufsv, &start, &len_I32);
1983 buffer = buffer+offset;
1985 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1986 if (IoTYPE(io) == IoTYPE_SOCKET) {
1987 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1993 /* See the note at doio.c:do_print about filesize limits. --jhi */
1994 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2000 const int flags = SvIVx(*++MARK);
2003 char * const sockbuf = SvPVx(*++MARK, mlen);
2004 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
2005 flags, (struct sockaddr *)sockbuf, mlen);
2009 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
2014 DIE(aTHX_ PL_no_sock_func, "send");
2021 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2024 #if Size_t_size > IVSIZE
2044 * in Perl 5.12 and later, the additional parameter is a bitmask:
2047 * 2 = eof() <- ARGV magic
2049 * I'll rely on the compiler's trace flow analysis to decide whether to
2050 * actually assign this out here, or punt it into the only block where it is
2051 * used. Doing it out here is DRY on the condition logic.
2056 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2062 if (PL_op->op_flags & OPf_SPECIAL) {
2063 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2067 gv = PL_last_in_gv; /* eof */
2075 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2076 return tied_handle_method1("EOF", SP, io, mg, newSVuv(which));
2079 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2080 if (io && !IoIFP(io)) {
2081 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2083 IoFLAGS(io) &= ~IOf_START;
2084 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2086 sv_setpvs(GvSV(gv), "-");
2088 GvSV(gv) = newSVpvs("-");
2089 SvSETMAGIC(GvSV(gv));
2091 else if (!nextargv(gv))
2096 PUSHs(boolSV(do_eof(gv)));
2107 PL_last_in_gv = MUTABLE_GV(POPs);
2112 if (gv && (io = GvIO(gv))) {
2113 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2115 return tied_handle_method("TELL", SP, io, mg);
2120 SETERRNO(EBADF,RMS_IFI);
2125 #if LSEEKSIZE > IVSIZE
2126 PUSHn( do_tell(gv) );
2128 PUSHi( do_tell(gv) );
2136 const int whence = POPi;
2137 #if LSEEKSIZE > IVSIZE
2138 const Off_t offset = (Off_t)SvNVx(POPs);
2140 const Off_t offset = (Off_t)SvIVx(POPs);
2143 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2146 if (gv && (io = GvIO(gv))) {
2147 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2149 #if LSEEKSIZE > IVSIZE
2150 SV *const offset_sv = newSVnv((NV) offset);
2152 SV *const offset_sv = newSViv(offset);
2155 return tied_handle_method2("SEEK", SP, io, mg, offset_sv,
2160 if (PL_op->op_type == OP_SEEK)
2161 PUSHs(boolSV(do_seek(gv, offset, whence)));
2163 const Off_t sought = do_sysseek(gv, offset, whence);
2165 PUSHs(&PL_sv_undef);
2167 SV* const sv = sought ?
2168 #if LSEEKSIZE > IVSIZE
2173 : newSVpvn(zero_but_true, ZBTLEN);
2184 /* There seems to be no consensus on the length type of truncate()
2185 * and ftruncate(), both off_t and size_t have supporters. In
2186 * general one would think that when using large files, off_t is
2187 * at least as wide as size_t, so using an off_t should be okay. */
2188 /* XXX Configure probe for the length type of *truncate() needed XXX */
2191 #if Off_t_size > IVSIZE
2196 /* Checking for length < 0 is problematic as the type might or
2197 * might not be signed: if it is not, clever compilers will moan. */
2198 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2205 if (PL_op->op_flags & OPf_SPECIAL) {
2206 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2215 TAINT_PROPER("truncate");
2216 if (!(fp = IoIFP(io))) {
2222 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2224 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2231 SV * const sv = POPs;
2234 if (isGV_with_GP(sv)) {
2235 tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */
2236 goto do_ftruncate_gv;
2238 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2239 tmpgv = MUTABLE_GV(SvRV(sv)); /* \*main::FRED for example */
2240 goto do_ftruncate_gv;
2242 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2243 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2244 goto do_ftruncate_io;
2247 name = SvPV_nolen_const(sv);
2248 TAINT_PROPER("truncate");
2250 if (truncate(name, len) < 0)
2254 const int tmpfd = PerlLIO_open(name, O_RDWR);
2259 if (my_chsize(tmpfd, len) < 0)
2261 PerlLIO_close(tmpfd);
2270 SETERRNO(EBADF,RMS_IFI);
2278 SV * const argsv = POPs;
2279 const unsigned int func = POPu;
2280 const int optype = PL_op->op_type;
2281 GV * const gv = MUTABLE_GV(POPs);
2282 IO * const io = gv ? GvIOn(gv) : NULL;
2286 if (!io || !argsv || !IoIFP(io)) {
2287 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2288 report_evil_fh(gv, io, PL_op->op_type);
2289 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2293 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2296 s = SvPV_force(argsv, len);
2297 need = IOCPARM_LEN(func);
2299 s = Sv_Grow(argsv, need + 1);
2300 SvCUR_set(argsv, need);
2303 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2306 retval = SvIV(argsv);
2307 s = INT2PTR(char*,retval); /* ouch */
2310 TAINT_PROPER(PL_op_desc[optype]);
2312 if (optype == OP_IOCTL)
2314 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2316 DIE(aTHX_ "ioctl is not implemented");
2320 DIE(aTHX_ "fcntl is not implemented");
2322 #if defined(OS2) && defined(__EMX__)
2323 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2325 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2329 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2331 if (s[SvCUR(argsv)] != 17)
2332 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2334 s[SvCUR(argsv)] = 0; /* put our null back */
2335 SvSETMAGIC(argsv); /* Assume it has changed */
2344 PUSHp(zero_but_true, ZBTLEN);
2357 const int argtype = POPi;
2358 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
2360 if (gv && (io = GvIO(gv)))
2366 /* XXX Looks to me like io is always NULL at this point */
2368 (void)PerlIO_flush(fp);
2369 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2372 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2373 report_evil_fh(gv, io, PL_op->op_type);
2375 SETERRNO(EBADF,RMS_IFI);
2380 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");
2440 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2442 const int protocol = POPi;
2443 const int type = POPi;
2444 const int domain = POPi;
2445 GV * const gv2 = MUTABLE_GV(POPs);
2446 GV * const gv1 = MUTABLE_GV(POPs);
2447 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2448 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2451 if (!gv1 || !gv2 || !io1 || !io2) {
2452 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2454 report_evil_fh(gv1, io1, PL_op->op_type);
2456 report_evil_fh(gv1, io2, PL_op->op_type);
2458 if (io1 && IoIFP(io1))
2459 do_close(gv1, FALSE);
2460 if (io2 && IoIFP(io2))
2461 do_close(gv2, FALSE);
2466 do_close(gv1, FALSE);
2468 do_close(gv2, FALSE);
2470 TAINT_PROPER("socketpair");
2471 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2473 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2474 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2475 IoTYPE(io1) = IoTYPE_SOCKET;
2476 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2477 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2478 IoTYPE(io2) = IoTYPE_SOCKET;
2479 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2480 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2481 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2482 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2483 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2484 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2485 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2488 #if defined(HAS_FCNTL) && defined(F_SETFD)
2489 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2490 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2495 DIE(aTHX_ PL_no_sock_func, "socketpair");
2504 SV * const addrsv = POPs;
2505 /* OK, so on what platform does bind modify addr? */
2507 GV * const gv = MUTABLE_GV(POPs);
2508 register IO * const io = GvIOn(gv);
2511 if (!io || !IoIFP(io))
2514 addr = SvPV_const(addrsv, len);
2515 TAINT_PROPER("bind");
2516 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2522 if (ckWARN(WARN_CLOSED))
2523 report_evil_fh(gv, io, PL_op->op_type);
2524 SETERRNO(EBADF,SS_IVCHAN);
2527 DIE(aTHX_ PL_no_sock_func, "bind");
2536 SV * const addrsv = POPs;
2537 GV * const gv = MUTABLE_GV(POPs);
2538 register IO * const io = GvIOn(gv);
2542 if (!io || !IoIFP(io))
2545 addr = SvPV_const(addrsv, len);
2546 TAINT_PROPER("connect");
2547 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2553 if (ckWARN(WARN_CLOSED))
2554 report_evil_fh(gv, io, PL_op->op_type);
2555 SETERRNO(EBADF,SS_IVCHAN);
2558 DIE(aTHX_ PL_no_sock_func, "connect");
2567 const int backlog = POPi;
2568 GV * const gv = MUTABLE_GV(POPs);
2569 register IO * const io = gv ? GvIOn(gv) : NULL;
2571 if (!gv || !io || !IoIFP(io))
2574 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2580 if (ckWARN(WARN_CLOSED))
2581 report_evil_fh(gv, io, PL_op->op_type);
2582 SETERRNO(EBADF,SS_IVCHAN);
2585 DIE(aTHX_ PL_no_sock_func, "listen");
2596 char namebuf[MAXPATHLEN];
2597 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2598 Sock_size_t len = sizeof (struct sockaddr_in);
2600 Sock_size_t len = sizeof namebuf;
2602 GV * const ggv = MUTABLE_GV(POPs);
2603 GV * const ngv = MUTABLE_GV(POPs);
2612 if (!gstio || !IoIFP(gstio))
2616 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2619 /* Some platforms indicate zero length when an AF_UNIX client is
2620 * not bound. Simulate a non-zero-length sockaddr structure in
2622 namebuf[0] = 0; /* sun_len */
2623 namebuf[1] = AF_UNIX; /* sun_family */
2631 do_close(ngv, FALSE);
2632 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2633 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2634 IoTYPE(nstio) = IoTYPE_SOCKET;
2635 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2636 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2637 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2638 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2641 #if defined(HAS_FCNTL) && defined(F_SETFD)
2642 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2646 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2647 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2649 #ifdef __SCO_VERSION__
2650 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2653 PUSHp(namebuf, len);
2657 if (ckWARN(WARN_CLOSED))
2658 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2659 SETERRNO(EBADF,SS_IVCHAN);
2665 DIE(aTHX_ PL_no_sock_func, "accept");
2674 const int how = POPi;
2675 GV * const gv = MUTABLE_GV(POPs);
2676 register IO * const io = GvIOn(gv);
2678 if (!io || !IoIFP(io))
2681 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2685 if (ckWARN(WARN_CLOSED))
2686 report_evil_fh(gv, io, PL_op->op_type);
2687 SETERRNO(EBADF,SS_IVCHAN);
2690 DIE(aTHX_ PL_no_sock_func, "shutdown");
2699 const int optype = PL_op->op_type;
2700 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2701 const unsigned int optname = (unsigned int) POPi;
2702 const unsigned int lvl = (unsigned int) POPi;
2703 GV * const gv = MUTABLE_GV(POPs);
2704 register IO * const io = GvIOn(gv);
2708 if (!io || !IoIFP(io))
2711 fd = PerlIO_fileno(IoIFP(io));
2715 (void)SvPOK_only(sv);
2719 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2726 #if defined(__SYMBIAN32__)
2727 # define SETSOCKOPT_OPTION_VALUE_T void *
2729 # define SETSOCKOPT_OPTION_VALUE_T const char *
2731 /* XXX TODO: We need to have a proper type (a Configure probe,
2732 * etc.) for what the C headers think of the third argument of
2733 * setsockopt(), the option_value read-only buffer: is it
2734 * a "char *", or a "void *", const or not. Some compilers
2735 * don't take kindly to e.g. assuming that "char *" implicitly
2736 * promotes to a "void *", or to explicitly promoting/demoting
2737 * consts to non/vice versa. The "const void *" is the SUS
2738 * definition, but that does not fly everywhere for the above
2740 SETSOCKOPT_OPTION_VALUE_T buf;
2744 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2748 aint = (int)SvIV(sv);
2749 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2752 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2761 if (ckWARN(WARN_CLOSED))
2762 report_evil_fh(gv, io, optype);
2763 SETERRNO(EBADF,SS_IVCHAN);
2768 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2777 const int optype = PL_op->op_type;
2778 GV * const gv = MUTABLE_GV(POPs);
2779 register IO * const io = GvIOn(gv);
2784 if (!io || !IoIFP(io))
2787 sv = sv_2mortal(newSV(257));
2788 (void)SvPOK_only(sv);
2792 fd = PerlIO_fileno(IoIFP(io));
2794 case OP_GETSOCKNAME:
2795 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2798 case OP_GETPEERNAME:
2799 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2801 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2803 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";
2804 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2805 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2806 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2807 sizeof(u_short) + sizeof(struct in_addr))) {
2814 #ifdef BOGUS_GETNAME_RETURN
2815 /* Interactive Unix, getpeername() and getsockname()
2816 does not return valid namelen */
2817 if (len == BOGUS_GETNAME_RETURN)
2818 len = sizeof(struct sockaddr);
2826 if (ckWARN(WARN_CLOSED))
2827 report_evil_fh(gv, io, optype);
2828 SETERRNO(EBADF,SS_IVCHAN);
2833 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2849 if (PL_op->op_flags & OPf_REF) {
2851 if (PL_op->op_type == OP_LSTAT) {
2852 if (gv != PL_defgv) {
2853 do_fstat_warning_check:
2854 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2855 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2856 } else if (PL_laststype != OP_LSTAT)
2857 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2861 if (gv != PL_defgv) {
2862 PL_laststype = OP_STAT;
2864 sv_setpvs(PL_statname, "");
2871 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2872 } else if (IoDIRP(io)) {
2874 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2876 PL_laststatval = -1;
2882 if (PL_laststatval < 0) {
2883 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2884 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2889 SV* const sv = POPs;
2890 if (isGV_with_GP(sv)) {
2891 gv = MUTABLE_GV(sv);
2893 } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2894 gv = MUTABLE_GV(SvRV(sv));
2895 if (PL_op->op_type == OP_LSTAT)
2896 goto do_fstat_warning_check;
2898 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2899 io = MUTABLE_IO(SvRV(sv));
2900 if (PL_op->op_type == OP_LSTAT)
2901 goto do_fstat_warning_check;
2902 goto do_fstat_have_io;
2905 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2907 PL_laststype = PL_op->op_type;
2908 if (PL_op->op_type == OP_LSTAT)
2909 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2911 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2912 if (PL_laststatval < 0) {
2913 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2914 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2920 if (gimme != G_ARRAY) {
2921 if (gimme != G_VOID)
2922 XPUSHs(boolSV(max));
2928 mPUSHi(PL_statcache.st_dev);
2929 mPUSHi(PL_statcache.st_ino);
2930 mPUSHu(PL_statcache.st_mode);
2931 mPUSHu(PL_statcache.st_nlink);
2932 #if Uid_t_size > IVSIZE
2933 mPUSHn(PL_statcache.st_uid);
2935 # if Uid_t_sign <= 0
2936 mPUSHi(PL_statcache.st_uid);
2938 mPUSHu(PL_statcache.st_uid);
2941 #if Gid_t_size > IVSIZE
2942 mPUSHn(PL_statcache.st_gid);
2944 # if Gid_t_sign <= 0
2945 mPUSHi(PL_statcache.st_gid);
2947 mPUSHu(PL_statcache.st_gid);
2950 #ifdef USE_STAT_RDEV
2951 mPUSHi(PL_statcache.st_rdev);
2953 PUSHs(newSVpvs_flags("", SVs_TEMP));
2955 #if Off_t_size > IVSIZE
2956 mPUSHn(PL_statcache.st_size);
2958 mPUSHi(PL_statcache.st_size);
2961 mPUSHn(PL_statcache.st_atime);
2962 mPUSHn(PL_statcache.st_mtime);
2963 mPUSHn(PL_statcache.st_ctime);
2965 mPUSHi(PL_statcache.st_atime);
2966 mPUSHi(PL_statcache.st_mtime);
2967 mPUSHi(PL_statcache.st_ctime);
2969 #ifdef USE_STAT_BLOCKS
2970 mPUSHu(PL_statcache.st_blksize);
2971 mPUSHu(PL_statcache.st_blocks);
2973 PUSHs(newSVpvs_flags("", SVs_TEMP));
2974 PUSHs(newSVpvs_flags("", SVs_TEMP));
2980 #define tryAMAGICftest_MG(chr) STMT_START { \
2981 if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
2982 && S_try_amagic_ftest(aTHX_ chr)) \
2987 S_try_amagic_ftest(pTHX_ char chr) {
2990 SV* const arg = TOPs;
2995 if ((PL_op->op_flags & OPf_KIDS)
2998 const char tmpchr = chr;
3000 SV * const tmpsv = amagic_call(arg,
3001 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
3002 ftest_amg, AMGf_unary);
3009 next = PL_op->op_next;
3010 if (next->op_type >= OP_FTRREAD &&
3011 next->op_type <= OP_FTBINARY &&
3012 next->op_private & OPpFT_STACKED
3015 /* leave the object alone */
3027 /* This macro is used by the stacked filetest operators :
3028 * if the previous filetest failed, short-circuit and pass its value.
3029 * Else, discard it from the stack and continue. --rgs
3031 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
3032 if (!SvTRUE(TOPs)) { RETURN; } \
3033 else { (void)POPs; PUTBACK; } \
3040 /* Not const, because things tweak this below. Not bool, because there's
3041 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
3042 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3043 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3044 /* Giving some sort of initial value silences compilers. */
3046 int access_mode = R_OK;
3048 int access_mode = 0;
3051 /* access_mode is never used, but leaving use_access in makes the
3052 conditional compiling below much clearer. */
3055 int stat_mode = S_IRUSR;
3057 bool effective = FALSE;
3061 switch (PL_op->op_type) {
3062 case OP_FTRREAD: opchar = 'R'; break;
3063 case OP_FTRWRITE: opchar = 'W'; break;
3064 case OP_FTREXEC: opchar = 'X'; break;
3065 case OP_FTEREAD: opchar = 'r'; break;
3066 case OP_FTEWRITE: opchar = 'w'; break;
3067 case OP_FTEEXEC: opchar = 'x'; break;
3069 tryAMAGICftest_MG(opchar);
3071 STACKED_FTEST_CHECK;
3073 switch (PL_op->op_type) {
3075 #if !(defined(HAS_ACCESS) && defined(R_OK))
3081 #if defined(HAS_ACCESS) && defined(W_OK)
3086 stat_mode = S_IWUSR;
3090 #if defined(HAS_ACCESS) && defined(X_OK)
3095 stat_mode = S_IXUSR;
3099 #ifdef PERL_EFF_ACCESS
3102 stat_mode = S_IWUSR;
3106 #ifndef PERL_EFF_ACCESS
3113 #ifdef PERL_EFF_ACCESS
3118 stat_mode = S_IXUSR;
3124 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3125 const char *name = POPpx;
3127 # ifdef PERL_EFF_ACCESS
3128 result = PERL_EFF_ACCESS(name, access_mode);
3130 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3136 result = access(name, access_mode);
3138 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3153 if (cando(stat_mode, effective, &PL_statcache))
3162 const int op_type = PL_op->op_type;
3167 case OP_FTIS: opchar = 'e'; break;
3168 case OP_FTSIZE: opchar = 's'; break;
3169 case OP_FTMTIME: opchar = 'M'; break;
3170 case OP_FTCTIME: opchar = 'C'; break;
3171 case OP_FTATIME: opchar = 'A'; break;
3173 tryAMAGICftest_MG(opchar);
3175 STACKED_FTEST_CHECK;
3181 if (op_type == OP_FTIS)
3184 /* You can't dTARGET inside OP_FTIS, because you'll get
3185 "panic: pad_sv po" - the op is not flagged to have a target. */
3189 #if Off_t_size > IVSIZE
3190 PUSHn(PL_statcache.st_size);
3192 PUSHi(PL_statcache.st_size);
3196 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3199 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3202 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3216 switch (PL_op->op_type) {
3217 case OP_FTROWNED: opchar = 'O'; break;
3218 case OP_FTEOWNED: opchar = 'o'; break;
3219 case OP_FTZERO: opchar = 'z'; break;
3220 case OP_FTSOCK: opchar = 'S'; break;
3221 case OP_FTCHR: opchar = 'c'; break;
3222 case OP_FTBLK: opchar = 'b'; break;
3223 case OP_FTFILE: opchar = 'f'; break;
3224 case OP_FTDIR: opchar = 'd'; break;
3225 case OP_FTPIPE: opchar = 'p'; break;
3226 case OP_FTSUID: opchar = 'u'; break;
3227 case OP_FTSGID: opchar = 'g'; break;
3228 case OP_FTSVTX: opchar = 'k'; break;
3230 tryAMAGICftest_MG(opchar);
3232 /* I believe that all these three are likely to be defined on most every
3233 system these days. */
3235 if(PL_op->op_type == OP_FTSUID)
3239 if(PL_op->op_type == OP_FTSGID)
3243 if(PL_op->op_type == OP_FTSVTX)
3247 STACKED_FTEST_CHECK;
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();
3324 if (S_ISLNK(PL_statcache.st_mode))
3337 tryAMAGICftest_MG('t');
3339 STACKED_FTEST_CHECK;
3341 if (PL_op->op_flags & OPf_REF)
3343 else if (isGV(TOPs))
3344 gv = MUTABLE_GV(POPs);
3345 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3346 gv = MUTABLE_GV(SvRV(POPs));
3348 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3350 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3351 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3352 else if (tmpsv && SvOK(tmpsv)) {
3353 const char *tmps = SvPV_nolen_const(tmpsv);
3361 if (PerlLIO_isatty(fd))
3366 #if defined(atarist) /* this will work with atariST. Configure will
3367 make guesses for other systems. */
3368 # define FILE_base(f) ((f)->_base)
3369 # define FILE_ptr(f) ((f)->_ptr)
3370 # define FILE_cnt(f) ((f)->_cnt)
3371 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3382 register STDCHAR *s;
3388 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3390 STACKED_FTEST_CHECK;
3392 if (PL_op->op_flags & OPf_REF)
3394 else if (isGV(TOPs))
3395 gv = MUTABLE_GV(POPs);
3396 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3397 gv = MUTABLE_GV(SvRV(POPs));
3403 if (gv == PL_defgv) {
3405 io = GvIO(PL_statgv);
3408 goto really_filename;
3413 PL_laststatval = -1;
3414 sv_setpvs(PL_statname, "");
3415 io = GvIO(PL_statgv);
3417 if (io && IoIFP(io)) {
3418 if (! PerlIO_has_base(IoIFP(io)))
3419 DIE(aTHX_ "-T and -B not implemented on filehandles");
3420 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3421 if (PL_laststatval < 0)
3423 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3424 if (PL_op->op_type == OP_FTTEXT)
3429 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3430 i = PerlIO_getc(IoIFP(io));
3432 (void)PerlIO_ungetc(IoIFP(io),i);
3434 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3436 len = PerlIO_get_bufsiz(IoIFP(io));
3437 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3438 /* sfio can have large buffers - limit to 512 */
3443 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3445 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3447 SETERRNO(EBADF,RMS_IFI);
3455 PL_laststype = OP_STAT;
3456 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3457 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3458 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3460 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3463 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3464 if (PL_laststatval < 0) {
3465 (void)PerlIO_close(fp);
3468 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3469 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3470 (void)PerlIO_close(fp);
3472 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3473 RETPUSHNO; /* special case NFS directories */
3474 RETPUSHYES; /* null file is anything */
3479 /* now scan s to look for textiness */
3480 /* XXX ASCII dependent code */
3482 #if defined(DOSISH) || defined(USEMYBINMODE)
3483 /* ignore trailing ^Z on short files */
3484 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3488 for (i = 0; i < len; i++, s++) {
3489 if (!*s) { /* null never allowed in text */
3494 else if (!(isPRINT(*s) || isSPACE(*s)))
3497 else if (*s & 128) {
3499 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3502 /* utf8 characters don't count as odd */
3503 if (UTF8_IS_START(*s)) {
3504 int ulen = UTF8SKIP(s);
3505 if (ulen < len - i) {
3507 for (j = 1; j < ulen; j++) {
3508 if (!UTF8_IS_CONTINUATION(s[j]))
3511 --ulen; /* loop does extra increment */
3521 *s != '\n' && *s != '\r' && *s != '\b' &&
3522 *s != '\t' && *s != '\f' && *s != 27)
3527 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3538 const char *tmps = NULL;
3542 SV * const sv = POPs;
3543 if (PL_op->op_flags & OPf_SPECIAL) {
3544 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3546 else if (isGV_with_GP(sv)) {
3547 gv = MUTABLE_GV(sv);
3549 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
3550 gv = MUTABLE_GV(SvRV(sv));
3553 tmps = SvPV_nolen_const(sv);
3557 if( !gv && (!tmps || !*tmps) ) {
3558 HV * const table = GvHVn(PL_envgv);
3561 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3562 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3564 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3569 deprecate("chdir('') or chdir(undef) as chdir()");
3570 tmps = SvPV_nolen_const(*svp);
3574 TAINT_PROPER("chdir");
3579 TAINT_PROPER("chdir");
3582 IO* const io = GvIO(gv);
3585 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3586 } else if (IoIFP(io)) {
3587 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3590 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3591 report_evil_fh(gv, io, PL_op->op_type);
3592 SETERRNO(EBADF, RMS_IFI);
3597 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3598 report_evil_fh(gv, io, PL_op->op_type);
3599 SETERRNO(EBADF,RMS_IFI);
3603 DIE(aTHX_ PL_no_func, "fchdir");
3607 PUSHi( PerlDir_chdir(tmps) >= 0 );
3609 /* Clear the DEFAULT element of ENV so we'll get the new value
3611 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3618 dVAR; dSP; dMARK; dTARGET;
3619 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3630 char * const tmps = POPpx;
3631 TAINT_PROPER("chroot");
3632 PUSHi( chroot(tmps) >= 0 );
3635 DIE(aTHX_ PL_no_func, "chroot");
3644 const char * const tmps2 = POPpconstx;
3645 const char * const tmps = SvPV_nolen_const(TOPs);
3646 TAINT_PROPER("rename");
3648 anum = PerlLIO_rename(tmps, tmps2);
3650 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3651 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3654 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3655 (void)UNLINK(tmps2);
3656 if (!(anum = link(tmps, tmps2)))
3657 anum = UNLINK(tmps);
3665 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3669 const int op_type = PL_op->op_type;
3673 if (op_type == OP_LINK)
3674 DIE(aTHX_ PL_no_func, "link");
3676 # ifndef HAS_SYMLINK
3677 if (op_type == OP_SYMLINK)
3678 DIE(aTHX_ PL_no_func, "symlink");
3682 const char * const tmps2 = POPpconstx;
3683 const char * const tmps = SvPV_nolen_const(TOPs);
3684 TAINT_PROPER(PL_op_desc[op_type]);
3686 # if defined(HAS_LINK)
3687 # if defined(HAS_SYMLINK)
3688 /* Both present - need to choose which. */
3689 (op_type == OP_LINK) ?
3690 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3692 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3693 PerlLIO_link(tmps, tmps2);
3696 # if defined(HAS_SYMLINK)
3697 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3698 symlink(tmps, tmps2);
3703 SETi( result >= 0 );
3710 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3722 char buf[MAXPATHLEN];
3725 #ifndef INCOMPLETE_TAINTS
3729 len = readlink(tmps, buf, sizeof(buf) - 1);
3736 RETSETUNDEF; /* just pretend it's a normal file */
3740 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3742 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3744 char * const save_filename = filename;
3749 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3751 PERL_ARGS_ASSERT_DOONELINER;
3753 Newx(cmdline, size, char);
3754 my_strlcpy(cmdline, cmd, size);
3755 my_strlcat(cmdline, " ", size);
3756 for (s = cmdline + strlen(cmdline); *filename; ) {
3760 if (s - cmdline < size)
3761 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3762 myfp = PerlProc_popen(cmdline, "r");
3766 SV * const tmpsv = sv_newmortal();
3767 /* Need to save/restore 'PL_rs' ?? */
3768 s = sv_gets(tmpsv, myfp, 0);
3769 (void)PerlProc_pclose(myfp);
3773 #ifdef HAS_SYS_ERRLIST
3778 /* you don't see this */
3779 const char * const errmsg =
3780 #ifdef HAS_SYS_ERRLIST
3788 if (instr(s, errmsg)) {
3795 #define EACCES EPERM
3797 if (instr(s, "cannot make"))
3798 SETERRNO(EEXIST,RMS_FEX);
3799 else if (instr(s, "existing file"))
3800 SETERRNO(EEXIST,RMS_FEX);
3801 else if (instr(s, "ile exists"))
3802 SETERRNO(EEXIST,RMS_FEX);
3803 else if (instr(s, "non-exist"))
3804 SETERRNO(ENOENT,RMS_FNF);
3805 else if (instr(s, "does not exist"))
3806 SETERRNO(ENOENT,RMS_FNF);
3807 else if (instr(s, "not empty"))
3808 SETERRNO(EBUSY,SS_DEVOFFLINE);
3809 else if (instr(s, "cannot access"))
3810 SETERRNO(EACCES,RMS_PRV);
3812 SETERRNO(EPERM,RMS_PRV);
3815 else { /* some mkdirs return no failure indication */
3816 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3817 if (PL_op->op_type == OP_RMDIR)
3822 SETERRNO(EACCES,RMS_PRV); /* a guess */
3831 /* This macro removes trailing slashes from a directory name.
3832 * Different operating and file systems take differently to
3833 * trailing slashes. According to POSIX 1003.1 1996 Edition
3834 * any number of trailing slashes should be allowed.
3835 * Thusly we snip them away so that even non-conforming
3836 * systems are happy.
3837 * We should probably do this "filtering" for all
3838 * the functions that expect (potentially) directory names:
3839 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3840 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3842 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3843 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3846 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3847 (tmps) = savepvn((tmps), (len)); \
3857 const int mode = (MAXARG > 1) ? POPi : 0777;
3859 TRIMSLASHES(tmps,len,copy);
3861 TAINT_PROPER("mkdir");
3863 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3867 SETi( dooneliner("mkdir", tmps) );
3868 oldumask = PerlLIO_umask(0);
3869 PerlLIO_umask(oldumask);
3870 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3885 TRIMSLASHES(tmps,len,copy);
3886 TAINT_PROPER("rmdir");
3888 SETi( PerlDir_rmdir(tmps) >= 0 );
3890 SETi( dooneliner("rmdir", tmps) );
3897 /* Directory calls. */
3901 #if defined(Direntry_t) && defined(HAS_READDIR)
3903 const char * const dirname = POPpconstx;
3904 GV * const gv = MUTABLE_GV(POPs);
3905 register IO * const io = GvIOn(gv);
3910 if ((IoIFP(io) || IoOFP(io)))
3911 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3912 "Opening filehandle %s also as a directory",
3915 PerlDir_close(IoDIRP(io));
3916 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3922 SETERRNO(EBADF,RMS_DIR);
3925 DIE(aTHX_ PL_no_dir_func, "opendir");
3932 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3933 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");
4019 #if defined(HAS_SEEKDIR) || defined(seekdir)
4021 const long along = POPl;
4022 GV * const gv = MUTABLE_GV(POPs);
4023 register IO * const io = GvIOn(gv);
4025 if (!io || !IoDIRP(io)) {
4026 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4027 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
4030 (void)PerlDir_seek(IoDIRP(io), along);
4035 SETERRNO(EBADF,RMS_ISI);
4038 DIE(aTHX_ PL_no_dir_func, "seekdir");
4045 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4047 GV * const gv = MUTABLE_GV(POPs);
4048 register IO * const io = GvIOn(gv);
4050 if (!io || !IoDIRP(io)) {
4051 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4052 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
4055 (void)PerlDir_rewind(IoDIRP(io));
4059 SETERRNO(EBADF,RMS_ISI);
4062 DIE(aTHX_ PL_no_dir_func, "rewinddir");
4069 #if defined(Direntry_t) && defined(HAS_READDIR)
4071 GV * const gv = MUTABLE_GV(POPs);
4072 register IO * const io = GvIOn(gv);
4074 if (!io || !IoDIRP(io)) {
4075 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4076 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
4079 #ifdef VOID_CLOSEDIR
4080 PerlDir_close(IoDIRP(io));
4082 if (PerlDir_close(IoDIRP(io)) < 0) {
4083 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4092 SETERRNO(EBADF,RMS_IFI);
4095 DIE(aTHX_ PL_no_dir_func, "closedir");
4100 /* Process control. */
4109 PERL_FLUSHALL_FOR_CHILD;
4110 childpid = PerlProc_fork();
4114 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
4116 SvREADONLY_off(GvSV(tmpgv));
4117 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4118 SvREADONLY_on(GvSV(tmpgv));
4120 #ifdef THREADS_HAVE_PIDS
4121 PL_ppid = (IV)getppid();
4123 #ifdef PERL_USES_PL_PIDSTATUS
4124 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4130 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4135 PERL_FLUSHALL_FOR_CHILD;
4136 childpid = PerlProc_fork();
4142 DIE(aTHX_ PL_no_func, "fork");
4150 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4155 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4156 childpid = wait4pid(-1, &argflags, 0);
4158 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4163 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4164 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4165 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4167 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4172 DIE(aTHX_ PL_no_func, "wait");
4179 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4181 const int optype = POPi;
4182 const Pid_t pid = TOPi;
4186 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4187 result = wait4pid(pid, &argflags, optype);
4189 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4194 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4195 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4196 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4198 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4203 DIE(aTHX_ PL_no_func, "waitpid");
4210 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4211 #if defined(__LIBCATAMOUNT__)
4212 PL_statusvalue = -1;
4221 while (++MARK <= SP) {
4222 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4227 TAINT_PROPER("system");
4229 PERL_FLUSHALL_FOR_CHILD;
4230 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4236 if (PerlProc_pipe(pp) >= 0)
4238 while ((childpid = PerlProc_fork()) == -1) {
4239 if (errno != EAGAIN) {
4244 PerlLIO_close(pp[0]);
4245 PerlLIO_close(pp[1]);
4252 Sigsave_t ihand,qhand; /* place to save signals during system() */
4256 PerlLIO_close(pp[1]);
4258 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4259 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4262 result = wait4pid(childpid, &status, 0);
4263 } while (result == -1 && errno == EINTR);
4265 (void)rsignal_restore(SIGINT, &ihand);
4266 (void)rsignal_restore(SIGQUIT, &qhand);
4268 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4269 do_execfree(); /* free any memory child malloced on fork */
4276 while (n < sizeof(int)) {
4277 n1 = PerlLIO_read(pp[0],
4278 (void*)(((char*)&errkid)+n),
4284 PerlLIO_close(pp[0]);
4285 if (n) { /* Error */
4286 if (n != sizeof(int))
4287 DIE(aTHX_ "panic: kid popen errno read");
4288 errno = errkid; /* Propagate errno from kid */
4289 STATUS_NATIVE_CHILD_SET(-1);
4292 XPUSHi(STATUS_CURRENT);
4296 PerlLIO_close(pp[0]);
4297 #if defined(HAS_FCNTL) && defined(F_SETFD)
4298 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4301 if (PL_op->op_flags & OPf_STACKED) {
4302 SV * const really = *++MARK;
4303 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4305 else if (SP - MARK != 1)
4306 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4308 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4312 #else /* ! FORK or VMS or OS/2 */
4315 if (PL_op->op_flags & OPf_STACKED) {
4316 SV * const really = *++MARK;
4317 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4318 value = (I32)do_aspawn(really, MARK, SP);
4320 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4323 else if (SP - MARK != 1) {
4324 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4325 value = (I32)do_aspawn(NULL, MARK, SP);
4327 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4331 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4333 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4335 STATUS_NATIVE_CHILD_SET(value);
4338 XPUSHi(result ? value : STATUS_CURRENT);
4339 #endif /* !FORK or VMS or OS/2 */
4346 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4351 while (++MARK <= SP) {
4352 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4357 TAINT_PROPER("exec");
4359 PERL_FLUSHALL_FOR_CHILD;
4360 if (PL_op->op_flags & OPf_STACKED) {
4361 SV * const really = *++MARK;
4362 value = (I32)do_aexec(really, MARK, SP);
4364 else if (SP - MARK != 1)
4366 value = (I32)vms_do_aexec(NULL, MARK, SP);
4370 (void ) do_aspawn(NULL, MARK, SP);
4374 value = (I32)do_aexec(NULL, MARK, SP);
4379 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4382 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4385 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4399 # ifdef THREADS_HAVE_PIDS
4400 if (PL_ppid != 1 && getppid() == 1)
4401 /* maybe the parent process has died. Refresh ppid cache */
4405 XPUSHi( getppid() );
4409 DIE(aTHX_ PL_no_func, "getppid");
4419 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4422 pgrp = (I32)BSD_GETPGRP(pid);
4424 if (pid != 0 && pid != PerlProc_getpid())
4425 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4431 DIE(aTHX_ PL_no_func, "getpgrp()");
4452 TAINT_PROPER("setpgrp");
4454 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4456 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4457 || (pid != 0 && pid != PerlProc_getpid()))
4459 DIE(aTHX_ "setpgrp can't take arguments");
4461 SETi( setpgrp() >= 0 );
4462 #endif /* USE_BSDPGRP */
4465 DIE(aTHX_ PL_no_func, "setpgrp()");
4472 #ifdef HAS_GETPRIORITY
4474 const int who = POPi;
4475 const int which = TOPi;
4476 SETi( getpriority(which, who) );
4479 DIE(aTHX_ PL_no_func, "getpriority()");
4486 #ifdef HAS_SETPRIORITY
4488 const int niceval = POPi;
4489 const int who = POPi;
4490 const int which = TOPi;
4491 TAINT_PROPER("setpriority");
4492 SETi( setpriority(which, who, niceval) >= 0 );
4495 DIE(aTHX_ PL_no_func, "setpriority()");
4506 XPUSHn( time(NULL) );
4508 XPUSHi( time(NULL) );
4520 (void)PerlProc_times(&PL_timesbuf);
4522 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4523 /* struct tms, though same data */
4527 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4528 if (GIMME == G_ARRAY) {
4529 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4530 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4531 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4539 if (GIMME == G_ARRAY) {
4546 DIE(aTHX_ "times not implemented");
4549 #endif /* HAS_TIMES */
4552 /* The 32 bit int year limits the times we can represent to these
4553 boundaries with a few days wiggle room to account for time zone
4556 /* Sat Jan 3 00:00:00 -2147481748 */
4557 #define TIME_LOWER_BOUND -67768100567755200.0
4558 /* Sun Dec 29 12:00:00 2147483647 */
4559 #define TIME_UPPER_BOUND 67767976233316800.0
4568 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4569 static const char * const dayname[] =
4570 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4571 static const char * const monname[] =
4572 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4573 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4578 when = (Time64_T)now;
4581 NV input = Perl_floor(POPn);
4582 when = (Time64_T)input;
4583 if (when != input) {
4584 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4585 "%s(%.0" NVff ") too large", opname, input);
4589 if ( TIME_LOWER_BOUND > when ) {
4590 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4591 "%s(%.0" NVff ") too small", opname, when);
4594 else if( when > TIME_UPPER_BOUND ) {
4595 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4596 "%s(%.0" NVff ") too large", opname, when);
4600 if (PL_op->op_type == OP_LOCALTIME)
4601 err = S_localtime64_r(&when, &tmbuf);
4603 err = S_gmtime64_r(&when, &tmbuf);
4607 /* XXX %lld broken for quads */
4608 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4609 "%s(%.0" NVff ") failed", opname, when);
4612 if (GIMME != G_ARRAY) { /* scalar context */
4614 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4615 double year = (double)tmbuf.tm_year + 1900;
4622 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4623 dayname[tmbuf.tm_wday],
4624 monname[tmbuf.tm_mon],
4632 else { /* list context */
4638 mPUSHi(tmbuf.tm_sec);
4639 mPUSHi(tmbuf.tm_min);
4640 mPUSHi(tmbuf.tm_hour);
4641 mPUSHi(tmbuf.tm_mday);
4642 mPUSHi(tmbuf.tm_mon);
4643 mPUSHn(tmbuf.tm_year);
4644 mPUSHi(tmbuf.tm_wday);
4645 mPUSHi(tmbuf.tm_yday);
4646 mPUSHi(tmbuf.tm_isdst);
4657 anum = alarm((unsigned int)anum);
4663 DIE(aTHX_ PL_no_func, "alarm");
4675 (void)time(&lasttime);
4680 PerlProc_sleep((unsigned int)duration);
4683 XPUSHi(when - lasttime);
4687 /* Shared memory. */
4688 /* Merged with some message passing. */
4692 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4693 dVAR; dSP; dMARK; dTARGET;
4694 const int op_type = PL_op->op_type;
4699 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4702 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4705 value = (I32)(do_semop(MARK, SP) >= 0);
4708 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4724 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4725 dVAR; dSP; dMARK; dTARGET;
4726 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4733 DIE(aTHX_ "System V IPC is not implemented on this machine");
4740 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4741 dVAR; dSP; dMARK; dTARGET;
4742 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4750 PUSHp(zero_but_true, ZBTLEN);
4758 /* I can't const this further without getting warnings about the types of
4759 various arrays passed in from structures. */
4761 S_space_join_names_mortal(pTHX_ char *const *array)
4765 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4767 if (array && *array) {
4768 target = newSVpvs_flags("", SVs_TEMP);
4770 sv_catpv(target, *array);
4773 sv_catpvs(target, " ");
4776 target = sv_mortalcopy(&PL_sv_no);
4781 /* Get system info. */
4785 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4787 I32 which = PL_op->op_type;
4788 register char **elem;
4790 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4791 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4792 struct hostent *gethostbyname(Netdb_name_t);
4793 struct hostent *gethostent(void);
4795 struct hostent *hent = NULL;
4799 if (which == OP_GHBYNAME) {
4800 #ifdef HAS_GETHOSTBYNAME
4801 const char* const name = POPpbytex;
4802 hent = PerlSock_gethostbyname(name);
4804 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4807 else if (which == OP_GHBYADDR) {
4808 #ifdef HAS_GETHOSTBYADDR
4809 const int addrtype = POPi;
4810 SV * const addrsv = POPs;
4812 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4814 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4816 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4820 #ifdef HAS_GETHOSTENT
4821 hent = PerlSock_gethostent();
4823 DIE(aTHX_ PL_no_sock_func, "gethostent");
4826 #ifdef HOST_NOT_FOUND
4828 #ifdef USE_REENTRANT_API
4829 # ifdef USE_GETHOSTENT_ERRNO
4830 h_errno = PL_reentrant_buffer->_gethostent_errno;
4833 STATUS_UNIX_SET(h_errno);
4837 if (GIMME != G_ARRAY) {
4838 PUSHs(sv = sv_newmortal());
4840 if (which == OP_GHBYNAME) {
4842 sv_setpvn(sv, hent->h_addr, hent->h_length);
4845 sv_setpv(sv, (char*)hent->h_name);
4851 mPUSHs(newSVpv((char*)hent->h_name, 0));
4852 PUSHs(space_join_names_mortal(hent->h_aliases));
4853 mPUSHi(hent->h_addrtype);
4854 len = hent->h_length;
4857 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4858 mXPUSHp(*elem, len);
4862 mPUSHp(hent->h_addr, len);
4864 PUSHs(sv_mortalcopy(&PL_sv_no));
4869 DIE(aTHX_ PL_no_sock_func, "gethostent");
4876 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4878 I32 which = PL_op->op_type;
4880 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4881 struct netent *getnetbyaddr(Netdb_net_t, int);
4882 struct netent *getnetbyname(Netdb_name_t);
4883 struct netent *getnetent(void);
4885 struct netent *nent;
4887 if (which == OP_GNBYNAME){
4888 #ifdef HAS_GETNETBYNAME
4889 const char * const name = POPpbytex;
4890 nent = PerlSock_getnetbyname(name);
4892 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4895 else if (which == OP_GNBYADDR) {
4896 #ifdef HAS_GETNETBYADDR
4897 const int addrtype = POPi;
4898 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4899 nent = PerlSock_getnetbyaddr(addr, addrtype);
4901 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4905 #ifdef HAS_GETNETENT
4906 nent = PerlSock_getnetent();
4908 DIE(aTHX_ PL_no_sock_func, "getnetent");
4911 #ifdef HOST_NOT_FOUND
4913 #ifdef USE_REENTRANT_API
4914 # ifdef USE_GETNETENT_ERRNO
4915 h_errno = PL_reentrant_buffer->_getnetent_errno;
4918 STATUS_UNIX_SET(h_errno);
4923 if (GIMME != G_ARRAY) {
4924 PUSHs(sv = sv_newmortal());
4926 if (which == OP_GNBYNAME)
4927 sv_setiv(sv, (IV)nent->n_net);
4929 sv_setpv(sv, nent->n_name);
4935 mPUSHs(newSVpv(nent->n_name, 0));
4936 PUSHs(space_join_names_mortal(nent->n_aliases));
4937 mPUSHi(nent->n_addrtype);
4938 mPUSHi(nent->n_net);
4943 DIE(aTHX_ PL_no_sock_func, "getnetent");
4950 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4952 I32 which = PL_op->op_type;
4954 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4955 struct protoent *getprotobyname(Netdb_name_t);
4956 struct protoent *getprotobynumber(int);
4957 struct protoent *getprotoent(void);
4959 struct protoent *pent;
4961 if (which == OP_GPBYNAME) {
4962 #ifdef HAS_GETPROTOBYNAME
4963 const char* const name = POPpbytex;
4964 pent = PerlSock_getprotobyname(name);
4966 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4969 else if (which == OP_GPBYNUMBER) {
4970 #ifdef HAS_GETPROTOBYNUMBER
4971 const int number = POPi;
4972 pent = PerlSock_getprotobynumber(number);
4974 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4978 #ifdef HAS_GETPROTOENT
4979 pent = PerlSock_getprotoent();
4981 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4985 if (GIMME != G_ARRAY) {
4986 PUSHs(sv = sv_newmortal());
4988 if (which == OP_GPBYNAME)
4989 sv_setiv(sv, (IV)pent->p_proto);
4991 sv_setpv(sv, pent->p_name);
4997 mPUSHs(newSVpv(pent->p_name, 0));
4998 PUSHs(space_join_names_mortal(pent->p_aliases));
4999 mPUSHi(pent->p_proto);
5004 DIE(aTHX_ PL_no_sock_func, "getprotoent");
5011 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
5013 I32 which = PL_op->op_type;
5015 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
5016 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
5017 struct servent *getservbyport(int, Netdb_name_t);
5018 struct servent *getservent(void);
5020 struct servent *sent;
5022 if (which == OP_GSBYNAME) {
5023 #ifdef HAS_GETSERVBYNAME
5024 const char * const proto = POPpbytex;
5025 const char * const name = POPpbytex;
5026 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5028 DIE(aTHX_ PL_no_sock_func, "getservbyname");
5031 else if (which == OP_GSBYPORT) {
5032 #ifdef HAS_GETSERVBYPORT
5033 const char * const proto = POPpbytex;
5034 unsigned short port = (unsigned short)POPu;
5036 port = PerlSock_htons(port);
5038 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5040 DIE(aTHX_ PL_no_sock_func, "getservbyport");
5044 #ifdef HAS_GETSERVENT
5045 sent = PerlSock_getservent();
5047 DIE(aTHX_ PL_no_sock_func, "getservent");
5051 if (GIMME != G_ARRAY) {
5052 PUSHs(sv = sv_newmortal());
5054 if (which == OP_GSBYNAME) {
5056 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5058 sv_setiv(sv, (IV)(sent->s_port));
5062 sv_setpv(sv, sent->s_name);
5068 mPUSHs(newSVpv(sent->s_name, 0));
5069 PUSHs(space_join_names_mortal(sent->s_aliases));
5071 mPUSHi(PerlSock_ntohs(sent->s_port));
5073 mPUSHi(sent->s_port);
5075 mPUSHs(newSVpv(sent->s_proto, 0));
5080 DIE(aTHX_ PL_no_sock_func, "getservent");
5087 #ifdef HAS_SETHOSTENT
5089 PerlSock_sethostent(TOPi);
5092 DIE(aTHX_ PL_no_sock_func, "sethostent");
5099 #ifdef HAS_SETNETENT
5101 (void)PerlSock_setnetent(TOPi);
5104 DIE(aTHX_ PL_no_sock_func, "setnetent");
5111 #ifdef HAS_SETPROTOENT
5113 (void)PerlSock_setprotoent(TOPi);
5116 DIE(aTHX_ PL_no_sock_func, "setprotoent");
5123 #ifdef HAS_SETSERVENT
5125 (void)PerlSock_setservent(TOPi);
5128 DIE(aTHX_ PL_no_sock_func, "setservent");
5135 #ifdef HAS_ENDHOSTENT
5137 PerlSock_endhostent();
5141 DIE(aTHX_ PL_no_sock_func, "endhostent");
5148 #ifdef HAS_ENDNETENT
5150 PerlSock_endnetent();
5154 DIE(aTHX_ PL_no_sock_func, "endnetent");
5161 #ifdef HAS_ENDPROTOENT
5163 PerlSock_endprotoent();
5167 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5174 #ifdef HAS_ENDSERVENT
5176 PerlSock_endservent();
5180 DIE(aTHX_ PL_no_sock_func, "endservent");
5189 I32 which = PL_op->op_type;
5191 struct passwd *pwent = NULL;
5193 * We currently support only the SysV getsp* shadow password interface.
5194 * The interface is declared in <shadow.h> and often one needs to link
5195 * with -lsecurity or some such.
5196 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5199 * AIX getpwnam() is clever enough to return the encrypted password
5200 * only if the caller (euid?) is root.
5202 * There are at least three other shadow password APIs. Many platforms
5203 * seem to contain more than one interface for accessing the shadow
5204 * password databases, possibly for compatibility reasons.
5205 * The getsp*() is by far he simplest one, the other two interfaces
5206 * are much more complicated, but also very similar to each other.
5211 * struct pr_passwd *getprpw*();
5212 * The password is in
5213 * char getprpw*(...).ufld.fd_encrypt[]
5214 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5219 * struct es_passwd *getespw*();
5220 * The password is in
5221 * char *(getespw*(...).ufld.fd_encrypt)
5222 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5225 * struct userpw *getuserpw();
5226 * The password is in
5227 * char *(getuserpw(...)).spw_upw_passwd
5228 * (but the de facto standard getpwnam() should work okay)
5230 * Mention I_PROT here so that Configure probes for it.
5232 * In HP-UX for getprpw*() the manual page claims that one should include
5233 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5234 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5235 * and pp_sys.c already includes <shadow.h> if there is such.
5237 * Note that <sys/security.h> is already probed for, but currently
5238 * it is only included in special cases.
5240 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5241 * be preferred interface, even though also the getprpw*() interface
5242 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5243 * One also needs to call set_auth_parameters() in main() before
5244 * doing anything else, whether one is using getespw*() or getprpw*().
5246 * Note that accessing the shadow databases can be magnitudes
5247 * slower than accessing the standard databases.
5252 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5253 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5254 * the pw_comment is left uninitialized. */
5255 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5261 const char* const name = POPpbytex;
5262 pwent = getpwnam(name);
5268 pwent = getpwuid(uid);
5272 # ifdef HAS_GETPWENT
5274 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5275 if (pwent) pwent = getpwnam(pwent->pw_name);
5278 DIE(aTHX_ PL_no_func, "getpwent");
5284 if (GIMME != G_ARRAY) {
5285 PUSHs(sv = sv_newmortal());
5287 if (which == OP_GPWNAM)
5288 # if Uid_t_sign <= 0
5289 sv_setiv(sv, (IV)pwent->pw_uid);
5291 sv_setuv(sv, (UV)pwent->pw_uid);
5294 sv_setpv(sv, pwent->pw_name);
5300 mPUSHs(newSVpv(pwent->pw_name, 0));
5304 /* If we have getspnam(), we try to dig up the shadow
5305 * password. If we are underprivileged, the shadow
5306 * interface will set the errno to EACCES or similar,
5307 * and return a null pointer. If this happens, we will
5308 * use the dummy password (usually "*" or "x") from the
5309 * standard password database.
5311 * In theory we could skip the shadow call completely
5312 * if euid != 0 but in practice we cannot know which
5313 * security measures are guarding the shadow databases
5314 * on a random platform.
5316 * Resist the urge to use additional shadow interfaces.
5317 * Divert the urge to writing an extension instead.
5320 /* Some AIX setups falsely(?) detect some getspnam(), which
5321 * has a different API than the Solaris/IRIX one. */
5322 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5325 const struct spwd * const spwent = getspnam(pwent->pw_name);
5326 /* Save and restore errno so that
5327 * underprivileged attempts seem
5328 * to have never made the unsccessful
5329 * attempt to retrieve the shadow password. */
5331 if (spwent && spwent->sp_pwdp)
5332 sv_setpv(sv, spwent->sp_pwdp);
5336 if (!SvPOK(sv)) /* Use the standard password, then. */
5337 sv_setpv(sv, pwent->pw_passwd);
5340 # ifndef INCOMPLETE_TAINTS
5341 /* passwd is tainted because user himself can diddle with it.
5342 * admittedly not much and in a very limited way, but nevertheless. */
5346 # if Uid_t_sign <= 0
5347 mPUSHi(pwent->pw_uid);
5349 mPUSHu(pwent->pw_uid);
5352 # if Uid_t_sign <= 0
5353 mPUSHi(pwent->pw_gid);
5355 mPUSHu(pwent->pw_gid);
5357 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5358 * because of the poor interface of the Perl getpw*(),
5359 * not because there's some standard/convention saying so.
5360 * A better interface would have been to return a hash,
5361 * but we are accursed by our history, alas. --jhi. */
5363 mPUSHi(pwent->pw_change);
5366 mPUSHi(pwent->pw_quota);
5369 mPUSHs(newSVpv(pwent->pw_age, 0));
5371 /* I think that you can never get this compiled, but just in case. */
5372 PUSHs(sv_mortalcopy(&PL_sv_no));
5377 /* pw_class and pw_comment are mutually exclusive--.
5378 * see the above note for pw_change, pw_quota, and pw_age. */
5380 mPUSHs(newSVpv(pwent->pw_class, 0));
5383 mPUSHs(newSVpv(pwent->pw_comment, 0));
5385 /* I think that you can never get this compiled, but just in case. */
5386 PUSHs(sv_mortalcopy(&PL_sv_no));
5391 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5393 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5395 # ifndef INCOMPLETE_TAINTS
5396 /* pw_gecos is tainted because user himself can diddle with it. */
5400 mPUSHs(newSVpv(pwent->pw_dir, 0));
5402 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5403 # ifndef INCOMPLETE_TAINTS
5404 /* pw_shell is tainted because user himself can diddle with it. */
5409 mPUSHi(pwent->pw_expire);
5414 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5421 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5426 DIE(aTHX_ PL_no_func, "setpwent");
5433 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5438 DIE(aTHX_ PL_no_func, "endpwent");
5447 const I32 which = PL_op->op_type;
5448 const struct group *grent;
5450 if (which == OP_GGRNAM) {
5451 const char* const name = POPpbytex;
5452 grent = (const struct group *)getgrnam(name);
5454 else if (which == OP_GGRGID) {
5455 const Gid_t gid = POPi;
5456 grent = (const struct group *)getgrgid(gid);
5460 grent = (struct group *)getgrent();
5462 DIE(aTHX_ PL_no_func, "getgrent");
5466 if (GIMME != G_ARRAY) {
5467 SV * const sv = sv_newmortal();
5471 if (which == OP_GGRNAM)
5473 sv_setiv(sv, (IV)grent->gr_gid);
5475 sv_setuv(sv, (UV)grent->gr_gid);
5478 sv_setpv(sv, grent->gr_name);
5484 mPUSHs(newSVpv(grent->gr_name, 0));
5487 mPUSHs(newSVpv(grent->gr_passwd, 0));
5489 PUSHs(sv_mortalcopy(&PL_sv_no));
5493 mPUSHi(grent->gr_gid);
5495 mPUSHu(grent->gr_gid);
5498 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5499 /* In UNICOS/mk (_CRAYMPP) the multithreading
5500 * versions (getgrnam_r, getgrgid_r)
5501 * seem to return an illegal pointer
5502 * as the group members list, gr_mem.
5503 * getgrent() doesn't even have a _r version
5504 * but the gr_mem is poisonous anyway.
5505 * So yes, you cannot get the list of group
5506 * members if building multithreaded in UNICOS/mk. */
5507 PUSHs(space_join_names_mortal(grent->gr_mem));
5513 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5520 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5525 DIE(aTHX_ PL_no_func, "setgrent");
5532 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5537 DIE(aTHX_ PL_no_func, "endgrent");
5548 if (!(tmps = PerlProc_getlogin()))
5550 PUSHp(tmps, strlen(tmps));
5553 DIE(aTHX_ PL_no_func, "getlogin");
5558 /* Miscellaneous. */
5563 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5564 register I32 items = SP - MARK;
5565 unsigned long a[20];
5570 while (++MARK <= SP) {
5571 if (SvTAINTED(*MARK)) {
5577 TAINT_PROPER("syscall");
5580 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5581 * or where sizeof(long) != sizeof(char*). But such machines will
5582 * not likely have syscall implemented either, so who cares?
5584 while (++MARK <= SP) {
5585 if (SvNIOK(*MARK) || !i)
5586 a[i++] = SvIV(*MARK);
5587 else if (*MARK == &PL_sv_undef)
5590 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5596 DIE(aTHX_ "Too many args to syscall");
5598 DIE(aTHX_ "Too few args to syscall");
5600 retval = syscall(a[0]);
5603 retval = syscall(a[0],a[1]);
5606 retval = syscall(a[0],a[1],a[2]);
5609 retval = syscall(a[0],a[1],a[2],a[3]);
5612 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5615 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5618 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5621 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5625 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5628 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5631 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5635 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5639 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5643 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5644 a[10],a[11],a[12],a[13]);
5646 #endif /* atarist */
5652 DIE(aTHX_ PL_no_func, "syscall");
5657 #ifdef FCNTL_EMULATE_FLOCK
5659 /* XXX Emulate flock() with fcntl().
5660 What's really needed is a good file locking module.
5664 fcntl_emulate_flock(int fd, int operation)
5669 switch (operation & ~LOCK_NB) {
5671 flock.l_type = F_RDLCK;
5674 flock.l_type = F_WRLCK;
5677 flock.l_type = F_UNLCK;
5683 flock.l_whence = SEEK_SET;
5684 flock.l_start = flock.l_len = (Off_t)0;
5686 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5687 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5688 errno = EWOULDBLOCK;
5692 #endif /* FCNTL_EMULATE_FLOCK */
5694 #ifdef LOCKF_EMULATE_FLOCK
5696 /* XXX Emulate flock() with lockf(). This is just to increase
5697 portability of scripts. The calls are not completely
5698 interchangeable. What's really needed is a good file
5702 /* The lockf() constants might have been defined in <unistd.h>.
5703 Unfortunately, <unistd.h> causes troubles on some mixed
5704 (BSD/POSIX) systems, such as SunOS 4.1.3.
5706 Further, the lockf() constants aren't POSIX, so they might not be
5707 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5708 just stick in the SVID values and be done with it. Sigh.
5712 # define F_ULOCK 0 /* Unlock a previously locked region */
5715 # define F_LOCK 1 /* Lock a region for exclusive use */
5718 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5721 # define F_TEST 3 /* Test a region for other processes locks */
5725 lockf_emulate_flock(int fd, int operation)
5731 /* flock locks entire file so for lockf we need to do the same */
5732 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5733 if (pos > 0) /* is seekable and needs to be repositioned */
5734 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5735 pos = -1; /* seek failed, so don't seek back afterwards */
5738 switch (operation) {
5740 /* LOCK_SH - get a shared lock */
5742 /* LOCK_EX - get an exclusive lock */
5744 i = lockf (fd, F_LOCK, 0);
5747 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5748 case LOCK_SH|LOCK_NB:
5749 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5750 case LOCK_EX|LOCK_NB:
5751 i = lockf (fd, F_TLOCK, 0);
5753 if ((errno == EAGAIN) || (errno == EACCES))
5754 errno = EWOULDBLOCK;
5757 /* LOCK_UN - unlock (non-blocking is a no-op) */
5759 case LOCK_UN|LOCK_NB:
5760 i = lockf (fd, F_ULOCK, 0);
5763 /* Default - can't decipher operation */
5770 if (pos > 0) /* need to restore position of the handle */
5771 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5776 #endif /* LOCKF_EMULATE_FLOCK */
5780 * c-indentation-style: bsd
5782 * indent-tabs-mode: t
5785 * ex: set ts=8 sts=4 sw=4 noet: