3 * Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 * 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * But only a short way ahead its floor and the walls on either side were
13 * cloven by a great fissure, out of which the red glare came, now leaping
14 * up, now dying down into darkness; and all the while far below there was
15 * a rumour and a trouble as of great engines throbbing and labouring.
17 * [p.945 of _The Lord of the Rings_, VI/iii: "Mount Doom"]
20 /* This file contains system pp ("push/pop") functions that
21 * execute the opcodes that make up a perl program. A typical pp function
22 * expects to find its arguments on the stack, and usually pushes its
23 * results onto the stack, hence the 'pp' terminology. Each OP structure
24 * contains a pointer to the relevant pp_foo() function.
26 * By 'system', we mean ops which interact with the OS, such as pp_open().
30 #define PERL_IN_PP_SYS_C
36 /* Shadow password support for solaris - pdo@cs.umd.edu
37 * Not just Solaris: at least HP-UX, IRIX, Linux.
38 * The API is from SysV.
40 * There are at least two more shadow interfaces,
41 * see the comments in pp_gpwent().
45 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
46 * and another MAXINT from "perl.h" <- <sys/param.h>. */
53 # include <sys/resource.h>
62 # include <sys/select.h>
66 /* XXX Configure test needed.
67 h_errno might not be a simple 'int', especially for multi-threaded
68 applications, see "extern int errno in perl.h". Creating such
69 a test requires taking into account the differences between
70 compiling multithreaded and singlethreaded ($ccflags et al).
71 HOST_NOT_FOUND is typically defined in <netdb.h>.
73 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
82 struct passwd *getpwnam (char *);
83 struct passwd *getpwuid (Uid_t);
88 struct passwd *getpwent (void);
89 #elif defined (VMS) && defined (my_getpwent)
90 struct passwd *Perl_my_getpwent (pTHX);
99 struct group *getgrnam (char *);
100 struct group *getgrgid (Gid_t);
104 struct group *getgrent (void);
110 # if defined(_MSC_VER) || defined(__MINGW32__)
111 # include <sys/utime.h>
118 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
121 # define my_chsize PerlLIO_chsize
124 # define my_chsize PerlLIO_chsize
126 I32 my_chsize(int fd, Off_t length);
132 #else /* no flock() */
134 /* fcntl.h might not have been included, even if it exists, because
135 the current Configure only sets I_FCNTL if it's needed to pick up
136 the *_OK constants. Make sure it has been included before testing
137 the fcntl() locking constants. */
138 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
142 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
143 # define FLOCK fcntl_emulate_flock
144 # define FCNTL_EMULATE_FLOCK
145 # else /* no flock() or fcntl(F_SETLK,...) */
147 # define FLOCK lockf_emulate_flock
148 # define LOCKF_EMULATE_FLOCK
150 # endif /* no flock() or fcntl(F_SETLK,...) */
153 static int FLOCK (int, int);
156 * These are the flock() constants. Since this sytems doesn't have
157 * flock(), the values of the constants are probably not available.
171 # endif /* emulating flock() */
173 #endif /* no flock() */
176 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
178 #if defined(I_SYS_ACCESS) && !defined(R_OK)
179 # include <sys/access.h>
182 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
183 # define FD_CLOEXEC 1 /* NeXT needs this */
189 /* Missing protos on LynxOS */
190 void sethostent(int);
191 void endhostent(void);
193 void endnetent(void);
194 void setprotoent(int);
195 void endprotoent(void);
196 void setservent(int);
197 void endservent(void);
200 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
202 /* F_OK unused: if stat() cannot find it... */
204 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
205 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
206 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
209 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
210 # ifdef I_SYS_SECURITY
211 # include <sys/security.h>
215 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
218 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
222 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
224 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
228 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
229 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
230 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
233 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
235 const Uid_t ruid = getuid();
236 const Uid_t euid = geteuid();
237 const Gid_t rgid = getgid();
238 const Gid_t egid = getegid();
241 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
242 Perl_croak(aTHX_ "switching effective uid is not implemented");
245 if (setreuid(euid, ruid))
248 if (setresuid(euid, ruid, (Uid_t)-1))
251 Perl_croak(aTHX_ "entering effective uid failed");
254 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
255 Perl_croak(aTHX_ "switching effective gid is not implemented");
258 if (setregid(egid, rgid))
261 if (setresgid(egid, rgid, (Gid_t)-1))
264 Perl_croak(aTHX_ "entering effective gid failed");
267 res = access(path, mode);
270 if (setreuid(ruid, euid))
273 if (setresuid(ruid, euid, (Uid_t)-1))
276 Perl_croak(aTHX_ "leaving effective uid failed");
279 if (setregid(rgid, egid))
282 if (setresgid(rgid, egid, (Gid_t)-1))
285 Perl_croak(aTHX_ "leaving effective gid failed");
289 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
296 const char * const tmps = POPpconstx;
297 const I32 gimme = GIMME_V;
298 const char *mode = "r";
301 if (PL_op->op_private & OPpOPEN_IN_RAW)
303 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
305 fp = PerlProc_popen(tmps, mode);
307 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
309 PerlIO_apply_layers(aTHX_ fp,mode,type);
311 if (gimme == G_VOID) {
313 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
316 else if (gimme == G_SCALAR) {
317 ENTER_with_name("backtick");
319 PL_rs = &PL_sv_undef;
320 sv_setpvs(TARG, ""); /* note that this preserves previous buffer */
321 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
323 LEAVE_with_name("backtick");
329 SV * const sv = newSV(79);
330 if (sv_gets(sv, fp, 0) == NULL) {
335 if (SvLEN(sv) - SvCUR(sv) > 20) {
336 SvPV_shrink_to_cur(sv);
341 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
342 TAINT; /* "I believe that this is not gratuitous!" */
345 STATUS_NATIVE_CHILD_SET(-1);
346 if (gimme == G_SCALAR)
358 /* make a copy of the pattern, to ensure that magic is called once
360 TOPm1s = sv_2mortal(newSVsv(TOPm1s));
362 tryAMAGICunTARGET(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL));
364 if (PL_op->op_flags & OPf_SPECIAL) {
365 /* call Perl-level glob function instead. Stack args are:
366 * MARK, wildcard, csh_glob context index
367 * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
371 /* stack args are: wildcard, gv(_GEN_n) */
374 /* Note that we only ever get here if File::Glob fails to load
375 * without at the same time croaking, for some reason, or if
376 * perl was built with PERL_EXTERNAL_GLOB */
378 ENTER_with_name("glob");
383 * The external globbing program may use things we can't control,
384 * so for security reasons we must assume the worst.
387 taint_proper(PL_no_security, "glob");
391 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
392 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
394 SAVESPTR(PL_rs); /* This is not permanent, either. */
395 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
398 *SvPVX(PL_rs) = '\n';
402 result = do_readline();
403 LEAVE_with_name("glob");
410 PL_last_in_gv = cGVOP_gv;
411 return do_readline();
421 do_join(TARG, &PL_sv_no, MARK, SP);
425 else if (SP == MARK) {
434 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
435 /* well-formed exception supplied */
437 else if (SvROK(ERRSV)) {
440 else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
441 exsv = sv_mortalcopy(ERRSV);
442 sv_catpvs(exsv, "\t...caught");
445 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
447 if (SvROK(exsv) && !PL_warnhook)
448 Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
459 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
461 if (SP - MARK != 1) {
463 do_join(TARG, &PL_sv_no, MARK, SP);
471 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
472 /* well-formed exception supplied */
474 else if (SvROK(ERRSV)) {
476 if (sv_isobject(exsv)) {
477 HV * const stash = SvSTASH(SvRV(exsv));
478 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
480 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
481 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
488 call_sv(MUTABLE_SV(GvCV(gv)),
489 G_SCALAR|G_EVAL|G_KEEPERR);
490 exsv = sv_mortalcopy(*PL_stack_sp--);
494 else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
495 exsv = sv_mortalcopy(ERRSV);
496 sv_catpvs(exsv, "\t...propagated");
499 exsv = newSVpvs_flags("Died", SVs_TEMP);
507 Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv,
508 const MAGIC *const mg, const U32 flags, U32 argc, ...)
513 PERL_ARGS_ASSERT_TIED_METHOD;
515 /* Ensure that our flag bits do not overlap. */
516 assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
517 assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
518 assert((TIED_METHOD_SAY & G_WANT) == 0);
520 PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
521 PUSHSTACKi(PERLSI_MAGIC);
522 EXTEND(SP, argc+1); /* object + args */
524 PUSHs(SvTIED_obj(sv, mg));
525 if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
526 Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
530 const U32 mortalize_not_needed
531 = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
533 va_start(args, argc);
535 SV *const arg = va_arg(args, SV *);
536 if(mortalize_not_needed)
545 ENTER_with_name("call_tied_method");
546 if (flags & TIED_METHOD_SAY) {
547 /* local $\ = "\n" */
548 SAVEGENERICSV(PL_ors_sv);
549 PL_ors_sv = newSVpvs("\n");
551 ret_args = call_method(methname, flags & G_WANT);
556 if (ret_args) { /* copy results back to original stack */
557 EXTEND(sp, ret_args);
558 Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
562 LEAVE_with_name("call_tied_method");
566 #define tied_method0(a,b,c,d) \
567 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
568 #define tied_method1(a,b,c,d,e) \
569 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
570 #define tied_method2(a,b,c,d,e,f) \
571 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
584 GV * const gv = MUTABLE_GV(*++MARK);
586 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
587 DIE(aTHX_ PL_no_usym, "filehandle");
589 if ((io = GvIOp(gv))) {
591 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
594 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
595 "Opening dirhandle %s also as a file",
598 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
600 /* Method's args are same as ours ... */
601 /* ... except handle is replaced by the object */
602 return Perl_tied_method(aTHX_ "OPEN", mark - 1, MUTABLE_SV(io), mg,
603 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
615 tmps = SvPV_const(sv, len);
616 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
619 PUSHi( (I32)PL_forkprocess );
620 else if (PL_forkprocess == 0) /* we are a new child */
631 MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
637 IO * const io = GvIO(gv);
639 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
641 return tied_method0("CLOSE", SP, MUTABLE_SV(io), mg);
645 PUSHs(boolSV(do_close(gv, TRUE)));
658 GV * const wgv = MUTABLE_GV(POPs);
659 GV * const rgv = MUTABLE_GV(POPs);
664 if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
665 DIE(aTHX_ PL_no_usym, "filehandle");
670 do_close(rgv, FALSE);
672 do_close(wgv, FALSE);
674 if (PerlProc_pipe(fd) < 0)
677 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
678 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
679 IoOFP(rstio) = IoIFP(rstio);
680 IoIFP(wstio) = IoOFP(wstio);
681 IoTYPE(rstio) = IoTYPE_RDONLY;
682 IoTYPE(wstio) = IoTYPE_WRONLY;
684 if (!IoIFP(rstio) || !IoOFP(wstio)) {
686 PerlIO_close(IoIFP(rstio));
688 PerlLIO_close(fd[0]);
690 PerlIO_close(IoOFP(wstio));
692 PerlLIO_close(fd[1]);
695 #if defined(HAS_FCNTL) && defined(F_SETFD)
696 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
697 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
704 DIE(aTHX_ PL_no_func, "pipe");
718 gv = MUTABLE_GV(POPs);
722 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
724 return tied_method0("FILENO", SP, MUTABLE_SV(io), mg);
727 if (!io || !(fp = IoIFP(io))) {
728 /* Can't do this because people seem to do things like
729 defined(fileno($foo)) to check whether $foo is a valid fh.
736 PUSHi(PerlIO_fileno(fp));
748 if (MAXARG < 1 || (!TOPs && !POPs)) {
749 anum = PerlLIO_umask(022);
750 /* setting it to 022 between the two calls to umask avoids
751 * to have a window where the umask is set to 0 -- meaning
752 * that another thread could create world-writeable files. */
754 (void)PerlLIO_umask(anum);
757 anum = PerlLIO_umask(POPi);
758 TAINT_PROPER("umask");
761 /* Only DIE if trying to restrict permissions on "user" (self).
762 * Otherwise it's harmless and more useful to just return undef
763 * since 'group' and 'other' concepts probably don't exist here. */
764 if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
765 DIE(aTHX_ "umask not implemented");
766 XPUSHs(&PL_sv_undef);
785 gv = MUTABLE_GV(POPs);
789 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
791 /* This takes advantage of the implementation of the varargs
792 function, which I don't think that the optimiser will be able to
793 figure out. Although, as it's a static function, in theory it
795 return Perl_tied_method(aTHX_ "BINMODE", SP, MUTABLE_SV(io), mg,
796 G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
797 discp ? 1 : 0, discp);
801 if (!io || !(fp = IoIFP(io))) {
803 SETERRNO(EBADF,RMS_IFI);
810 const char *d = NULL;
813 d = SvPV_const(discp, len);
814 mode = mode_from_discipline(d, len);
815 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
816 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
817 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
838 const I32 markoff = MARK - PL_stack_base;
839 const char *methname;
840 int how = PERL_MAGIC_tied;
844 switch(SvTYPE(varsv)) {
846 methname = "TIEHASH";
847 HvEITER_set(MUTABLE_HV(varsv), 0);
850 methname = "TIEARRAY";
854 if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
855 methname = "TIEHANDLE";
856 how = PERL_MAGIC_tiedscalar;
857 /* For tied filehandles, we apply tiedscalar magic to the IO
858 slot of the GP rather than the GV itself. AMS 20010812 */
860 GvIOp(varsv) = newIO();
861 varsv = MUTABLE_SV(GvIOp(varsv));
866 methname = "TIESCALAR";
867 how = PERL_MAGIC_tiedscalar;
871 if (sv_isobject(*MARK)) { /* Calls GET magic. */
872 ENTER_with_name("call_TIE");
873 PUSHSTACKi(PERLSI_MAGIC);
875 EXTEND(SP,(I32)items);
879 call_method(methname, G_SCALAR);
882 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
883 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
884 * wrong error message, and worse case, supreme action at a distance.
885 * (Sorry obfuscation writers. You're not going to be given this one.)
888 const char *name = SvPV_nomg_const(*MARK, len);
889 stash = gv_stashpvn(name, len, 0);
890 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
891 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
892 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
894 ENTER_with_name("call_TIE");
895 PUSHSTACKi(PERLSI_MAGIC);
897 EXTEND(SP,(I32)items);
901 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
907 if (sv_isobject(sv)) {
908 sv_unmagic(varsv, how);
909 /* Croak if a self-tie on an aggregate is attempted. */
910 if (varsv == SvRV(sv) &&
911 (SvTYPE(varsv) == SVt_PVAV ||
912 SvTYPE(varsv) == SVt_PVHV))
914 "Self-ties of arrays and hashes are not supported");
915 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
917 LEAVE_with_name("call_TIE");
918 SP = PL_stack_base + markoff;
928 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
929 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
931 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
934 if ((mg = SvTIED_mg(sv, how))) {
935 SV * const obj = SvRV(SvTIED_obj(sv, mg));
937 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
939 if (gv && isGV(gv) && (cv = GvCV(gv))) {
941 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
942 mXPUSHi(SvREFCNT(obj) - 1);
944 ENTER_with_name("call_UNTIE");
945 call_sv(MUTABLE_SV(cv), G_VOID);
946 LEAVE_with_name("call_UNTIE");
949 else if (mg && SvREFCNT(obj) > 1) {
950 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
951 "untie attempted while %"UVuf" inner references still exist",
952 (UV)SvREFCNT(obj) - 1 ) ;
956 sv_unmagic(sv, how) ;
966 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
967 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
969 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
972 if ((mg = SvTIED_mg(sv, how))) {
973 SV *osv = SvTIED_obj(sv, mg);
974 if (osv == mg->mg_obj)
975 osv = sv_mortalcopy(osv);
989 HV * const hv = MUTABLE_HV(POPs);
990 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
991 stash = gv_stashsv(sv, 0);
992 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
994 require_pv("AnyDBM_File.pm");
996 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
997 DIE(aTHX_ "No dbm on this machine");
1007 mPUSHu(O_RDWR|O_CREAT);
1012 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1015 if (!sv_isobject(TOPs)) {
1023 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1027 if (sv_isobject(TOPs)) {
1028 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1029 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1046 struct timeval timebuf;
1047 struct timeval *tbuf = &timebuf;
1050 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1055 # if BYTEORDER & 0xf0000
1056 # define ORDERBYTE (0x88888888 - BYTEORDER)
1058 # define ORDERBYTE (0x4444 - BYTEORDER)
1064 for (i = 1; i <= 3; i++) {
1065 SV * const sv = SP[i];
1068 if (SvREADONLY(sv)) {
1070 sv_force_normal_flags(sv, 0);
1071 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1072 Perl_croak_no_modify(aTHX);
1075 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1076 SvPV_force_nolen(sv); /* force string conversion */
1083 /* little endians can use vecs directly */
1084 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1091 masksize = NFDBITS / NBBY;
1093 masksize = sizeof(long); /* documented int, everyone seems to use long */
1095 Zero(&fd_sets[0], 4, char*);
1098 # if SELECT_MIN_BITS == 1
1099 growsize = sizeof(fd_set);
1101 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1102 # undef SELECT_MIN_BITS
1103 # define SELECT_MIN_BITS __FD_SETSIZE
1105 /* If SELECT_MIN_BITS is greater than one we most probably will want
1106 * to align the sizes with SELECT_MIN_BITS/8 because for example
1107 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1108 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1109 * on (sets/tests/clears bits) is 32 bits. */
1110 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1118 timebuf.tv_sec = (long)value;
1119 value -= (NV)timebuf.tv_sec;
1120 timebuf.tv_usec = (long)(value * 1000000.0);
1125 for (i = 1; i <= 3; i++) {
1127 if (!SvOK(sv) || SvCUR(sv) == 0) {
1134 Sv_Grow(sv, growsize);
1138 while (++j <= growsize) {
1142 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1144 Newx(fd_sets[i], growsize, char);
1145 for (offset = 0; offset < growsize; offset += masksize) {
1146 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1147 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1150 fd_sets[i] = SvPVX(sv);
1154 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1155 /* Can't make just the (void*) conditional because that would be
1156 * cpp #if within cpp macro, and not all compilers like that. */
1157 nfound = PerlSock_select(
1159 (Select_fd_set_t) fd_sets[1],
1160 (Select_fd_set_t) fd_sets[2],
1161 (Select_fd_set_t) fd_sets[3],
1162 (void*) tbuf); /* Workaround for compiler bug. */
1164 nfound = PerlSock_select(
1166 (Select_fd_set_t) fd_sets[1],
1167 (Select_fd_set_t) fd_sets[2],
1168 (Select_fd_set_t) fd_sets[3],
1171 for (i = 1; i <= 3; i++) {
1174 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1176 for (offset = 0; offset < growsize; offset += masksize) {
1177 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1178 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1180 Safefree(fd_sets[i]);
1187 if (GIMME == G_ARRAY && tbuf) {
1188 value = (NV)(timebuf.tv_sec) +
1189 (NV)(timebuf.tv_usec) / 1000000.0;
1194 DIE(aTHX_ "select not implemented");
1199 =for apidoc setdefout
1201 Sets PL_defoutgv, the default file handle for output, to the passed in
1202 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1203 count of the passed in typeglob is increased by one, and the reference count
1204 of the typeglob that PL_defoutgv points to is decreased by one.
1210 Perl_setdefout(pTHX_ GV *gv)
1213 SvREFCNT_inc_simple_void(gv);
1214 SvREFCNT_dec(PL_defoutgv);
1222 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1223 GV * egv = GvEGVx(PL_defoutgv);
1227 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1229 XPUSHs(&PL_sv_undef);
1231 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1232 if (gvp && *gvp == egv) {
1233 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1237 mXPUSHs(newRV(MUTABLE_SV(egv)));
1242 if (!GvIO(newdefout))
1243 gv_IOadd(newdefout);
1244 setdefout(newdefout);
1254 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1255 IO *const io = GvIO(gv);
1261 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1263 const U32 gimme = GIMME_V;
1264 Perl_tied_method(aTHX_ "GETC", SP, MUTABLE_SV(io), mg, gimme, 0);
1265 if (gimme == G_SCALAR) {
1267 SvSetMagicSV_nosteal(TARG, TOPs);
1272 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1273 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1275 SETERRNO(EBADF,RMS_IFI);
1279 sv_setpvs(TARG, " ");
1280 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1281 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1282 /* Find out how many bytes the char needs */
1283 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1286 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1287 SvCUR_set(TARG,1+len);
1296 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1299 register PERL_CONTEXT *cx;
1300 const I32 gimme = GIMME_V;
1302 PERL_ARGS_ASSERT_DOFORM;
1304 if (cv && CvCLONE(cv))
1305 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1310 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1311 PUSHFORMAT(cx, retop);
1313 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1315 setdefout(gv); /* locally select filehandle so $% et al work */
1334 gv = MUTABLE_GV(POPs);
1348 goto not_a_format_reference;
1353 tmpsv = sv_newmortal();
1354 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1355 name = SvPV_nolen_const(tmpsv);
1357 DIE(aTHX_ "Undefined format \"%s\" called", name);
1359 not_a_format_reference:
1360 DIE(aTHX_ "Not a format reference");
1362 IoFLAGS(io) &= ~IOf_DIDTOP;
1363 return doform(cv,gv,PL_op->op_next);
1369 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1370 register IO * const io = GvIOp(gv);
1375 register PERL_CONTEXT *cx;
1378 if (!io || !(ofp = IoOFP(io)))
1381 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1382 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1384 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1385 PL_formtarget != PL_toptarget)
1389 if (!IoTOP_GV(io)) {
1392 if (!IoTOP_NAME(io)) {
1394 if (!IoFMT_NAME(io))
1395 IoFMT_NAME(io) = savepv(GvNAME(gv));
1396 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1397 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1398 if ((topgv && GvFORM(topgv)) ||
1399 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1400 IoTOP_NAME(io) = savesvpv(topname);
1402 IoTOP_NAME(io) = savepvs("top");
1404 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1405 if (!topgv || !GvFORM(topgv)) {
1406 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1409 IoTOP_GV(io) = topgv;
1411 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1412 I32 lines = IoLINES_LEFT(io);
1413 const char *s = SvPVX_const(PL_formtarget);
1414 if (lines <= 0) /* Yow, header didn't even fit!!! */
1416 while (lines-- > 0) {
1417 s = strchr(s, '\n');
1423 const STRLEN save = SvCUR(PL_formtarget);
1424 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1425 do_print(PL_formtarget, ofp);
1426 SvCUR_set(PL_formtarget, save);
1427 sv_chop(PL_formtarget, s);
1428 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1431 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1432 do_print(PL_formfeed, ofp);
1433 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1435 PL_formtarget = PL_toptarget;
1436 IoFLAGS(io) |= IOf_DIDTOP;
1439 DIE(aTHX_ "bad top format reference");
1442 SV * const sv = sv_newmortal();
1444 gv_efullname4(sv, fgv, NULL, FALSE);
1445 name = SvPV_nolen_const(sv);
1447 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1449 DIE(aTHX_ "Undefined top format called");
1451 return doform(cv, gv, PL_op);
1455 POPBLOCK(cx,PL_curpm);
1457 retop = cx->blk_sub.retop;
1463 report_wrongway_fh(gv, '<');
1469 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1470 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1472 if (!do_print(PL_formtarget, fp))
1475 FmLINES(PL_formtarget) = 0;
1476 SvCUR_set(PL_formtarget, 0);
1477 *SvEND(PL_formtarget) = '\0';
1478 if (IoFLAGS(io) & IOf_FLUSH)
1479 (void)PerlIO_flush(fp);
1484 PL_formtarget = PL_bodytarget;
1486 PERL_UNUSED_VAR(newsp);
1487 PERL_UNUSED_VAR(gimme);
1493 dVAR; dSP; dMARK; dORIGMARK;
1498 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1499 IO *const io = GvIO(gv);
1502 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1504 if (MARK == ORIGMARK) {
1507 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1510 return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io),
1512 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1520 SETERRNO(EBADF,RMS_IFI);
1523 else if (!(fp = IoOFP(io))) {
1525 report_wrongway_fh(gv, '<');
1526 else if (ckWARN(WARN_CLOSED))
1528 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1532 do_sprintf(sv, SP - MARK, MARK + 1);
1533 if (!do_print(sv, fp))
1536 if (IoFLAGS(io) & IOf_FLUSH)
1537 if (PerlIO_flush(fp) == EOF)
1548 PUSHs(&PL_sv_undef);
1556 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1557 const int mode = POPi;
1558 SV * const sv = POPs;
1559 GV * const gv = MUTABLE_GV(POPs);
1562 /* Need TIEHANDLE method ? */
1563 const char * const tmps = SvPV_const(sv, len);
1564 /* FIXME? do_open should do const */
1565 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1566 IoLINES(GvIOp(gv)) = 0;
1570 PUSHs(&PL_sv_undef);
1577 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1583 Sock_size_t bufsize;
1591 bool charstart = FALSE;
1592 STRLEN charskip = 0;
1595 GV * const gv = MUTABLE_GV(*++MARK);
1596 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1597 && gv && (io = GvIO(gv)) )
1599 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1601 return Perl_tied_method(aTHX_ "READ", mark - 1, MUTABLE_SV(io), mg,
1602 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1611 sv_setpvs(bufsv, "");
1612 length = SvIVx(*++MARK);
1615 offset = SvIVx(*++MARK);
1619 if (!io || !IoIFP(io)) {
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);
1660 /* MSG_TRUNC can give oversized count; quietly lose it */
1664 /* Bogus return without padding */
1665 bufsize = sizeof (struct sockaddr_in);
1667 SvCUR_set(bufsv, count);
1668 *SvEND(bufsv) = '\0';
1669 (void)SvPOK_only(bufsv);
1673 /* This should not be marked tainted if the fp is marked clean */
1674 if (!(IoFLAGS(io) & IOf_UNTAINT))
1675 SvTAINTED_on(bufsv);
1677 sv_setpvn(TARG, namebuf, bufsize);
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)
1760 report_wrongway_fh(gv, '>');
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;
1826 STRLEN orig_blen_bytes;
1827 const int op_type = PL_op->op_type;
1830 GV *const gv = MUTABLE_GV(*++MARK);
1831 IO *const io = GvIO(gv);
1833 if (op_type == OP_SYSWRITE && io) {
1834 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1836 if (MARK == SP - 1) {
1838 mXPUSHi(sv_len(sv));
1842 return Perl_tied_method(aTHX_ "WRITE", mark - 1, MUTABLE_SV(io), mg,
1843 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1853 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1855 if (io && IoIFP(io))
1856 report_wrongway_fh(gv, '<');
1859 SETERRNO(EBADF,RMS_IFI);
1863 /* Do this first to trigger any overloading. */
1864 buffer = SvPV_const(bufsv, blen);
1865 orig_blen_bytes = blen;
1866 doing_utf8 = DO_UTF8(bufsv);
1868 if (PerlIO_isutf8(IoIFP(io))) {
1869 if (!SvUTF8(bufsv)) {
1870 /* We don't modify the original scalar. */
1871 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1872 buffer = (char *) tmpbuf;
1876 else if (doing_utf8) {
1877 STRLEN tmplen = blen;
1878 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1881 buffer = (char *) tmpbuf;
1885 assert((char *)result == buffer);
1886 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1891 if (op_type == OP_SEND) {
1892 const int flags = SvIVx(*++MARK);
1895 char * const sockbuf = SvPVx(*++MARK, mlen);
1896 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1897 flags, (struct sockaddr *)sockbuf, mlen);
1901 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1907 Size_t length = 0; /* This length is in characters. */
1913 /* The SV is bytes, and we've had to upgrade it. */
1914 blen_chars = orig_blen_bytes;
1916 /* The SV really is UTF-8. */
1917 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1918 /* Don't call sv_len_utf8 again because it will call magic
1919 or overloading a second time, and we might get back a
1920 different result. */
1921 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1923 /* It's safe, and it may well be cached. */
1924 blen_chars = sv_len_utf8(bufsv);
1932 length = blen_chars;
1934 #if Size_t_size > IVSIZE
1935 length = (Size_t)SvNVx(*++MARK);
1937 length = (Size_t)SvIVx(*++MARK);
1939 if ((SSize_t)length < 0) {
1941 DIE(aTHX_ "Negative length");
1946 offset = SvIVx(*++MARK);
1948 if (-offset > (IV)blen_chars) {
1950 DIE(aTHX_ "Offset outside string");
1952 offset += blen_chars;
1953 } else if (offset > (IV)blen_chars) {
1955 DIE(aTHX_ "Offset outside string");
1959 if (length > blen_chars - offset)
1960 length = blen_chars - offset;
1962 /* Here we convert length from characters to bytes. */
1963 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1964 /* Either we had to convert the SV, or the SV is magical, or
1965 the SV has overloading, in which case we can't or mustn't
1966 or mustn't call it again. */
1968 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1969 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1971 /* It's a real UTF-8 SV, and it's not going to change under
1972 us. Take advantage of any cache. */
1974 I32 len_I32 = length;
1976 /* Convert the start and end character positions to bytes.
1977 Remember that the second argument to sv_pos_u2b is relative
1979 sv_pos_u2b(bufsv, &start, &len_I32);
1986 buffer = buffer+offset;
1988 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1989 if (IoTYPE(io) == IoTYPE_SOCKET) {
1990 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1996 /* See the note at doio.c:do_print about filesize limits. --jhi */
1997 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2006 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2009 #if Size_t_size > IVSIZE
2029 * in Perl 5.12 and later, the additional parameter is a bitmask:
2032 * 2 = eof() <- ARGV magic
2034 * I'll rely on the compiler's trace flow analysis to decide whether to
2035 * actually assign this out here, or punt it into the only block where it is
2036 * used. Doing it out here is DRY on the condition logic.
2041 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2047 if (PL_op->op_flags & OPf_SPECIAL) {
2048 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2052 gv = PL_last_in_gv; /* eof */
2060 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2061 return tied_method1("EOF", SP, MUTABLE_SV(io), mg, newSVuv(which));
2064 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2065 if (io && !IoIFP(io)) {
2066 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2068 IoFLAGS(io) &= ~IOf_START;
2069 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2071 sv_setpvs(GvSV(gv), "-");
2073 GvSV(gv) = newSVpvs("-");
2074 SvSETMAGIC(GvSV(gv));
2076 else if (!nextargv(gv))
2081 PUSHs(boolSV(do_eof(gv)));
2091 if (MAXARG != 0 && (TOPs || POPs))
2092 PL_last_in_gv = MUTABLE_GV(POPs);
2099 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2101 return tied_method0("TELL", SP, MUTABLE_SV(io), mg);
2106 SETERRNO(EBADF,RMS_IFI);
2111 #if LSEEKSIZE > IVSIZE
2112 PUSHn( do_tell(gv) );
2114 PUSHi( do_tell(gv) );
2122 const int whence = POPi;
2123 #if LSEEKSIZE > IVSIZE
2124 const Off_t offset = (Off_t)SvNVx(POPs);
2126 const Off_t offset = (Off_t)SvIVx(POPs);
2129 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2130 IO *const io = GvIO(gv);
2133 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2135 #if LSEEKSIZE > IVSIZE
2136 SV *const offset_sv = newSVnv((NV) offset);
2138 SV *const offset_sv = newSViv(offset);
2141 return tied_method2("SEEK", SP, MUTABLE_SV(io), mg, offset_sv,
2146 if (PL_op->op_type == OP_SEEK)
2147 PUSHs(boolSV(do_seek(gv, offset, whence)));
2149 const Off_t sought = do_sysseek(gv, offset, whence);
2151 PUSHs(&PL_sv_undef);
2153 SV* const sv = sought ?
2154 #if LSEEKSIZE > IVSIZE
2159 : newSVpvn(zero_but_true, ZBTLEN);
2170 /* There seems to be no consensus on the length type of truncate()
2171 * and ftruncate(), both off_t and size_t have supporters. In
2172 * general one would think that when using large files, off_t is
2173 * at least as wide as size_t, so using an off_t should be okay. */
2174 /* XXX Configure probe for the length type of *truncate() needed XXX */
2177 #if Off_t_size > IVSIZE
2182 /* Checking for length < 0 is problematic as the type might or
2183 * might not be signed: if it is not, clever compilers will moan. */
2184 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2187 SV * const sv = POPs;
2192 if ((tmpgv = PL_op->op_flags & OPf_SPECIAL
2193 ? gv_fetchsv(sv, 0, SVt_PVIO)
2194 : MAYBE_DEREF_GV(sv) )) {
2201 TAINT_PROPER("truncate");
2202 if (!(fp = IoIFP(io))) {
2208 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2210 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2216 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2217 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2218 goto do_ftruncate_io;
2221 const char * const name = SvPV_nomg_const_nolen(sv);
2222 TAINT_PROPER("truncate");
2224 if (truncate(name, len) < 0)
2228 const int tmpfd = PerlLIO_open(name, O_RDWR);
2233 if (my_chsize(tmpfd, len) < 0)
2235 PerlLIO_close(tmpfd);
2244 SETERRNO(EBADF,RMS_IFI);
2252 SV * const argsv = POPs;
2253 const unsigned int func = POPu;
2254 const int optype = PL_op->op_type;
2255 GV * const gv = MUTABLE_GV(POPs);
2256 IO * const io = gv ? GvIOn(gv) : NULL;
2260 if (!io || !argsv || !IoIFP(io)) {
2262 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2266 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2269 s = SvPV_force(argsv, len);
2270 need = IOCPARM_LEN(func);
2272 s = Sv_Grow(argsv, need + 1);
2273 SvCUR_set(argsv, need);
2276 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2279 retval = SvIV(argsv);
2280 s = INT2PTR(char*,retval); /* ouch */
2283 TAINT_PROPER(PL_op_desc[optype]);
2285 if (optype == OP_IOCTL)
2287 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2289 DIE(aTHX_ "ioctl is not implemented");
2293 DIE(aTHX_ "fcntl is not implemented");
2295 #if defined(OS2) && defined(__EMX__)
2296 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2298 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2302 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2304 if (s[SvCUR(argsv)] != 17)
2305 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2307 s[SvCUR(argsv)] = 0; /* put our null back */
2308 SvSETMAGIC(argsv); /* Assume it has changed */
2317 PUSHp(zero_but_true, ZBTLEN);
2328 const int argtype = POPi;
2329 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
2330 IO *const io = GvIO(gv);
2331 PerlIO *const fp = io ? IoIFP(io) : NULL;
2333 /* XXX Looks to me like io is always NULL at this point */
2335 (void)PerlIO_flush(fp);
2336 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2341 SETERRNO(EBADF,RMS_IFI);
2346 DIE(aTHX_ PL_no_func, "flock()");
2357 const int protocol = POPi;
2358 const int type = POPi;
2359 const int domain = POPi;
2360 GV * const gv = MUTABLE_GV(POPs);
2361 register IO * const io = gv ? GvIOn(gv) : NULL;
2366 if (io && IoIFP(io))
2367 do_close(gv, FALSE);
2368 SETERRNO(EBADF,LIB_INVARG);
2373 do_close(gv, FALSE);
2375 TAINT_PROPER("socket");
2376 fd = PerlSock_socket(domain, type, protocol);
2379 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2380 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2381 IoTYPE(io) = IoTYPE_SOCKET;
2382 if (!IoIFP(io) || !IoOFP(io)) {
2383 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2384 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2385 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2388 #if defined(HAS_FCNTL) && defined(F_SETFD)
2389 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2393 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2402 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2404 const int protocol = POPi;
2405 const int type = POPi;
2406 const int domain = POPi;
2407 GV * const gv2 = MUTABLE_GV(POPs);
2408 GV * const gv1 = MUTABLE_GV(POPs);
2409 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2410 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2414 report_evil_fh(gv1);
2416 report_evil_fh(gv2);
2418 if (io1 && IoIFP(io1))
2419 do_close(gv1, FALSE);
2420 if (io2 && IoIFP(io2))
2421 do_close(gv2, FALSE);
2426 TAINT_PROPER("socketpair");
2427 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2429 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2430 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2431 IoTYPE(io1) = IoTYPE_SOCKET;
2432 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2433 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2434 IoTYPE(io2) = IoTYPE_SOCKET;
2435 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2436 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2437 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2438 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2439 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2440 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2441 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2444 #if defined(HAS_FCNTL) && defined(F_SETFD)
2445 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2446 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2451 DIE(aTHX_ PL_no_sock_func, "socketpair");
2460 SV * const addrsv = POPs;
2461 /* OK, so on what platform does bind modify addr? */
2463 GV * const gv = MUTABLE_GV(POPs);
2464 register IO * const io = GvIOn(gv);
2466 const int op_type = PL_op->op_type;
2468 if (!io || !IoIFP(io))
2471 addr = SvPV_const(addrsv, len);
2472 TAINT_PROPER(PL_op_desc[op_type]);
2473 if ((op_type == OP_BIND
2474 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2475 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2483 SETERRNO(EBADF,SS_IVCHAN);
2490 const int backlog = POPi;
2491 GV * const gv = MUTABLE_GV(POPs);
2492 register IO * const io = gv ? GvIOn(gv) : NULL;
2494 if (!io || !IoIFP(io))
2497 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2504 SETERRNO(EBADF,SS_IVCHAN);
2513 char namebuf[MAXPATHLEN];
2514 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2515 Sock_size_t len = sizeof (struct sockaddr_in);
2517 Sock_size_t len = sizeof namebuf;
2519 GV * const ggv = MUTABLE_GV(POPs);
2520 GV * const ngv = MUTABLE_GV(POPs);
2529 if (!gstio || !IoIFP(gstio))
2533 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2536 /* Some platforms indicate zero length when an AF_UNIX client is
2537 * not bound. Simulate a non-zero-length sockaddr structure in
2539 namebuf[0] = 0; /* sun_len */
2540 namebuf[1] = AF_UNIX; /* sun_family */
2548 do_close(ngv, FALSE);
2549 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2550 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2551 IoTYPE(nstio) = IoTYPE_SOCKET;
2552 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2553 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2554 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2555 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2558 #if defined(HAS_FCNTL) && defined(F_SETFD)
2559 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2563 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2564 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2566 #ifdef __SCO_VERSION__
2567 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2570 PUSHp(namebuf, len);
2574 report_evil_fh(ggv);
2575 SETERRNO(EBADF,SS_IVCHAN);
2585 const int how = POPi;
2586 GV * const gv = MUTABLE_GV(POPs);
2587 register IO * const io = GvIOn(gv);
2589 if (!io || !IoIFP(io))
2592 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2597 SETERRNO(EBADF,SS_IVCHAN);
2604 const int optype = PL_op->op_type;
2605 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2606 const unsigned int optname = (unsigned int) POPi;
2607 const unsigned int lvl = (unsigned int) POPi;
2608 GV * const gv = MUTABLE_GV(POPs);
2609 register IO * const io = GvIOn(gv);
2613 if (!io || !IoIFP(io))
2616 fd = PerlIO_fileno(IoIFP(io));
2620 (void)SvPOK_only(sv);
2624 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2631 #if defined(__SYMBIAN32__)
2632 # define SETSOCKOPT_OPTION_VALUE_T void *
2634 # define SETSOCKOPT_OPTION_VALUE_T const char *
2636 /* XXX TODO: We need to have a proper type (a Configure probe,
2637 * etc.) for what the C headers think of the third argument of
2638 * setsockopt(), the option_value read-only buffer: is it
2639 * a "char *", or a "void *", const or not. Some compilers
2640 * don't take kindly to e.g. assuming that "char *" implicitly
2641 * promotes to a "void *", or to explicitly promoting/demoting
2642 * consts to non/vice versa. The "const void *" is the SUS
2643 * definition, but that does not fly everywhere for the above
2645 SETSOCKOPT_OPTION_VALUE_T buf;
2649 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2653 aint = (int)SvIV(sv);
2654 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2657 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2667 SETERRNO(EBADF,SS_IVCHAN);
2676 const int optype = PL_op->op_type;
2677 GV * const gv = MUTABLE_GV(POPs);
2678 register IO * const io = GvIOn(gv);
2683 if (!io || !IoIFP(io))
2686 sv = sv_2mortal(newSV(257));
2687 (void)SvPOK_only(sv);
2691 fd = PerlIO_fileno(IoIFP(io));
2693 case OP_GETSOCKNAME:
2694 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2697 case OP_GETPEERNAME:
2698 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2700 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2702 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";
2703 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2704 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2705 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2706 sizeof(u_short) + sizeof(struct in_addr))) {
2713 #ifdef BOGUS_GETNAME_RETURN
2714 /* Interactive Unix, getpeername() and getsockname()
2715 does not return valid namelen */
2716 if (len == BOGUS_GETNAME_RETURN)
2717 len = sizeof(struct sockaddr);
2726 SETERRNO(EBADF,SS_IVCHAN);
2745 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2746 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2747 if (PL_op->op_type == OP_LSTAT) {
2748 if (gv != PL_defgv) {
2749 do_fstat_warning_check:
2750 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2751 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2752 } else if (PL_laststype != OP_LSTAT)
2753 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2754 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2757 if (gv != PL_defgv) {
2758 PL_laststype = OP_STAT;
2760 sv_setpvs(PL_statname, "");
2767 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2768 } else if (IoDIRP(io)) {
2770 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2772 PL_laststatval = -1;
2778 if (PL_laststatval < 0) {
2784 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2785 io = MUTABLE_IO(SvRV(sv));
2786 if (PL_op->op_type == OP_LSTAT)
2787 goto do_fstat_warning_check;
2788 goto do_fstat_have_io;
2791 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2793 PL_laststype = PL_op->op_type;
2794 if (PL_op->op_type == OP_LSTAT)
2795 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2797 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2798 if (PL_laststatval < 0) {
2799 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2800 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2806 if (gimme != G_ARRAY) {
2807 if (gimme != G_VOID)
2808 XPUSHs(boolSV(max));
2814 mPUSHi(PL_statcache.st_dev);
2815 #if ST_INO_SIZE > IVSIZE
2816 mPUSHn(PL_statcache.st_ino);
2818 # if ST_INO_SIGN <= 0
2819 mPUSHi(PL_statcache.st_ino);
2821 mPUSHu(PL_statcache.st_ino);
2824 mPUSHu(PL_statcache.st_mode);
2825 mPUSHu(PL_statcache.st_nlink);
2826 #if Uid_t_size > IVSIZE
2827 mPUSHn(PL_statcache.st_uid);
2829 # if Uid_t_sign <= 0
2830 mPUSHi(PL_statcache.st_uid);
2832 mPUSHu(PL_statcache.st_uid);
2835 #if Gid_t_size > IVSIZE
2836 mPUSHn(PL_statcache.st_gid);
2838 # if Gid_t_sign <= 0
2839 mPUSHi(PL_statcache.st_gid);
2841 mPUSHu(PL_statcache.st_gid);
2844 #ifdef USE_STAT_RDEV
2845 mPUSHi(PL_statcache.st_rdev);
2847 PUSHs(newSVpvs_flags("", SVs_TEMP));
2849 #if Off_t_size > IVSIZE
2850 mPUSHn(PL_statcache.st_size);
2852 mPUSHi(PL_statcache.st_size);
2855 mPUSHn(PL_statcache.st_atime);
2856 mPUSHn(PL_statcache.st_mtime);
2857 mPUSHn(PL_statcache.st_ctime);
2859 mPUSHi(PL_statcache.st_atime);
2860 mPUSHi(PL_statcache.st_mtime);
2861 mPUSHi(PL_statcache.st_ctime);
2863 #ifdef USE_STAT_BLOCKS
2864 mPUSHu(PL_statcache.st_blksize);
2865 mPUSHu(PL_statcache.st_blocks);
2867 PUSHs(newSVpvs_flags("", SVs_TEMP));
2868 PUSHs(newSVpvs_flags("", SVs_TEMP));
2874 #define tryAMAGICftest_MG(chr) STMT_START { \
2875 if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
2876 && PL_op->op_flags & OPf_KIDS \
2877 && S_try_amagic_ftest(aTHX_ chr)) \
2882 S_try_amagic_ftest(pTHX_ char chr) {
2885 SV* const arg = TOPs;
2892 const char tmpchr = chr;
2893 SV * const tmpsv = amagic_call(arg,
2894 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2895 ftest_amg, AMGf_unary);
2902 if (PL_op->op_private & OPpFT_STACKING) {
2904 /* leave the object alone */
2916 /* This macro is used by the stacked filetest operators :
2917 * if the previous filetest failed, short-circuit and pass its value.
2918 * Else, discard it from the stack and continue. --rgs
2920 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2921 if (!SvTRUE(TOPs)) { RETURN; } \
2922 else { (void)POPs; PUTBACK; } \
2929 /* Not const, because things tweak this below. Not bool, because there's
2930 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2931 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2932 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2933 /* Giving some sort of initial value silences compilers. */
2935 int access_mode = R_OK;
2937 int access_mode = 0;
2940 /* access_mode is never used, but leaving use_access in makes the
2941 conditional compiling below much clearer. */
2944 Mode_t stat_mode = S_IRUSR;
2946 bool effective = FALSE;
2950 switch (PL_op->op_type) {
2951 case OP_FTRREAD: opchar = 'R'; break;
2952 case OP_FTRWRITE: opchar = 'W'; break;
2953 case OP_FTREXEC: opchar = 'X'; break;
2954 case OP_FTEREAD: opchar = 'r'; break;
2955 case OP_FTEWRITE: opchar = 'w'; break;
2956 case OP_FTEEXEC: opchar = 'x'; break;
2958 tryAMAGICftest_MG(opchar);
2960 STACKED_FTEST_CHECK;
2962 switch (PL_op->op_type) {
2964 #if !(defined(HAS_ACCESS) && defined(R_OK))
2970 #if defined(HAS_ACCESS) && defined(W_OK)
2975 stat_mode = S_IWUSR;
2979 #if defined(HAS_ACCESS) && defined(X_OK)
2984 stat_mode = S_IXUSR;
2988 #ifdef PERL_EFF_ACCESS
2991 stat_mode = S_IWUSR;
2995 #ifndef PERL_EFF_ACCESS
3002 #ifdef PERL_EFF_ACCESS
3007 stat_mode = S_IXUSR;
3013 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3014 const char *name = POPpx;
3016 # ifdef PERL_EFF_ACCESS
3017 result = PERL_EFF_ACCESS(name, access_mode);
3019 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3025 result = access(name, access_mode);
3027 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3038 result = my_stat_flags(0);
3042 if (cando(stat_mode, effective, &PL_statcache))
3051 const int op_type = PL_op->op_type;
3056 case OP_FTIS: opchar = 'e'; break;
3057 case OP_FTSIZE: opchar = 's'; break;
3058 case OP_FTMTIME: opchar = 'M'; break;
3059 case OP_FTCTIME: opchar = 'C'; break;
3060 case OP_FTATIME: opchar = 'A'; break;
3062 tryAMAGICftest_MG(opchar);
3064 STACKED_FTEST_CHECK;
3066 result = my_stat_flags(0);
3070 if (op_type == OP_FTIS)
3073 /* You can't dTARGET inside OP_FTIS, because you'll get
3074 "panic: pad_sv po" - the op is not flagged to have a target. */
3078 #if Off_t_size > IVSIZE
3079 PUSHn(PL_statcache.st_size);
3081 PUSHi(PL_statcache.st_size);
3085 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3088 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3091 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3105 switch (PL_op->op_type) {
3106 case OP_FTROWNED: opchar = 'O'; break;
3107 case OP_FTEOWNED: opchar = 'o'; break;
3108 case OP_FTZERO: opchar = 'z'; break;
3109 case OP_FTSOCK: opchar = 'S'; break;
3110 case OP_FTCHR: opchar = 'c'; break;
3111 case OP_FTBLK: opchar = 'b'; break;
3112 case OP_FTFILE: opchar = 'f'; break;
3113 case OP_FTDIR: opchar = 'd'; break;
3114 case OP_FTPIPE: opchar = 'p'; break;
3115 case OP_FTSUID: opchar = 'u'; break;
3116 case OP_FTSGID: opchar = 'g'; break;
3117 case OP_FTSVTX: opchar = 'k'; break;
3119 tryAMAGICftest_MG(opchar);
3121 STACKED_FTEST_CHECK;
3123 /* I believe that all these three are likely to be defined on most every
3124 system these days. */
3126 if(PL_op->op_type == OP_FTSUID) {
3127 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3133 if(PL_op->op_type == OP_FTSGID) {
3134 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3140 if(PL_op->op_type == OP_FTSVTX) {
3141 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3147 result = my_stat_flags(0);
3151 switch (PL_op->op_type) {
3153 if (PL_statcache.st_uid == PL_uid)
3157 if (PL_statcache.st_uid == PL_euid)
3161 if (PL_statcache.st_size == 0)
3165 if (S_ISSOCK(PL_statcache.st_mode))
3169 if (S_ISCHR(PL_statcache.st_mode))
3173 if (S_ISBLK(PL_statcache.st_mode))
3177 if (S_ISREG(PL_statcache.st_mode))
3181 if (S_ISDIR(PL_statcache.st_mode))
3185 if (S_ISFIFO(PL_statcache.st_mode))
3190 if (PL_statcache.st_mode & S_ISUID)
3196 if (PL_statcache.st_mode & S_ISGID)
3202 if (PL_statcache.st_mode & S_ISVTX)
3216 tryAMAGICftest_MG('l');
3217 STACKED_FTEST_CHECK;
3218 result = my_lstat_flags(0);
3223 if (S_ISLNK(PL_statcache.st_mode))
3238 tryAMAGICftest_MG('t');
3240 STACKED_FTEST_CHECK;
3242 if (PL_op->op_flags & OPf_REF)
3244 else if (!(gv = MAYBE_DEREF_GV_nomg(TOPs))) {
3246 name = SvPV_nomg(tmpsv, namelen);
3247 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3250 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3251 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3252 else if (tmpsv && SvOK(tmpsv)) {
3260 if (PerlLIO_isatty(fd))
3265 #if defined(atarist) /* this will work with atariST. Configure will
3266 make guesses for other systems. */
3267 # define FILE_base(f) ((f)->_base)
3268 # define FILE_ptr(f) ((f)->_ptr)
3269 # define FILE_cnt(f) ((f)->_cnt)
3270 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3281 register STDCHAR *s;
3287 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3289 STACKED_FTEST_CHECK;
3291 if (PL_op->op_flags & OPf_REF)
3293 else gv = MAYBE_DEREF_GV_nomg(TOPs);
3297 if (gv == PL_defgv) {
3299 io = GvIO(PL_statgv);
3302 goto really_filename;
3307 PL_laststatval = -1;
3308 sv_setpvs(PL_statname, "");
3309 io = GvIO(PL_statgv);
3311 if (io && IoIFP(io)) {
3312 if (! PerlIO_has_base(IoIFP(io)))
3313 DIE(aTHX_ "-T and -B not implemented on filehandles");
3314 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3315 if (PL_laststatval < 0)
3317 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3318 if (PL_op->op_type == OP_FTTEXT)
3323 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3324 i = PerlIO_getc(IoIFP(io));
3326 (void)PerlIO_ungetc(IoIFP(io),i);
3328 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3330 len = PerlIO_get_bufsiz(IoIFP(io));
3331 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3332 /* sfio can have large buffers - limit to 512 */
3337 report_evil_fh(cGVOP_gv);
3338 SETERRNO(EBADF,RMS_IFI);
3346 PL_laststype = OP_STAT;
3347 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3348 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3349 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3351 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3354 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3355 if (PL_laststatval < 0) {
3356 (void)PerlIO_close(fp);
3359 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3360 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3361 (void)PerlIO_close(fp);
3363 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3364 RETPUSHNO; /* special case NFS directories */
3365 RETPUSHYES; /* null file is anything */
3370 /* now scan s to look for textiness */
3371 /* XXX ASCII dependent code */
3373 #if defined(DOSISH) || defined(USEMYBINMODE)
3374 /* ignore trailing ^Z on short files */
3375 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3379 for (i = 0; i < len; i++, s++) {
3380 if (!*s) { /* null never allowed in text */
3385 else if (!(isPRINT(*s) || isSPACE(*s)))
3388 else if (*s & 128) {
3390 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3393 /* utf8 characters don't count as odd */
3394 if (UTF8_IS_START(*s)) {
3395 int ulen = UTF8SKIP(s);
3396 if (ulen < len - i) {
3398 for (j = 1; j < ulen; j++) {
3399 if (!UTF8_IS_CONTINUATION(s[j]))
3402 --ulen; /* loop does extra increment */
3412 *s != '\n' && *s != '\r' && *s != '\b' &&
3413 *s != '\t' && *s != '\f' && *s != 27)
3418 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3429 const char *tmps = NULL;
3433 SV * const sv = POPs;
3434 if (PL_op->op_flags & OPf_SPECIAL) {
3435 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3437 else if (!(gv = MAYBE_DEREF_GV(sv)))
3438 tmps = SvPV_nomg_const_nolen(sv);
3441 if( !gv && (!tmps || !*tmps) ) {
3442 HV * const table = GvHVn(PL_envgv);
3445 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3446 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3448 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3453 deprecate("chdir('') or chdir(undef) as chdir()");
3454 tmps = SvPV_nolen_const(*svp);
3458 TAINT_PROPER("chdir");
3463 TAINT_PROPER("chdir");
3466 IO* const io = GvIO(gv);
3469 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3470 } else if (IoIFP(io)) {
3471 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3475 SETERRNO(EBADF, RMS_IFI);
3481 SETERRNO(EBADF,RMS_IFI);
3485 DIE(aTHX_ PL_no_func, "fchdir");
3489 PUSHi( PerlDir_chdir(tmps) >= 0 );
3491 /* Clear the DEFAULT element of ENV so we'll get the new value
3493 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3500 dVAR; dSP; dMARK; dTARGET;
3501 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3512 char * const tmps = POPpx;
3513 TAINT_PROPER("chroot");
3514 PUSHi( chroot(tmps) >= 0 );
3517 DIE(aTHX_ PL_no_func, "chroot");
3525 const char * const tmps2 = POPpconstx;
3526 const char * const tmps = SvPV_nolen_const(TOPs);
3527 TAINT_PROPER("rename");
3529 anum = PerlLIO_rename(tmps, tmps2);
3531 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3532 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3535 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3536 (void)UNLINK(tmps2);
3537 if (!(anum = link(tmps, tmps2)))
3538 anum = UNLINK(tmps);
3546 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3550 const int op_type = PL_op->op_type;
3554 if (op_type == OP_LINK)
3555 DIE(aTHX_ PL_no_func, "link");
3557 # ifndef HAS_SYMLINK
3558 if (op_type == OP_SYMLINK)
3559 DIE(aTHX_ PL_no_func, "symlink");
3563 const char * const tmps2 = POPpconstx;
3564 const char * const tmps = SvPV_nolen_const(TOPs);
3565 TAINT_PROPER(PL_op_desc[op_type]);
3567 # if defined(HAS_LINK)
3568 # if defined(HAS_SYMLINK)
3569 /* Both present - need to choose which. */
3570 (op_type == OP_LINK) ?
3571 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3573 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3574 PerlLIO_link(tmps, tmps2);
3577 # if defined(HAS_SYMLINK)
3578 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3579 symlink(tmps, tmps2);
3584 SETi( result >= 0 );
3591 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3602 char buf[MAXPATHLEN];
3605 #ifndef INCOMPLETE_TAINTS
3609 len = readlink(tmps, buf, sizeof(buf) - 1);
3616 RETSETUNDEF; /* just pretend it's a normal file */
3620 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3622 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3624 char * const save_filename = filename;
3629 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3631 PERL_ARGS_ASSERT_DOONELINER;
3633 Newx(cmdline, size, char);
3634 my_strlcpy(cmdline, cmd, size);
3635 my_strlcat(cmdline, " ", size);
3636 for (s = cmdline + strlen(cmdline); *filename; ) {
3640 if (s - cmdline < size)
3641 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3642 myfp = PerlProc_popen(cmdline, "r");
3646 SV * const tmpsv = sv_newmortal();
3647 /* Need to save/restore 'PL_rs' ?? */
3648 s = sv_gets(tmpsv, myfp, 0);
3649 (void)PerlProc_pclose(myfp);
3653 #ifdef HAS_SYS_ERRLIST
3658 /* you don't see this */
3659 const char * const errmsg =
3660 #ifdef HAS_SYS_ERRLIST
3668 if (instr(s, errmsg)) {
3675 #define EACCES EPERM
3677 if (instr(s, "cannot make"))
3678 SETERRNO(EEXIST,RMS_FEX);
3679 else if (instr(s, "existing file"))
3680 SETERRNO(EEXIST,RMS_FEX);
3681 else if (instr(s, "ile exists"))
3682 SETERRNO(EEXIST,RMS_FEX);
3683 else if (instr(s, "non-exist"))
3684 SETERRNO(ENOENT,RMS_FNF);
3685 else if (instr(s, "does not exist"))
3686 SETERRNO(ENOENT,RMS_FNF);
3687 else if (instr(s, "not empty"))
3688 SETERRNO(EBUSY,SS_DEVOFFLINE);
3689 else if (instr(s, "cannot access"))
3690 SETERRNO(EACCES,RMS_PRV);
3692 SETERRNO(EPERM,RMS_PRV);
3695 else { /* some mkdirs return no failure indication */
3696 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3697 if (PL_op->op_type == OP_RMDIR)
3702 SETERRNO(EACCES,RMS_PRV); /* a guess */
3711 /* This macro removes trailing slashes from a directory name.
3712 * Different operating and file systems take differently to
3713 * trailing slashes. According to POSIX 1003.1 1996 Edition
3714 * any number of trailing slashes should be allowed.
3715 * Thusly we snip them away so that even non-conforming
3716 * systems are happy.
3717 * We should probably do this "filtering" for all
3718 * the functions that expect (potentially) directory names:
3719 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3720 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3722 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3723 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3726 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3727 (tmps) = savepvn((tmps), (len)); \
3737 const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3739 TRIMSLASHES(tmps,len,copy);
3741 TAINT_PROPER("mkdir");
3743 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3747 SETi( dooneliner("mkdir", tmps) );
3748 oldumask = PerlLIO_umask(0);
3749 PerlLIO_umask(oldumask);
3750 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3765 TRIMSLASHES(tmps,len,copy);
3766 TAINT_PROPER("rmdir");
3768 SETi( PerlDir_rmdir(tmps) >= 0 );
3770 SETi( dooneliner("rmdir", tmps) );
3777 /* Directory calls. */
3781 #if defined(Direntry_t) && defined(HAS_READDIR)
3783 const char * const dirname = POPpconstx;
3784 GV * const gv = MUTABLE_GV(POPs);
3785 register IO * const io = GvIOn(gv);
3790 if ((IoIFP(io) || IoOFP(io)))
3791 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3792 "Opening filehandle %s also as a directory",
3795 PerlDir_close(IoDIRP(io));
3796 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3802 SETERRNO(EBADF,RMS_DIR);
3805 DIE(aTHX_ PL_no_dir_func, "opendir");
3811 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3812 DIE(aTHX_ PL_no_dir_func, "readdir");
3814 #if !defined(I_DIRENT) && !defined(VMS)
3815 Direntry_t *readdir (DIR *);
3821 const I32 gimme = GIMME;
3822 GV * const gv = MUTABLE_GV(POPs);
3823 register const Direntry_t *dp;
3824 register IO * const io = GvIOn(gv);
3826 if (!io || !IoDIRP(io)) {
3827 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3828 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3833 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3837 sv = newSVpvn(dp->d_name, dp->d_namlen);
3839 sv = newSVpv(dp->d_name, 0);
3841 #ifndef INCOMPLETE_TAINTS
3842 if (!(IoFLAGS(io) & IOf_UNTAINT))
3846 } while (gimme == G_ARRAY);
3848 if (!dp && gimme != G_ARRAY)
3855 SETERRNO(EBADF,RMS_ISI);
3856 if (GIMME == G_ARRAY)
3865 #if defined(HAS_TELLDIR) || defined(telldir)
3867 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3868 /* XXX netbsd still seemed to.
3869 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3870 --JHI 1999-Feb-02 */
3871 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3872 long telldir (DIR *);
3874 GV * const gv = MUTABLE_GV(POPs);
3875 register IO * const io = GvIOn(gv);
3877 if (!io || !IoDIRP(io)) {
3878 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3879 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3883 PUSHi( PerlDir_tell(IoDIRP(io)) );
3887 SETERRNO(EBADF,RMS_ISI);
3890 DIE(aTHX_ PL_no_dir_func, "telldir");
3896 #if defined(HAS_SEEKDIR) || defined(seekdir)
3898 const long along = POPl;
3899 GV * const gv = MUTABLE_GV(POPs);
3900 register IO * const io = GvIOn(gv);
3902 if (!io || !IoDIRP(io)) {
3903 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3904 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3907 (void)PerlDir_seek(IoDIRP(io), along);
3912 SETERRNO(EBADF,RMS_ISI);
3915 DIE(aTHX_ PL_no_dir_func, "seekdir");
3921 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3923 GV * const gv = MUTABLE_GV(POPs);
3924 register IO * const io = GvIOn(gv);
3926 if (!io || !IoDIRP(io)) {
3927 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3928 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3931 (void)PerlDir_rewind(IoDIRP(io));
3935 SETERRNO(EBADF,RMS_ISI);
3938 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3944 #if defined(Direntry_t) && defined(HAS_READDIR)
3946 GV * const gv = MUTABLE_GV(POPs);
3947 register IO * const io = GvIOn(gv);
3949 if (!io || !IoDIRP(io)) {
3950 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3951 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3954 #ifdef VOID_CLOSEDIR
3955 PerlDir_close(IoDIRP(io));
3957 if (PerlDir_close(IoDIRP(io)) < 0) {
3958 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3967 SETERRNO(EBADF,RMS_IFI);
3970 DIE(aTHX_ PL_no_dir_func, "closedir");
3974 /* Process control. */
3983 PERL_FLUSHALL_FOR_CHILD;
3984 childpid = PerlProc_fork();
3988 #ifdef THREADS_HAVE_PIDS
3989 PL_ppid = (IV)getppid();
3991 #ifdef PERL_USES_PL_PIDSTATUS
3992 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3998 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4003 PERL_FLUSHALL_FOR_CHILD;
4004 childpid = PerlProc_fork();
4010 DIE(aTHX_ PL_no_func, "fork");
4017 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4022 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4023 childpid = wait4pid(-1, &argflags, 0);
4025 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4030 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4031 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4032 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4034 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4039 DIE(aTHX_ PL_no_func, "wait");
4045 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4047 const int optype = POPi;
4048 const Pid_t pid = TOPi;
4052 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4053 result = wait4pid(pid, &argflags, optype);
4055 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4060 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4061 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4062 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4064 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4069 DIE(aTHX_ PL_no_func, "waitpid");
4075 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4076 #if defined(__LIBCATAMOUNT__)
4077 PL_statusvalue = -1;
4086 while (++MARK <= SP) {
4087 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4092 TAINT_PROPER("system");
4094 PERL_FLUSHALL_FOR_CHILD;
4095 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4101 if (PerlProc_pipe(pp) >= 0)
4103 while ((childpid = PerlProc_fork()) == -1) {
4104 if (errno != EAGAIN) {
4109 PerlLIO_close(pp[0]);
4110 PerlLIO_close(pp[1]);
4117 Sigsave_t ihand,qhand; /* place to save signals during system() */
4121 PerlLIO_close(pp[1]);
4123 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4124 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4127 result = wait4pid(childpid, &status, 0);
4128 } while (result == -1 && errno == EINTR);
4130 (void)rsignal_restore(SIGINT, &ihand);
4131 (void)rsignal_restore(SIGQUIT, &qhand);
4133 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4134 do_execfree(); /* free any memory child malloced on fork */
4141 while (n < sizeof(int)) {
4142 n1 = PerlLIO_read(pp[0],
4143 (void*)(((char*)&errkid)+n),
4149 PerlLIO_close(pp[0]);
4150 if (n) { /* Error */
4151 if (n != sizeof(int))
4152 DIE(aTHX_ "panic: kid popen errno read");
4153 errno = errkid; /* Propagate errno from kid */
4154 STATUS_NATIVE_CHILD_SET(-1);
4157 XPUSHi(STATUS_CURRENT);
4161 PerlLIO_close(pp[0]);
4162 #if defined(HAS_FCNTL) && defined(F_SETFD)
4163 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4166 if (PL_op->op_flags & OPf_STACKED) {
4167 SV * const really = *++MARK;
4168 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4170 else if (SP - MARK != 1)
4171 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4173 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4177 #else /* ! FORK or VMS or OS/2 */
4180 if (PL_op->op_flags & OPf_STACKED) {
4181 SV * const really = *++MARK;
4182 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4183 value = (I32)do_aspawn(really, MARK, SP);
4185 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4188 else if (SP - MARK != 1) {
4189 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4190 value = (I32)do_aspawn(NULL, MARK, SP);
4192 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4196 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4198 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4200 STATUS_NATIVE_CHILD_SET(value);
4203 XPUSHi(result ? value : STATUS_CURRENT);
4204 #endif /* !FORK or VMS or OS/2 */
4211 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4216 while (++MARK <= SP) {
4217 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4222 TAINT_PROPER("exec");
4224 PERL_FLUSHALL_FOR_CHILD;
4225 if (PL_op->op_flags & OPf_STACKED) {
4226 SV * const really = *++MARK;
4227 value = (I32)do_aexec(really, MARK, SP);
4229 else if (SP - MARK != 1)
4231 value = (I32)vms_do_aexec(NULL, MARK, SP);
4235 (void ) do_aspawn(NULL, MARK, SP);
4239 value = (I32)do_aexec(NULL, MARK, SP);
4244 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4247 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4250 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4264 # ifdef THREADS_HAVE_PIDS
4265 if (PL_ppid != 1 && getppid() == 1)
4266 /* maybe the parent process has died. Refresh ppid cache */
4270 XPUSHi( getppid() );
4274 DIE(aTHX_ PL_no_func, "getppid");
4284 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4287 pgrp = (I32)BSD_GETPGRP(pid);
4289 if (pid != 0 && pid != PerlProc_getpid())
4290 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4296 DIE(aTHX_ PL_no_func, "getpgrp()");
4306 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4307 if (MAXARG > 0) pid = TOPs && TOPi;
4313 TAINT_PROPER("setpgrp");
4315 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4317 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4318 || (pid != 0 && pid != PerlProc_getpid()))
4320 DIE(aTHX_ "setpgrp can't take arguments");
4322 SETi( setpgrp() >= 0 );
4323 #endif /* USE_BSDPGRP */
4326 DIE(aTHX_ PL_no_func, "setpgrp()");
4330 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4331 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4333 # define PRIORITY_WHICH_T(which) which
4338 #ifdef HAS_GETPRIORITY
4340 const int who = POPi;
4341 const int which = TOPi;
4342 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4345 DIE(aTHX_ PL_no_func, "getpriority()");
4351 #ifdef HAS_SETPRIORITY
4353 const int niceval = POPi;
4354 const int who = POPi;
4355 const int which = TOPi;
4356 TAINT_PROPER("setpriority");
4357 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4360 DIE(aTHX_ PL_no_func, "setpriority()");
4364 #undef PRIORITY_WHICH_T
4372 XPUSHn( time(NULL) );
4374 XPUSHi( time(NULL) );
4386 (void)PerlProc_times(&PL_timesbuf);
4388 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4389 /* struct tms, though same data */
4393 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4394 if (GIMME == G_ARRAY) {
4395 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4396 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4397 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4405 if (GIMME == G_ARRAY) {
4412 DIE(aTHX_ "times not implemented");
4414 #endif /* HAS_TIMES */
4417 /* The 32 bit int year limits the times we can represent to these
4418 boundaries with a few days wiggle room to account for time zone
4421 /* Sat Jan 3 00:00:00 -2147481748 */
4422 #define TIME_LOWER_BOUND -67768100567755200.0
4423 /* Sun Dec 29 12:00:00 2147483647 */
4424 #define TIME_UPPER_BOUND 67767976233316800.0
4433 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4434 static const char * const dayname[] =
4435 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4436 static const char * const monname[] =
4437 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4438 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4440 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4443 when = (Time64_T)now;
4446 NV input = Perl_floor(POPn);
4447 when = (Time64_T)input;
4448 if (when != input) {
4449 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4450 "%s(%.0" NVff ") too large", opname, input);
4454 if ( TIME_LOWER_BOUND > when ) {
4455 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4456 "%s(%.0" NVff ") too small", opname, when);
4459 else if( when > TIME_UPPER_BOUND ) {
4460 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4461 "%s(%.0" NVff ") too large", opname, when);
4465 if (PL_op->op_type == OP_LOCALTIME)
4466 err = S_localtime64_r(&when, &tmbuf);
4468 err = S_gmtime64_r(&when, &tmbuf);
4472 /* XXX %lld broken for quads */
4473 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4474 "%s(%.0" NVff ") failed", opname, when);
4477 if (GIMME != G_ARRAY) { /* scalar context */
4479 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4480 double year = (double)tmbuf.tm_year + 1900;
4487 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4488 dayname[tmbuf.tm_wday],
4489 monname[tmbuf.tm_mon],
4497 else { /* list context */
4503 mPUSHi(tmbuf.tm_sec);
4504 mPUSHi(tmbuf.tm_min);
4505 mPUSHi(tmbuf.tm_hour);
4506 mPUSHi(tmbuf.tm_mday);
4507 mPUSHi(tmbuf.tm_mon);
4508 mPUSHn(tmbuf.tm_year);
4509 mPUSHi(tmbuf.tm_wday);
4510 mPUSHi(tmbuf.tm_yday);
4511 mPUSHi(tmbuf.tm_isdst);
4522 anum = alarm((unsigned int)anum);
4528 DIE(aTHX_ PL_no_func, "alarm");
4539 (void)time(&lasttime);
4540 if (MAXARG < 1 || (!TOPs && !POPs))
4544 PerlProc_sleep((unsigned int)duration);
4547 XPUSHi(when - lasttime);
4551 /* Shared memory. */
4552 /* Merged with some message passing. */
4556 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4557 dVAR; dSP; dMARK; dTARGET;
4558 const int op_type = PL_op->op_type;
4563 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4566 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4569 value = (I32)(do_semop(MARK, SP) >= 0);
4572 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4580 return Perl_pp_semget(aTHX);
4588 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4589 dVAR; dSP; dMARK; dTARGET;
4590 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4597 DIE(aTHX_ "System V IPC is not implemented on this machine");
4603 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4604 dVAR; dSP; dMARK; dTARGET;
4605 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4613 PUSHp(zero_but_true, ZBTLEN);
4617 return Perl_pp_semget(aTHX);
4621 /* I can't const this further without getting warnings about the types of
4622 various arrays passed in from structures. */
4624 S_space_join_names_mortal(pTHX_ char *const *array)
4628 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4630 if (array && *array) {
4631 target = newSVpvs_flags("", SVs_TEMP);
4633 sv_catpv(target, *array);
4636 sv_catpvs(target, " ");
4639 target = sv_mortalcopy(&PL_sv_no);
4644 /* Get system info. */
4648 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4650 I32 which = PL_op->op_type;
4651 register char **elem;
4653 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4654 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4655 struct hostent *gethostbyname(Netdb_name_t);
4656 struct hostent *gethostent(void);
4658 struct hostent *hent = NULL;
4662 if (which == OP_GHBYNAME) {
4663 #ifdef HAS_GETHOSTBYNAME
4664 const char* const name = POPpbytex;
4665 hent = PerlSock_gethostbyname(name);
4667 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4670 else if (which == OP_GHBYADDR) {
4671 #ifdef HAS_GETHOSTBYADDR
4672 const int addrtype = POPi;
4673 SV * const addrsv = POPs;
4675 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4677 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4679 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4683 #ifdef HAS_GETHOSTENT
4684 hent = PerlSock_gethostent();
4686 DIE(aTHX_ PL_no_sock_func, "gethostent");
4689 #ifdef HOST_NOT_FOUND
4691 #ifdef USE_REENTRANT_API
4692 # ifdef USE_GETHOSTENT_ERRNO
4693 h_errno = PL_reentrant_buffer->_gethostent_errno;
4696 STATUS_UNIX_SET(h_errno);
4700 if (GIMME != G_ARRAY) {
4701 PUSHs(sv = sv_newmortal());
4703 if (which == OP_GHBYNAME) {
4705 sv_setpvn(sv, hent->h_addr, hent->h_length);
4708 sv_setpv(sv, (char*)hent->h_name);
4714 mPUSHs(newSVpv((char*)hent->h_name, 0));
4715 PUSHs(space_join_names_mortal(hent->h_aliases));
4716 mPUSHi(hent->h_addrtype);
4717 len = hent->h_length;
4720 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4721 mXPUSHp(*elem, len);
4725 mPUSHp(hent->h_addr, len);
4727 PUSHs(sv_mortalcopy(&PL_sv_no));
4732 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4738 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4740 I32 which = PL_op->op_type;
4742 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4743 struct netent *getnetbyaddr(Netdb_net_t, int);
4744 struct netent *getnetbyname(Netdb_name_t);
4745 struct netent *getnetent(void);
4747 struct netent *nent;
4749 if (which == OP_GNBYNAME){
4750 #ifdef HAS_GETNETBYNAME
4751 const char * const name = POPpbytex;
4752 nent = PerlSock_getnetbyname(name);
4754 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4757 else if (which == OP_GNBYADDR) {
4758 #ifdef HAS_GETNETBYADDR
4759 const int addrtype = POPi;
4760 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4761 nent = PerlSock_getnetbyaddr(addr, addrtype);
4763 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4767 #ifdef HAS_GETNETENT
4768 nent = PerlSock_getnetent();
4770 DIE(aTHX_ PL_no_sock_func, "getnetent");
4773 #ifdef HOST_NOT_FOUND
4775 #ifdef USE_REENTRANT_API
4776 # ifdef USE_GETNETENT_ERRNO
4777 h_errno = PL_reentrant_buffer->_getnetent_errno;
4780 STATUS_UNIX_SET(h_errno);
4785 if (GIMME != G_ARRAY) {
4786 PUSHs(sv = sv_newmortal());
4788 if (which == OP_GNBYNAME)
4789 sv_setiv(sv, (IV)nent->n_net);
4791 sv_setpv(sv, nent->n_name);
4797 mPUSHs(newSVpv(nent->n_name, 0));
4798 PUSHs(space_join_names_mortal(nent->n_aliases));
4799 mPUSHi(nent->n_addrtype);
4800 mPUSHi(nent->n_net);
4805 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4811 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4813 I32 which = PL_op->op_type;
4815 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4816 struct protoent *getprotobyname(Netdb_name_t);
4817 struct protoent *getprotobynumber(int);
4818 struct protoent *getprotoent(void);
4820 struct protoent *pent;
4822 if (which == OP_GPBYNAME) {
4823 #ifdef HAS_GETPROTOBYNAME
4824 const char* const name = POPpbytex;
4825 pent = PerlSock_getprotobyname(name);
4827 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4830 else if (which == OP_GPBYNUMBER) {
4831 #ifdef HAS_GETPROTOBYNUMBER
4832 const int number = POPi;
4833 pent = PerlSock_getprotobynumber(number);
4835 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4839 #ifdef HAS_GETPROTOENT
4840 pent = PerlSock_getprotoent();
4842 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4846 if (GIMME != G_ARRAY) {
4847 PUSHs(sv = sv_newmortal());
4849 if (which == OP_GPBYNAME)
4850 sv_setiv(sv, (IV)pent->p_proto);
4852 sv_setpv(sv, pent->p_name);
4858 mPUSHs(newSVpv(pent->p_name, 0));
4859 PUSHs(space_join_names_mortal(pent->p_aliases));
4860 mPUSHi(pent->p_proto);
4865 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4871 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4873 I32 which = PL_op->op_type;
4875 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4876 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4877 struct servent *getservbyport(int, Netdb_name_t);
4878 struct servent *getservent(void);
4880 struct servent *sent;
4882 if (which == OP_GSBYNAME) {
4883 #ifdef HAS_GETSERVBYNAME
4884 const char * const proto = POPpbytex;
4885 const char * const name = POPpbytex;
4886 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4888 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4891 else if (which == OP_GSBYPORT) {
4892 #ifdef HAS_GETSERVBYPORT
4893 const char * const proto = POPpbytex;
4894 unsigned short port = (unsigned short)POPu;
4896 port = PerlSock_htons(port);
4898 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4900 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4904 #ifdef HAS_GETSERVENT
4905 sent = PerlSock_getservent();
4907 DIE(aTHX_ PL_no_sock_func, "getservent");
4911 if (GIMME != G_ARRAY) {
4912 PUSHs(sv = sv_newmortal());
4914 if (which == OP_GSBYNAME) {
4916 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4918 sv_setiv(sv, (IV)(sent->s_port));
4922 sv_setpv(sv, sent->s_name);
4928 mPUSHs(newSVpv(sent->s_name, 0));
4929 PUSHs(space_join_names_mortal(sent->s_aliases));
4931 mPUSHi(PerlSock_ntohs(sent->s_port));
4933 mPUSHi(sent->s_port);
4935 mPUSHs(newSVpv(sent->s_proto, 0));
4940 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4947 const int stayopen = TOPi;
4948 switch(PL_op->op_type) {
4950 #ifdef HAS_SETHOSTENT
4951 PerlSock_sethostent(stayopen);
4953 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4956 #ifdef HAS_SETNETENT
4958 PerlSock_setnetent(stayopen);
4960 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4964 #ifdef HAS_SETPROTOENT
4965 PerlSock_setprotoent(stayopen);
4967 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4971 #ifdef HAS_SETSERVENT
4972 PerlSock_setservent(stayopen);
4974 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4984 switch(PL_op->op_type) {
4986 #ifdef HAS_ENDHOSTENT
4987 PerlSock_endhostent();
4989 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4993 #ifdef HAS_ENDNETENT
4994 PerlSock_endnetent();
4996 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5000 #ifdef HAS_ENDPROTOENT
5001 PerlSock_endprotoent();
5003 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5007 #ifdef HAS_ENDSERVENT
5008 PerlSock_endservent();
5010 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5014 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5017 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5021 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5024 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5028 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5031 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5035 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5038 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5050 I32 which = PL_op->op_type;
5052 struct passwd *pwent = NULL;
5054 * We currently support only the SysV getsp* shadow password interface.
5055 * The interface is declared in <shadow.h> and often one needs to link
5056 * with -lsecurity or some such.
5057 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5060 * AIX getpwnam() is clever enough to return the encrypted password
5061 * only if the caller (euid?) is root.
5063 * There are at least three other shadow password APIs. Many platforms
5064 * seem to contain more than one interface for accessing the shadow
5065 * password databases, possibly for compatibility reasons.
5066 * The getsp*() is by far he simplest one, the other two interfaces
5067 * are much more complicated, but also very similar to each other.
5072 * struct pr_passwd *getprpw*();
5073 * The password is in
5074 * char getprpw*(...).ufld.fd_encrypt[]
5075 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5080 * struct es_passwd *getespw*();
5081 * The password is in
5082 * char *(getespw*(...).ufld.fd_encrypt)
5083 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5086 * struct userpw *getuserpw();
5087 * The password is in
5088 * char *(getuserpw(...)).spw_upw_passwd
5089 * (but the de facto standard getpwnam() should work okay)
5091 * Mention I_PROT here so that Configure probes for it.
5093 * In HP-UX for getprpw*() the manual page claims that one should include
5094 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5095 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5096 * and pp_sys.c already includes <shadow.h> if there is such.
5098 * Note that <sys/security.h> is already probed for, but currently
5099 * it is only included in special cases.
5101 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5102 * be preferred interface, even though also the getprpw*() interface
5103 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5104 * One also needs to call set_auth_parameters() in main() before
5105 * doing anything else, whether one is using getespw*() or getprpw*().
5107 * Note that accessing the shadow databases can be magnitudes
5108 * slower than accessing the standard databases.
5113 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5114 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5115 * the pw_comment is left uninitialized. */
5116 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5122 const char* const name = POPpbytex;
5123 pwent = getpwnam(name);
5129 pwent = getpwuid(uid);
5133 # ifdef HAS_GETPWENT
5135 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5136 if (pwent) pwent = getpwnam(pwent->pw_name);
5139 DIE(aTHX_ PL_no_func, "getpwent");
5145 if (GIMME != G_ARRAY) {
5146 PUSHs(sv = sv_newmortal());
5148 if (which == OP_GPWNAM)
5149 # if Uid_t_sign <= 0
5150 sv_setiv(sv, (IV)pwent->pw_uid);
5152 sv_setuv(sv, (UV)pwent->pw_uid);
5155 sv_setpv(sv, pwent->pw_name);
5161 mPUSHs(newSVpv(pwent->pw_name, 0));
5165 /* If we have getspnam(), we try to dig up the shadow
5166 * password. If we are underprivileged, the shadow
5167 * interface will set the errno to EACCES or similar,
5168 * and return a null pointer. If this happens, we will
5169 * use the dummy password (usually "*" or "x") from the
5170 * standard password database.
5172 * In theory we could skip the shadow call completely
5173 * if euid != 0 but in practice we cannot know which
5174 * security measures are guarding the shadow databases
5175 * on a random platform.
5177 * Resist the urge to use additional shadow interfaces.
5178 * Divert the urge to writing an extension instead.
5181 /* Some AIX setups falsely(?) detect some getspnam(), which
5182 * has a different API than the Solaris/IRIX one. */
5183 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5186 const struct spwd * const spwent = getspnam(pwent->pw_name);
5187 /* Save and restore errno so that
5188 * underprivileged attempts seem
5189 * to have never made the unsuccessful
5190 * attempt to retrieve the shadow password. */
5192 if (spwent && spwent->sp_pwdp)
5193 sv_setpv(sv, spwent->sp_pwdp);
5197 if (!SvPOK(sv)) /* Use the standard password, then. */
5198 sv_setpv(sv, pwent->pw_passwd);
5201 # ifndef INCOMPLETE_TAINTS
5202 /* passwd is tainted because user himself can diddle with it.
5203 * admittedly not much and in a very limited way, but nevertheless. */
5207 # if Uid_t_sign <= 0
5208 mPUSHi(pwent->pw_uid);
5210 mPUSHu(pwent->pw_uid);
5213 # if Uid_t_sign <= 0
5214 mPUSHi(pwent->pw_gid);
5216 mPUSHu(pwent->pw_gid);
5218 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5219 * because of the poor interface of the Perl getpw*(),
5220 * not because there's some standard/convention saying so.
5221 * A better interface would have been to return a hash,
5222 * but we are accursed by our history, alas. --jhi. */
5224 mPUSHi(pwent->pw_change);
5227 mPUSHi(pwent->pw_quota);
5230 mPUSHs(newSVpv(pwent->pw_age, 0));
5232 /* I think that you can never get this compiled, but just in case. */
5233 PUSHs(sv_mortalcopy(&PL_sv_no));
5238 /* pw_class and pw_comment are mutually exclusive--.
5239 * see the above note for pw_change, pw_quota, and pw_age. */
5241 mPUSHs(newSVpv(pwent->pw_class, 0));
5244 mPUSHs(newSVpv(pwent->pw_comment, 0));
5246 /* I think that you can never get this compiled, but just in case. */
5247 PUSHs(sv_mortalcopy(&PL_sv_no));
5252 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5254 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5256 # ifndef INCOMPLETE_TAINTS
5257 /* pw_gecos is tainted because user himself can diddle with it. */
5261 mPUSHs(newSVpv(pwent->pw_dir, 0));
5263 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5264 # ifndef INCOMPLETE_TAINTS
5265 /* pw_shell is tainted because user himself can diddle with it. */
5270 mPUSHi(pwent->pw_expire);
5275 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5283 const I32 which = PL_op->op_type;
5284 const struct group *grent;
5286 if (which == OP_GGRNAM) {
5287 const char* const name = POPpbytex;
5288 grent = (const struct group *)getgrnam(name);
5290 else if (which == OP_GGRGID) {
5291 const Gid_t gid = POPi;
5292 grent = (const struct group *)getgrgid(gid);
5296 grent = (struct group *)getgrent();
5298 DIE(aTHX_ PL_no_func, "getgrent");
5302 if (GIMME != G_ARRAY) {
5303 SV * const sv = sv_newmortal();
5307 if (which == OP_GGRNAM)
5309 sv_setiv(sv, (IV)grent->gr_gid);
5311 sv_setuv(sv, (UV)grent->gr_gid);
5314 sv_setpv(sv, grent->gr_name);
5320 mPUSHs(newSVpv(grent->gr_name, 0));
5323 mPUSHs(newSVpv(grent->gr_passwd, 0));
5325 PUSHs(sv_mortalcopy(&PL_sv_no));
5329 mPUSHi(grent->gr_gid);
5331 mPUSHu(grent->gr_gid);
5334 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5335 /* In UNICOS/mk (_CRAYMPP) the multithreading
5336 * versions (getgrnam_r, getgrgid_r)
5337 * seem to return an illegal pointer
5338 * as the group members list, gr_mem.
5339 * getgrent() doesn't even have a _r version
5340 * but the gr_mem is poisonous anyway.
5341 * So yes, you cannot get the list of group
5342 * members if building multithreaded in UNICOS/mk. */
5343 PUSHs(space_join_names_mortal(grent->gr_mem));
5349 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5359 if (!(tmps = PerlProc_getlogin()))
5361 sv_setpv_mg(TARG, tmps);
5365 DIE(aTHX_ PL_no_func, "getlogin");
5369 /* Miscellaneous. */
5374 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5375 register I32 items = SP - MARK;
5376 unsigned long a[20];
5381 while (++MARK <= SP) {
5382 if (SvTAINTED(*MARK)) {
5388 TAINT_PROPER("syscall");
5391 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5392 * or where sizeof(long) != sizeof(char*). But such machines will
5393 * not likely have syscall implemented either, so who cares?
5395 while (++MARK <= SP) {
5396 if (SvNIOK(*MARK) || !i)
5397 a[i++] = SvIV(*MARK);
5398 else if (*MARK == &PL_sv_undef)
5401 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5407 DIE(aTHX_ "Too many args to syscall");
5409 DIE(aTHX_ "Too few args to syscall");
5411 retval = syscall(a[0]);
5414 retval = syscall(a[0],a[1]);
5417 retval = syscall(a[0],a[1],a[2]);
5420 retval = syscall(a[0],a[1],a[2],a[3]);
5423 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5426 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5429 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5432 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5436 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5439 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5442 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5446 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5450 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5454 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5455 a[10],a[11],a[12],a[13]);
5457 #endif /* atarist */
5463 DIE(aTHX_ PL_no_func, "syscall");
5467 #ifdef FCNTL_EMULATE_FLOCK
5469 /* XXX Emulate flock() with fcntl().
5470 What's really needed is a good file locking module.
5474 fcntl_emulate_flock(int fd, int operation)
5479 switch (operation & ~LOCK_NB) {
5481 flock.l_type = F_RDLCK;
5484 flock.l_type = F_WRLCK;
5487 flock.l_type = F_UNLCK;
5493 flock.l_whence = SEEK_SET;
5494 flock.l_start = flock.l_len = (Off_t)0;
5496 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5497 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5498 errno = EWOULDBLOCK;
5502 #endif /* FCNTL_EMULATE_FLOCK */
5504 #ifdef LOCKF_EMULATE_FLOCK
5506 /* XXX Emulate flock() with lockf(). This is just to increase
5507 portability of scripts. The calls are not completely
5508 interchangeable. What's really needed is a good file
5512 /* The lockf() constants might have been defined in <unistd.h>.
5513 Unfortunately, <unistd.h> causes troubles on some mixed
5514 (BSD/POSIX) systems, such as SunOS 4.1.3.
5516 Further, the lockf() constants aren't POSIX, so they might not be
5517 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5518 just stick in the SVID values and be done with it. Sigh.
5522 # define F_ULOCK 0 /* Unlock a previously locked region */
5525 # define F_LOCK 1 /* Lock a region for exclusive use */
5528 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5531 # define F_TEST 3 /* Test a region for other processes locks */
5535 lockf_emulate_flock(int fd, int operation)
5541 /* flock locks entire file so for lockf we need to do the same */
5542 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5543 if (pos > 0) /* is seekable and needs to be repositioned */
5544 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5545 pos = -1; /* seek failed, so don't seek back afterwards */
5548 switch (operation) {
5550 /* LOCK_SH - get a shared lock */
5552 /* LOCK_EX - get an exclusive lock */
5554 i = lockf (fd, F_LOCK, 0);
5557 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5558 case LOCK_SH|LOCK_NB:
5559 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5560 case LOCK_EX|LOCK_NB:
5561 i = lockf (fd, F_TLOCK, 0);
5563 if ((errno == EAGAIN) || (errno == EACCES))
5564 errno = EWOULDBLOCK;
5567 /* LOCK_UN - unlock (non-blocking is a no-op) */
5569 case LOCK_UN|LOCK_NB:
5570 i = lockf (fd, F_ULOCK, 0);
5573 /* Default - can't decipher operation */
5580 if (pos > 0) /* need to restore position of the handle */
5581 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5586 #endif /* LOCKF_EMULATE_FLOCK */
5590 * c-indentation-style: bsd
5592 * indent-tabs-mode: t
5595 * ex: set ts=8 sts=4 sw=4 noet: