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 /* diag_listed_as: entering effective %s failed */
252 Perl_croak(aTHX_ "entering effective uid failed");
255 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
256 Perl_croak(aTHX_ "switching effective gid is not implemented");
259 if (setregid(egid, rgid))
262 if (setresgid(egid, rgid, (Gid_t)-1))
265 /* diag_listed_as: entering effective %s failed */
266 Perl_croak(aTHX_ "entering effective gid failed");
269 res = access(path, mode);
272 if (setreuid(ruid, euid))
275 if (setresuid(ruid, euid, (Uid_t)-1))
278 /* diag_listed_as: leaving effective %s failed */
279 Perl_croak(aTHX_ "leaving effective uid failed");
282 if (setregid(rgid, egid))
285 if (setresgid(rgid, egid, (Gid_t)-1))
288 /* diag_listed_as: leaving effective %s failed */
289 Perl_croak(aTHX_ "leaving effective gid failed");
293 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
300 const char * const tmps = POPpconstx;
301 const I32 gimme = GIMME_V;
302 const char *mode = "r";
305 if (PL_op->op_private & OPpOPEN_IN_RAW)
307 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
309 fp = PerlProc_popen(tmps, mode);
311 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
313 PerlIO_apply_layers(aTHX_ fp,mode,type);
315 if (gimme == G_VOID) {
317 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
320 else if (gimme == G_SCALAR) {
321 ENTER_with_name("backtick");
323 PL_rs = &PL_sv_undef;
324 sv_setpvs(TARG, ""); /* note that this preserves previous buffer */
325 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
327 LEAVE_with_name("backtick");
333 SV * const sv = newSV(79);
334 if (sv_gets(sv, fp, 0) == NULL) {
339 if (SvLEN(sv) - SvCUR(sv) > 20) {
340 SvPV_shrink_to_cur(sv);
345 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
346 TAINT; /* "I believe that this is not gratuitous!" */
349 STATUS_NATIVE_CHILD_SET(-1);
350 if (gimme == G_SCALAR)
362 GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs;
366 /* make a copy of the pattern if it is gmagical, to ensure that magic
367 * is called once and only once */
368 if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs));
370 tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL));
372 if (PL_op->op_flags & OPf_SPECIAL) {
373 /* call Perl-level glob function instead. Stack args are:
375 * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
384 /* Note that we only ever get here if File::Glob fails to load
385 * without at the same time croaking, for some reason, or if
386 * perl was built with PERL_EXTERNAL_GLOB */
388 ENTER_with_name("glob");
393 * The external globbing program may use things we can't control,
394 * so for security reasons we must assume the worst.
397 taint_proper(PL_no_security, "glob");
401 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
404 SAVESPTR(PL_rs); /* This is not permanent, either. */
405 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
408 *SvPVX(PL_rs) = '\n';
412 result = do_readline();
413 LEAVE_with_name("glob");
420 PL_last_in_gv = cGVOP_gv;
421 return do_readline();
431 do_join(TARG, &PL_sv_no, MARK, SP);
435 else if (SP == MARK) {
442 if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
445 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
446 /* well-formed exception supplied */
449 SV * const errsv = ERRSV;
452 if (SvGMAGICAL(errsv)) {
453 exsv = sv_newmortal();
454 sv_setsv_nomg(exsv, errsv);
458 else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) {
459 exsv = sv_newmortal();
460 sv_setsv_nomg(exsv, errsv);
461 sv_catpvs(exsv, "\t...caught");
464 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
467 if (SvROK(exsv) && !PL_warnhook)
468 Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
479 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
481 if (SP - MARK != 1) {
483 do_join(TARG, &PL_sv_no, MARK, SP);
491 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
492 /* well-formed exception supplied */
495 SV * const errsv = ERRSV;
498 if (sv_isobject(exsv)) {
499 HV * const stash = SvSTASH(SvRV(exsv));
500 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
502 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
503 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
510 call_sv(MUTABLE_SV(GvCV(gv)),
511 G_SCALAR|G_EVAL|G_KEEPERR);
512 exsv = sv_mortalcopy(*PL_stack_sp--);
516 else if (SvPV_const(errsv, len), len) {
517 exsv = sv_mortalcopy(errsv);
518 sv_catpvs(exsv, "\t...propagated");
521 exsv = newSVpvs_flags("Died", SVs_TEMP);
530 Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv,
531 const MAGIC *const mg, const U32 flags, U32 argc, ...)
536 PERL_ARGS_ASSERT_TIED_METHOD;
538 /* Ensure that our flag bits do not overlap. */
539 assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
540 assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
541 assert((TIED_METHOD_SAY & G_WANT) == 0);
543 PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
544 PUSHSTACKi(PERLSI_MAGIC);
545 EXTEND(SP, argc+1); /* object + args */
547 PUSHs(SvTIED_obj(sv, mg));
548 if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
549 Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
553 const U32 mortalize_not_needed
554 = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
556 va_start(args, argc);
558 SV *const arg = va_arg(args, SV *);
559 if(mortalize_not_needed)
568 ENTER_with_name("call_tied_method");
569 if (flags & TIED_METHOD_SAY) {
570 /* local $\ = "\n" */
571 SAVEGENERICSV(PL_ors_sv);
572 PL_ors_sv = newSVpvs("\n");
574 ret_args = call_method(methname, flags & G_WANT);
579 if (ret_args) { /* copy results back to original stack */
580 EXTEND(sp, ret_args);
581 Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
585 LEAVE_with_name("call_tied_method");
589 #define tied_method0(a,b,c,d) \
590 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
591 #define tied_method1(a,b,c,d,e) \
592 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
593 #define tied_method2(a,b,c,d,e,f) \
594 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
607 GV * const gv = MUTABLE_GV(*++MARK);
609 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
610 DIE(aTHX_ PL_no_usym, "filehandle");
612 if ((io = GvIOp(gv))) {
614 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
617 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
618 "Opening dirhandle %"HEKf" also as a file",
619 HEKfARG(GvENAME_HEK(gv)));
621 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
623 /* Method's args are same as ours ... */
624 /* ... except handle is replaced by the object */
625 return Perl_tied_method(aTHX_ "OPEN", mark - 1, MUTABLE_SV(io), mg,
626 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
638 tmps = SvPV_const(sv, len);
639 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
642 PUSHi( (I32)PL_forkprocess );
643 else if (PL_forkprocess == 0) /* we are a new child */
654 MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
660 IO * const io = GvIO(gv);
662 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
664 return tied_method0("CLOSE", SP, MUTABLE_SV(io), mg);
668 PUSHs(boolSV(do_close(gv, TRUE)));
681 GV * const wgv = MUTABLE_GV(POPs);
682 GV * const rgv = MUTABLE_GV(POPs);
687 if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
688 DIE(aTHX_ PL_no_usym, "filehandle");
693 do_close(rgv, FALSE);
695 do_close(wgv, FALSE);
697 if (PerlProc_pipe(fd) < 0)
700 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
701 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
702 IoOFP(rstio) = IoIFP(rstio);
703 IoIFP(wstio) = IoOFP(wstio);
704 IoTYPE(rstio) = IoTYPE_RDONLY;
705 IoTYPE(wstio) = IoTYPE_WRONLY;
707 if (!IoIFP(rstio) || !IoOFP(wstio)) {
709 PerlIO_close(IoIFP(rstio));
711 PerlLIO_close(fd[0]);
713 PerlIO_close(IoOFP(wstio));
715 PerlLIO_close(fd[1]);
718 #if defined(HAS_FCNTL) && defined(F_SETFD)
719 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
720 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
727 DIE(aTHX_ PL_no_func, "pipe");
741 gv = MUTABLE_GV(POPs);
745 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
747 return tied_method0("FILENO", SP, MUTABLE_SV(io), mg);
750 if (!io || !(fp = IoIFP(io))) {
751 /* Can't do this because people seem to do things like
752 defined(fileno($foo)) to check whether $foo is a valid fh.
759 PUSHi(PerlIO_fileno(fp));
771 if (MAXARG < 1 || (!TOPs && !POPs)) {
772 anum = PerlLIO_umask(022);
773 /* setting it to 022 between the two calls to umask avoids
774 * to have a window where the umask is set to 0 -- meaning
775 * that another thread could create world-writeable files. */
777 (void)PerlLIO_umask(anum);
780 anum = PerlLIO_umask(POPi);
781 TAINT_PROPER("umask");
784 /* Only DIE if trying to restrict permissions on "user" (self).
785 * Otherwise it's harmless and more useful to just return undef
786 * since 'group' and 'other' concepts probably don't exist here. */
787 if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
788 DIE(aTHX_ "umask not implemented");
789 XPUSHs(&PL_sv_undef);
808 gv = MUTABLE_GV(POPs);
812 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
814 /* This takes advantage of the implementation of the varargs
815 function, which I don't think that the optimiser will be able to
816 figure out. Although, as it's a static function, in theory it
818 return Perl_tied_method(aTHX_ "BINMODE", SP, MUTABLE_SV(io), mg,
819 G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
820 discp ? 1 : 0, discp);
824 if (!io || !(fp = IoIFP(io))) {
826 SETERRNO(EBADF,RMS_IFI);
833 const char *d = NULL;
836 d = SvPV_const(discp, len);
837 mode = mode_from_discipline(d, len);
838 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
839 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
840 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
861 const I32 markoff = MARK - PL_stack_base;
862 const char *methname;
863 int how = PERL_MAGIC_tied;
867 switch(SvTYPE(varsv)) {
871 methname = "TIEHASH";
872 if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
873 HvLAZYDEL_off(varsv);
874 hv_free_ent((HV *)varsv, entry);
876 HvEITER_set(MUTABLE_HV(varsv), 0);
880 methname = "TIEARRAY";
881 if (!AvREAL(varsv)) {
883 Perl_croak(aTHX_ "Cannot tie unreifiable array");
884 av_clear((AV *)varsv);
891 if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
892 methname = "TIEHANDLE";
893 how = PERL_MAGIC_tiedscalar;
894 /* For tied filehandles, we apply tiedscalar magic to the IO
895 slot of the GP rather than the GV itself. AMS 20010812 */
897 GvIOp(varsv) = newIO();
898 varsv = MUTABLE_SV(GvIOp(varsv));
903 methname = "TIESCALAR";
904 how = PERL_MAGIC_tiedscalar;
908 if (sv_isobject(*MARK)) { /* Calls GET magic. */
909 ENTER_with_name("call_TIE");
910 PUSHSTACKi(PERLSI_MAGIC);
912 EXTEND(SP,(I32)items);
916 call_method(methname, G_SCALAR);
919 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
920 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
921 * wrong error message, and worse case, supreme action at a distance.
922 * (Sorry obfuscation writers. You're not going to be given this one.)
924 stash = gv_stashsv(*MARK, 0);
925 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
926 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
927 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
929 ENTER_with_name("call_TIE");
930 PUSHSTACKi(PERLSI_MAGIC);
932 EXTEND(SP,(I32)items);
936 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
942 if (sv_isobject(sv)) {
943 sv_unmagic(varsv, how);
944 /* Croak if a self-tie on an aggregate is attempted. */
945 if (varsv == SvRV(sv) &&
946 (SvTYPE(varsv) == SVt_PVAV ||
947 SvTYPE(varsv) == SVt_PVHV))
949 "Self-ties of arrays and hashes are not supported");
950 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
952 LEAVE_with_name("call_TIE");
953 SP = PL_stack_base + markoff;
963 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
964 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
966 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
969 if ((mg = SvTIED_mg(sv, how))) {
970 SV * const obj = SvRV(SvTIED_obj(sv, mg));
972 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
974 if (gv && isGV(gv) && (cv = GvCV(gv))) {
976 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
977 mXPUSHi(SvREFCNT(obj) - 1);
979 ENTER_with_name("call_UNTIE");
980 call_sv(MUTABLE_SV(cv), G_VOID);
981 LEAVE_with_name("call_UNTIE");
984 else if (mg && SvREFCNT(obj) > 1) {
985 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
986 "untie attempted while %"UVuf" inner references still exist",
987 (UV)SvREFCNT(obj) - 1 ) ;
991 sv_unmagic(sv, how) ;
1001 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1002 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1004 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1007 if ((mg = SvTIED_mg(sv, how))) {
1008 PUSHs(SvTIED_obj(sv, mg));
1021 HV * const hv = MUTABLE_HV(POPs);
1022 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1023 stash = gv_stashsv(sv, 0);
1024 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1026 require_pv("AnyDBM_File.pm");
1028 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1029 DIE(aTHX_ "No dbm on this machine");
1039 mPUSHu(O_RDWR|O_CREAT);
1043 if (!SvOK(right)) right = &PL_sv_no;
1047 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1050 if (!sv_isobject(TOPs)) {
1058 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1062 if (sv_isobject(TOPs)) {
1063 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1064 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1081 struct timeval timebuf;
1082 struct timeval *tbuf = &timebuf;
1085 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1090 # if BYTEORDER & 0xf0000
1091 # define ORDERBYTE (0x88888888 - BYTEORDER)
1093 # define ORDERBYTE (0x4444 - BYTEORDER)
1099 for (i = 1; i <= 3; i++) {
1100 SV * const sv = SP[i];
1105 sv_force_normal_flags(sv, 0);
1106 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1107 Perl_croak_no_modify();
1110 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1111 "Non-string passed as bitmask");
1112 SvPV_force_nomg_nolen(sv); /* force string conversion */
1119 /* little endians can use vecs directly */
1120 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1127 masksize = NFDBITS / NBBY;
1129 masksize = sizeof(long); /* documented int, everyone seems to use long */
1131 Zero(&fd_sets[0], 4, char*);
1134 # if SELECT_MIN_BITS == 1
1135 growsize = sizeof(fd_set);
1137 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1138 # undef SELECT_MIN_BITS
1139 # define SELECT_MIN_BITS __FD_SETSIZE
1141 /* If SELECT_MIN_BITS is greater than one we most probably will want
1142 * to align the sizes with SELECT_MIN_BITS/8 because for example
1143 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1144 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1145 * on (sets/tests/clears bits) is 32 bits. */
1146 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1154 timebuf.tv_sec = (long)value;
1155 value -= (NV)timebuf.tv_sec;
1156 timebuf.tv_usec = (long)(value * 1000000.0);
1161 for (i = 1; i <= 3; i++) {
1163 if (!SvOK(sv) || SvCUR(sv) == 0) {
1170 Sv_Grow(sv, growsize);
1174 while (++j <= growsize) {
1178 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1180 Newx(fd_sets[i], growsize, char);
1181 for (offset = 0; offset < growsize; offset += masksize) {
1182 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1183 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1186 fd_sets[i] = SvPVX(sv);
1190 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1191 /* Can't make just the (void*) conditional because that would be
1192 * cpp #if within cpp macro, and not all compilers like that. */
1193 nfound = PerlSock_select(
1195 (Select_fd_set_t) fd_sets[1],
1196 (Select_fd_set_t) fd_sets[2],
1197 (Select_fd_set_t) fd_sets[3],
1198 (void*) tbuf); /* Workaround for compiler bug. */
1200 nfound = PerlSock_select(
1202 (Select_fd_set_t) fd_sets[1],
1203 (Select_fd_set_t) fd_sets[2],
1204 (Select_fd_set_t) fd_sets[3],
1207 for (i = 1; i <= 3; i++) {
1210 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1212 for (offset = 0; offset < growsize; offset += masksize) {
1213 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1214 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1216 Safefree(fd_sets[i]);
1223 if (GIMME == G_ARRAY && tbuf) {
1224 value = (NV)(timebuf.tv_sec) +
1225 (NV)(timebuf.tv_usec) / 1000000.0;
1230 DIE(aTHX_ "select not implemented");
1235 =for apidoc setdefout
1237 Sets PL_defoutgv, the default file handle for output, to the passed in
1238 typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1239 count of the passed in typeglob is increased by one, and the reference count
1240 of the typeglob that PL_defoutgv points to is decreased by one.
1246 Perl_setdefout(pTHX_ GV *gv)
1249 PERL_ARGS_ASSERT_SETDEFOUT;
1250 SvREFCNT_inc_simple_void_NN(gv);
1251 SvREFCNT_dec(PL_defoutgv);
1259 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1260 GV * egv = GvEGVx(PL_defoutgv);
1265 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1266 gvp = hv && HvENAME(hv)
1267 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1269 if (gvp && *gvp == egv) {
1270 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1274 mXPUSHs(newRV(MUTABLE_SV(egv)));
1278 if (!GvIO(newdefout))
1279 gv_IOadd(newdefout);
1280 setdefout(newdefout);
1290 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1291 IO *const io = GvIO(gv);
1297 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1299 const U32 gimme = GIMME_V;
1300 Perl_tied_method(aTHX_ "GETC", SP, MUTABLE_SV(io), mg, gimme, 0);
1301 if (gimme == G_SCALAR) {
1303 SvSetMagicSV_nosteal(TARG, TOPs);
1308 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1309 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1311 SETERRNO(EBADF,RMS_IFI);
1315 sv_setpvs(TARG, " ");
1316 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1317 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1318 /* Find out how many bytes the char needs */
1319 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1322 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1323 SvCUR_set(TARG,1+len);
1332 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1336 const I32 gimme = GIMME_V;
1338 PERL_ARGS_ASSERT_DOFORM;
1340 if (cv && CvCLONE(cv))
1341 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1346 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1347 PUSHFORMAT(cx, retop);
1348 if (CvDEPTH(cv) >= 2) {
1349 PERL_STACK_OVERFLOW_CHECK();
1350 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1353 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1355 setdefout(gv); /* locally select filehandle so $% et al work */
1374 gv = MUTABLE_GV(POPs);
1391 tmpsv = sv_newmortal();
1392 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1393 DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
1395 IoFLAGS(io) &= ~IOf_DIDTOP;
1396 RETURNOP(doform(cv,gv,PL_op->op_next));
1402 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1403 IO * const io = GvIOp(gv);
1411 if (!io || !(ofp = IoOFP(io)))
1414 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1415 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1417 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1418 PL_formtarget != PL_toptarget)
1422 if (!IoTOP_GV(io)) {
1425 if (!IoTOP_NAME(io)) {
1427 if (!IoFMT_NAME(io))
1428 IoFMT_NAME(io) = savepv(GvNAME(gv));
1429 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1430 HEKfARG(GvNAME_HEK(gv))));
1431 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1432 if ((topgv && GvFORM(topgv)) ||
1433 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1434 IoTOP_NAME(io) = savesvpv(topname);
1436 IoTOP_NAME(io) = savepvs("top");
1438 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1439 if (!topgv || !GvFORM(topgv)) {
1440 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1443 IoTOP_GV(io) = topgv;
1445 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1446 I32 lines = IoLINES_LEFT(io);
1447 const char *s = SvPVX_const(PL_formtarget);
1448 if (lines <= 0) /* Yow, header didn't even fit!!! */
1450 while (lines-- > 0) {
1451 s = strchr(s, '\n');
1457 const STRLEN save = SvCUR(PL_formtarget);
1458 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1459 do_print(PL_formtarget, ofp);
1460 SvCUR_set(PL_formtarget, save);
1461 sv_chop(PL_formtarget, s);
1462 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1465 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1466 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1467 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1469 PL_formtarget = PL_toptarget;
1470 IoFLAGS(io) |= IOf_DIDTOP;
1473 DIE(aTHX_ "bad top format reference");
1476 SV * const sv = sv_newmortal();
1477 gv_efullname4(sv, fgv, NULL, FALSE);
1478 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1480 return doform(cv, gv, PL_op);
1484 POPBLOCK(cx,PL_curpm);
1486 retop = cx->blk_sub.retop;
1487 SP = newsp; /* ignore retval of formline */
1490 if (!io || !(fp = IoOFP(io))) {
1491 if (io && IoIFP(io))
1492 report_wrongway_fh(gv, '<');
1498 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1499 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1501 if (!do_print(PL_formtarget, fp))
1504 FmLINES(PL_formtarget) = 0;
1505 SvCUR_set(PL_formtarget, 0);
1506 *SvEND(PL_formtarget) = '\0';
1507 if (IoFLAGS(io) & IOf_FLUSH)
1508 (void)PerlIO_flush(fp);
1512 PL_formtarget = PL_bodytarget;
1513 PERL_UNUSED_VAR(gimme);
1519 dVAR; dSP; dMARK; dORIGMARK;
1523 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1524 IO *const io = GvIO(gv);
1526 /* Treat empty list as "" */
1527 if (MARK == SP) XPUSHs(&PL_sv_no);
1530 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1532 if (MARK == ORIGMARK) {
1535 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1538 return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io),
1540 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1547 SETERRNO(EBADF,RMS_IFI);
1550 else if (!(fp = IoOFP(io))) {
1552 report_wrongway_fh(gv, '<');
1553 else if (ckWARN(WARN_CLOSED))
1555 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1559 SV *sv = sv_newmortal();
1560 do_sprintf(sv, SP - MARK, MARK + 1);
1561 if (!do_print(sv, fp))
1564 if (IoFLAGS(io) & IOf_FLUSH)
1565 if (PerlIO_flush(fp) == EOF)
1574 PUSHs(&PL_sv_undef);
1582 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1583 const int mode = POPi;
1584 SV * const sv = POPs;
1585 GV * const gv = MUTABLE_GV(POPs);
1588 /* Need TIEHANDLE method ? */
1589 const char * const tmps = SvPV_const(sv, len);
1590 /* FIXME? do_open should do const */
1591 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1592 IoLINES(GvIOp(gv)) = 0;
1596 PUSHs(&PL_sv_undef);
1603 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1617 bool charstart = FALSE;
1618 STRLEN charskip = 0;
1621 GV * const gv = MUTABLE_GV(*++MARK);
1622 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1623 && gv && (io = GvIO(gv)) )
1625 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1627 return Perl_tied_method(aTHX_ "READ", mark - 1, MUTABLE_SV(io), mg,
1628 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1637 sv_setpvs(bufsv, "");
1638 length = SvIVx(*++MARK);
1640 DIE(aTHX_ "Negative length");
1643 offset = SvIVx(*++MARK);
1647 if (!io || !IoIFP(io)) {
1649 SETERRNO(EBADF,RMS_IFI);
1652 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1653 buffer = SvPVutf8_force(bufsv, blen);
1654 /* UTF-8 may not have been set if they are all low bytes */
1659 buffer = SvPV_force(bufsv, blen);
1660 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1662 if (DO_UTF8(bufsv)) {
1663 blen = sv_len_utf8_nomg(bufsv);
1672 if (PL_op->op_type == OP_RECV) {
1673 Sock_size_t bufsize;
1674 char namebuf[MAXPATHLEN];
1675 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1676 bufsize = sizeof (struct sockaddr_in);
1678 bufsize = sizeof namebuf;
1680 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1684 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1685 /* 'offset' means 'flags' here */
1686 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1687 (struct sockaddr *)namebuf, &bufsize);
1690 /* MSG_TRUNC can give oversized count; quietly lose it */
1693 SvCUR_set(bufsv, count);
1694 *SvEND(bufsv) = '\0';
1695 (void)SvPOK_only(bufsv);
1699 /* This should not be marked tainted if the fp is marked clean */
1700 if (!(IoFLAGS(io) & IOf_UNTAINT))
1701 SvTAINTED_on(bufsv);
1703 sv_setpvn(TARG, namebuf, bufsize);
1709 if (-offset > (SSize_t)blen)
1710 DIE(aTHX_ "Offset outside string");
1713 if (DO_UTF8(bufsv)) {
1714 /* convert offset-as-chars to offset-as-bytes */
1715 if (offset >= (SSize_t)blen)
1716 offset += SvCUR(bufsv) - blen;
1718 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1721 orig_size = SvCUR(bufsv);
1722 /* Allocating length + offset + 1 isn't perfect in the case of reading
1723 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1725 (should be 2 * length + offset + 1, or possibly something longer if
1726 PL_encoding is true) */
1727 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1728 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1729 Zero(buffer+orig_size, offset-orig_size, char);
1731 buffer = buffer + offset;
1733 read_target = bufsv;
1735 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1736 concatenate it to the current buffer. */
1738 /* Truncate the existing buffer to the start of where we will be
1740 SvCUR_set(bufsv, offset);
1742 read_target = sv_newmortal();
1743 SvUPGRADE(read_target, SVt_PV);
1744 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1747 if (PL_op->op_type == OP_SYSREAD) {
1748 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1749 if (IoTYPE(io) == IoTYPE_SOCKET) {
1750 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1756 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1761 #ifdef HAS_SOCKET__bad_code_maybe
1762 if (IoTYPE(io) == IoTYPE_SOCKET) {
1763 Sock_size_t bufsize;
1764 char namebuf[MAXPATHLEN];
1765 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1766 bufsize = sizeof (struct sockaddr_in);
1768 bufsize = sizeof namebuf;
1770 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1771 (struct sockaddr *)namebuf, &bufsize);
1776 count = PerlIO_read(IoIFP(io), buffer, length);
1777 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1778 if (count == 0 && PerlIO_error(IoIFP(io)))
1782 if (IoTYPE(io) == IoTYPE_WRONLY)
1783 report_wrongway_fh(gv, '>');
1786 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1787 *SvEND(read_target) = '\0';
1788 (void)SvPOK_only(read_target);
1789 if (fp_utf8 && !IN_BYTES) {
1790 /* Look at utf8 we got back and count the characters */
1791 const char *bend = buffer + count;
1792 while (buffer < bend) {
1794 skip = UTF8SKIP(buffer);
1797 if (buffer - charskip + skip > bend) {
1798 /* partial character - try for rest of it */
1799 length = skip - (bend-buffer);
1800 offset = bend - SvPVX_const(bufsv);
1812 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1813 provided amount read (count) was what was requested (length)
1815 if (got < wanted && count == length) {
1816 length = wanted - got;
1817 offset = bend - SvPVX_const(bufsv);
1820 /* return value is character count */
1824 else if (buffer_utf8) {
1825 /* Let svcatsv upgrade the bytes we read in to utf8.
1826 The buffer is a mortal so will be freed soon. */
1827 sv_catsv_nomg(bufsv, read_target);
1830 /* This should not be marked tainted if the fp is marked clean */
1831 if (!(IoFLAGS(io) & IOf_UNTAINT))
1832 SvTAINTED_on(bufsv);
1844 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1849 STRLEN orig_blen_bytes;
1850 const int op_type = PL_op->op_type;
1853 GV *const gv = MUTABLE_GV(*++MARK);
1854 IO *const io = GvIO(gv);
1856 if (op_type == OP_SYSWRITE && io) {
1857 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1859 if (MARK == SP - 1) {
1861 mXPUSHi(sv_len(sv));
1865 return Perl_tied_method(aTHX_ "WRITE", mark - 1, MUTABLE_SV(io), mg,
1866 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1876 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1878 if (io && IoIFP(io))
1879 report_wrongway_fh(gv, '<');
1882 SETERRNO(EBADF,RMS_IFI);
1886 /* Do this first to trigger any overloading. */
1887 buffer = SvPV_const(bufsv, blen);
1888 orig_blen_bytes = blen;
1889 doing_utf8 = DO_UTF8(bufsv);
1891 if (PerlIO_isutf8(IoIFP(io))) {
1892 if (!SvUTF8(bufsv)) {
1893 /* We don't modify the original scalar. */
1894 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1895 buffer = (char *) tmpbuf;
1899 else if (doing_utf8) {
1900 STRLEN tmplen = blen;
1901 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1904 buffer = (char *) tmpbuf;
1908 assert((char *)result == buffer);
1909 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1914 if (op_type == OP_SEND) {
1915 const int flags = SvIVx(*++MARK);
1918 char * const sockbuf = SvPVx(*++MARK, mlen);
1919 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1920 flags, (struct sockaddr *)sockbuf, mlen);
1924 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1930 Size_t length = 0; /* This length is in characters. */
1936 /* The SV is bytes, and we've had to upgrade it. */
1937 blen_chars = orig_blen_bytes;
1939 /* The SV really is UTF-8. */
1940 /* Don't call sv_len_utf8 on a magical or overloaded
1941 scalar, as we might get back a different result. */
1942 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
1949 length = blen_chars;
1951 #if Size_t_size > IVSIZE
1952 length = (Size_t)SvNVx(*++MARK);
1954 length = (Size_t)SvIVx(*++MARK);
1956 if ((SSize_t)length < 0) {
1958 DIE(aTHX_ "Negative length");
1963 offset = SvIVx(*++MARK);
1965 if (-offset > (IV)blen_chars) {
1967 DIE(aTHX_ "Offset outside string");
1969 offset += blen_chars;
1970 } else if (offset > (IV)blen_chars) {
1972 DIE(aTHX_ "Offset outside string");
1976 if (length > blen_chars - offset)
1977 length = blen_chars - offset;
1979 /* Here we convert length from characters to bytes. */
1980 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1981 /* Either we had to convert the SV, or the SV is magical, or
1982 the SV has overloading, in which case we can't or mustn't
1983 or mustn't call it again. */
1985 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1986 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1988 /* It's a real UTF-8 SV, and it's not going to change under
1989 us. Take advantage of any cache. */
1991 I32 len_I32 = length;
1993 /* Convert the start and end character positions to bytes.
1994 Remember that the second argument to sv_pos_u2b is relative
1996 sv_pos_u2b(bufsv, &start, &len_I32);
2003 buffer = buffer+offset;
2005 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2006 if (IoTYPE(io) == IoTYPE_SOCKET) {
2007 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
2013 /* See the note at doio.c:do_print about filesize limits. --jhi */
2014 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2023 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2026 #if Size_t_size > IVSIZE
2046 * in Perl 5.12 and later, the additional parameter is a bitmask:
2049 * 2 = eof() <- ARGV magic
2051 * I'll rely on the compiler's trace flow analysis to decide whether to
2052 * actually assign this out here, or punt it into the only block where it is
2053 * used. Doing it out here is DRY on the condition logic.
2058 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2064 if (PL_op->op_flags & OPf_SPECIAL) {
2065 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2069 gv = PL_last_in_gv; /* eof */
2077 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2078 return tied_method1("EOF", SP, MUTABLE_SV(io), mg, newSVuv(which));
2081 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2082 if (io && !IoIFP(io)) {
2083 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2085 IoFLAGS(io) &= ~IOf_START;
2086 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2088 sv_setpvs(GvSV(gv), "-");
2090 GvSV(gv) = newSVpvs("-");
2091 SvSETMAGIC(GvSV(gv));
2093 else if (!nextargv(gv))
2098 PUSHs(boolSV(do_eof(gv)));
2108 if (MAXARG != 0 && (TOPs || POPs))
2109 PL_last_in_gv = MUTABLE_GV(POPs);
2116 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2118 return tied_method0("TELL", SP, MUTABLE_SV(io), mg);
2123 SETERRNO(EBADF,RMS_IFI);
2128 #if LSEEKSIZE > IVSIZE
2129 PUSHn( do_tell(gv) );
2131 PUSHi( do_tell(gv) );
2139 const int whence = POPi;
2140 #if LSEEKSIZE > IVSIZE
2141 const Off_t offset = (Off_t)SvNVx(POPs);
2143 const Off_t offset = (Off_t)SvIVx(POPs);
2146 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2147 IO *const io = GvIO(gv);
2150 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2152 #if LSEEKSIZE > IVSIZE
2153 SV *const offset_sv = newSVnv((NV) offset);
2155 SV *const offset_sv = newSViv(offset);
2158 return tied_method2("SEEK", SP, MUTABLE_SV(io), mg, offset_sv,
2163 if (PL_op->op_type == OP_SEEK)
2164 PUSHs(boolSV(do_seek(gv, offset, whence)));
2166 const Off_t sought = do_sysseek(gv, offset, whence);
2168 PUSHs(&PL_sv_undef);
2170 SV* const sv = sought ?
2171 #if LSEEKSIZE > IVSIZE
2176 : newSVpvn(zero_but_true, ZBTLEN);
2187 /* There seems to be no consensus on the length type of truncate()
2188 * and ftruncate(), both off_t and size_t have supporters. In
2189 * general one would think that when using large files, off_t is
2190 * at least as wide as size_t, so using an off_t should be okay. */
2191 /* XXX Configure probe for the length type of *truncate() needed XXX */
2194 #if Off_t_size > IVSIZE
2199 /* Checking for length < 0 is problematic as the type might or
2200 * might not be signed: if it is not, clever compilers will moan. */
2201 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2204 SV * const sv = POPs;
2209 if (PL_op->op_flags & OPf_SPECIAL
2210 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2211 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2218 TAINT_PROPER("truncate");
2219 if (!(fp = IoIFP(io))) {
2225 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2227 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2233 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2234 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2235 goto do_ftruncate_io;
2238 const char * const name = SvPV_nomg_const_nolen(sv);
2239 TAINT_PROPER("truncate");
2241 if (truncate(name, len) < 0)
2245 const int tmpfd = PerlLIO_open(name, O_RDWR);
2250 if (my_chsize(tmpfd, len) < 0)
2252 PerlLIO_close(tmpfd);
2261 SETERRNO(EBADF,RMS_IFI);
2269 SV * const argsv = POPs;
2270 const unsigned int func = POPu;
2271 const int optype = PL_op->op_type;
2272 GV * const gv = MUTABLE_GV(POPs);
2273 IO * const io = gv ? GvIOn(gv) : NULL;
2277 if (!io || !argsv || !IoIFP(io)) {
2279 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2283 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2286 s = SvPV_force(argsv, len);
2287 need = IOCPARM_LEN(func);
2289 s = Sv_Grow(argsv, need + 1);
2290 SvCUR_set(argsv, need);
2293 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2296 retval = SvIV(argsv);
2297 s = INT2PTR(char*,retval); /* ouch */
2300 TAINT_PROPER(PL_op_desc[optype]);
2302 if (optype == OP_IOCTL)
2304 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2306 DIE(aTHX_ "ioctl is not implemented");
2310 DIE(aTHX_ "fcntl is not implemented");
2312 #if defined(OS2) && defined(__EMX__)
2313 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2315 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2319 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2321 if (s[SvCUR(argsv)] != 17)
2322 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2324 s[SvCUR(argsv)] = 0; /* put our null back */
2325 SvSETMAGIC(argsv); /* Assume it has changed */
2334 PUSHp(zero_but_true, ZBTLEN);
2345 const int argtype = POPi;
2346 GV * const gv = MUTABLE_GV(POPs);
2347 IO *const io = GvIO(gv);
2348 PerlIO *const fp = io ? IoIFP(io) : NULL;
2350 /* XXX Looks to me like io is always NULL at this point */
2352 (void)PerlIO_flush(fp);
2353 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2358 SETERRNO(EBADF,RMS_IFI);
2363 DIE(aTHX_ PL_no_func, "flock()");
2374 const int protocol = POPi;
2375 const int type = POPi;
2376 const int domain = POPi;
2377 GV * const gv = MUTABLE_GV(POPs);
2378 IO * const io = gv ? GvIOn(gv) : NULL;
2383 if (io && IoIFP(io))
2384 do_close(gv, FALSE);
2385 SETERRNO(EBADF,LIB_INVARG);
2390 do_close(gv, FALSE);
2392 TAINT_PROPER("socket");
2393 fd = PerlSock_socket(domain, type, protocol);
2396 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2397 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2398 IoTYPE(io) = IoTYPE_SOCKET;
2399 if (!IoIFP(io) || !IoOFP(io)) {
2400 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2401 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2402 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2405 #if defined(HAS_FCNTL) && defined(F_SETFD)
2406 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2415 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2417 const int protocol = POPi;
2418 const int type = POPi;
2419 const int domain = POPi;
2420 GV * const gv2 = MUTABLE_GV(POPs);
2421 GV * const gv1 = MUTABLE_GV(POPs);
2422 IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2423 IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2427 report_evil_fh(gv1);
2429 report_evil_fh(gv2);
2431 if (io1 && IoIFP(io1))
2432 do_close(gv1, FALSE);
2433 if (io2 && IoIFP(io2))
2434 do_close(gv2, FALSE);
2439 TAINT_PROPER("socketpair");
2440 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2442 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2443 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2444 IoTYPE(io1) = IoTYPE_SOCKET;
2445 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2446 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2447 IoTYPE(io2) = IoTYPE_SOCKET;
2448 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2449 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2450 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2451 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2452 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2453 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2454 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2457 #if defined(HAS_FCNTL) && defined(F_SETFD)
2458 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2459 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2464 DIE(aTHX_ PL_no_sock_func, "socketpair");
2473 SV * const addrsv = POPs;
2474 /* OK, so on what platform does bind modify addr? */
2476 GV * const gv = MUTABLE_GV(POPs);
2477 IO * const io = GvIOn(gv);
2479 const int op_type = PL_op->op_type;
2481 if (!io || !IoIFP(io))
2484 addr = SvPV_const(addrsv, len);
2485 TAINT_PROPER(PL_op_desc[op_type]);
2486 if ((op_type == OP_BIND
2487 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2488 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2496 SETERRNO(EBADF,SS_IVCHAN);
2503 const int backlog = POPi;
2504 GV * const gv = MUTABLE_GV(POPs);
2505 IO * const io = gv ? GvIOn(gv) : NULL;
2507 if (!io || !IoIFP(io))
2510 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2517 SETERRNO(EBADF,SS_IVCHAN);
2526 char namebuf[MAXPATHLEN];
2527 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2528 Sock_size_t len = sizeof (struct sockaddr_in);
2530 Sock_size_t len = sizeof namebuf;
2532 GV * const ggv = MUTABLE_GV(POPs);
2533 GV * const ngv = MUTABLE_GV(POPs);
2542 if (!gstio || !IoIFP(gstio))
2546 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2549 /* Some platforms indicate zero length when an AF_UNIX client is
2550 * not bound. Simulate a non-zero-length sockaddr structure in
2552 namebuf[0] = 0; /* sun_len */
2553 namebuf[1] = AF_UNIX; /* sun_family */
2561 do_close(ngv, FALSE);
2562 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2563 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2564 IoTYPE(nstio) = IoTYPE_SOCKET;
2565 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2566 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2567 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2568 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2571 #if defined(HAS_FCNTL) && defined(F_SETFD)
2572 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2575 #ifdef __SCO_VERSION__
2576 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2579 PUSHp(namebuf, len);
2583 report_evil_fh(ggv);
2584 SETERRNO(EBADF,SS_IVCHAN);
2594 const int how = POPi;
2595 GV * const gv = MUTABLE_GV(POPs);
2596 IO * const io = GvIOn(gv);
2598 if (!io || !IoIFP(io))
2601 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2606 SETERRNO(EBADF,SS_IVCHAN);
2613 const int optype = PL_op->op_type;
2614 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2615 const unsigned int optname = (unsigned int) POPi;
2616 const unsigned int lvl = (unsigned int) POPi;
2617 GV * const gv = MUTABLE_GV(POPs);
2618 IO * const io = GvIOn(gv);
2622 if (!io || !IoIFP(io))
2625 fd = PerlIO_fileno(IoIFP(io));
2629 (void)SvPOK_only(sv);
2633 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2640 #if defined(__SYMBIAN32__)
2641 # define SETSOCKOPT_OPTION_VALUE_T void *
2643 # define SETSOCKOPT_OPTION_VALUE_T const char *
2645 /* XXX TODO: We need to have a proper type (a Configure probe,
2646 * etc.) for what the C headers think of the third argument of
2647 * setsockopt(), the option_value read-only buffer: is it
2648 * a "char *", or a "void *", const or not. Some compilers
2649 * don't take kindly to e.g. assuming that "char *" implicitly
2650 * promotes to a "void *", or to explicitly promoting/demoting
2651 * consts to non/vice versa. The "const void *" is the SUS
2652 * definition, but that does not fly everywhere for the above
2654 SETSOCKOPT_OPTION_VALUE_T buf;
2658 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2662 aint = (int)SvIV(sv);
2663 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2666 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2676 SETERRNO(EBADF,SS_IVCHAN);
2685 const int optype = PL_op->op_type;
2686 GV * const gv = MUTABLE_GV(POPs);
2687 IO * const io = GvIOn(gv);
2692 if (!io || !IoIFP(io))
2695 sv = sv_2mortal(newSV(257));
2696 (void)SvPOK_only(sv);
2700 fd = PerlIO_fileno(IoIFP(io));
2702 case OP_GETSOCKNAME:
2703 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2706 case OP_GETPEERNAME:
2707 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2709 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2711 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";
2712 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2713 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2714 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2715 sizeof(u_short) + sizeof(struct in_addr))) {
2722 #ifdef BOGUS_GETNAME_RETURN
2723 /* Interactive Unix, getpeername() and getsockname()
2724 does not return valid namelen */
2725 if (len == BOGUS_GETNAME_RETURN)
2726 len = sizeof(struct sockaddr);
2735 SETERRNO(EBADF,SS_IVCHAN);
2754 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2755 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2756 if (PL_op->op_type == OP_LSTAT) {
2757 if (gv != PL_defgv) {
2758 do_fstat_warning_check:
2759 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2760 "lstat() on filehandle%s%"SVf,
2763 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2765 } else if (PL_laststype != OP_LSTAT)
2766 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2767 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2770 if (gv != PL_defgv) {
2774 PL_laststype = OP_STAT;
2775 PL_statgv = gv ? gv : (GV *)io;
2776 sv_setpvs(PL_statname, "");
2783 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2785 } else if (IoDIRP(io)) {
2787 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2790 PL_laststatval = -1;
2793 else PL_laststatval = -1;
2794 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2797 if (PL_laststatval < 0) {
2802 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2803 io = MUTABLE_IO(SvRV(sv));
2804 if (PL_op->op_type == OP_LSTAT)
2805 goto do_fstat_warning_check;
2806 goto do_fstat_have_io;
2809 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2810 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2812 PL_laststype = PL_op->op_type;
2813 if (PL_op->op_type == OP_LSTAT)
2814 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2816 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2817 if (PL_laststatval < 0) {
2818 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2819 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2825 if (gimme != G_ARRAY) {
2826 if (gimme != G_VOID)
2827 XPUSHs(boolSV(max));
2833 mPUSHi(PL_statcache.st_dev);
2834 #if ST_INO_SIZE > IVSIZE
2835 mPUSHn(PL_statcache.st_ino);
2837 # if ST_INO_SIGN <= 0
2838 mPUSHi(PL_statcache.st_ino);
2840 mPUSHu(PL_statcache.st_ino);
2843 mPUSHu(PL_statcache.st_mode);
2844 mPUSHu(PL_statcache.st_nlink);
2845 #if Uid_t_size > IVSIZE
2846 mPUSHn(PL_statcache.st_uid);
2848 # if Uid_t_sign <= 0
2849 mPUSHi(PL_statcache.st_uid);
2851 mPUSHu(PL_statcache.st_uid);
2854 #if Gid_t_size > IVSIZE
2855 mPUSHn(PL_statcache.st_gid);
2857 # if Gid_t_sign <= 0
2858 mPUSHi(PL_statcache.st_gid);
2860 mPUSHu(PL_statcache.st_gid);
2863 #ifdef USE_STAT_RDEV
2864 mPUSHi(PL_statcache.st_rdev);
2866 PUSHs(newSVpvs_flags("", SVs_TEMP));
2868 #if Off_t_size > IVSIZE
2869 mPUSHn(PL_statcache.st_size);
2871 mPUSHi(PL_statcache.st_size);
2874 mPUSHn(PL_statcache.st_atime);
2875 mPUSHn(PL_statcache.st_mtime);
2876 mPUSHn(PL_statcache.st_ctime);
2878 mPUSHi(PL_statcache.st_atime);
2879 mPUSHi(PL_statcache.st_mtime);
2880 mPUSHi(PL_statcache.st_ctime);
2882 #ifdef USE_STAT_BLOCKS
2883 mPUSHu(PL_statcache.st_blksize);
2884 mPUSHu(PL_statcache.st_blocks);
2886 PUSHs(newSVpvs_flags("", SVs_TEMP));
2887 PUSHs(newSVpvs_flags("", SVs_TEMP));
2893 /* All filetest ops avoid manipulating the perl stack pointer in their main
2894 bodies (since commit d2c4d2d1e22d3125), and return using either
2895 S_ft_return_false() or S_ft_return_true(). These two helper functions are
2896 the only two which manipulate the perl stack. To ensure that no stack
2897 manipulation macros are used, the filetest ops avoid defining a local copy
2898 of the stack pointer with dSP. */
2900 /* If the next filetest is stacked up with this one
2901 (PL_op->op_private & OPpFT_STACKING), we leave
2902 the original argument on the stack for success,
2903 and skip the stacked operators on failure.
2904 The next few macros/functions take care of this.
2908 S_ft_return_false(pTHX_ SV *ret) {
2912 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
2916 if (PL_op->op_private & OPpFT_STACKING) {
2917 while (OP_IS_FILETEST(next->op_type)
2918 && next->op_private & OPpFT_STACKED)
2919 next = next->op_next;
2924 PERL_STATIC_INLINE OP *
2925 S_ft_return_true(pTHX_ SV *ret) {
2927 if (PL_op->op_flags & OPf_REF)
2928 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
2929 else if (!(PL_op->op_private & OPpFT_STACKING))
2935 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
2936 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
2937 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
2939 #define tryAMAGICftest_MG(chr) STMT_START { \
2940 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
2941 && PL_op->op_flags & OPf_KIDS) { \
2942 OP *next = S_try_amagic_ftest(aTHX_ chr); \
2943 if (next) return next; \
2948 S_try_amagic_ftest(pTHX_ char chr) {
2950 SV *const arg = *PL_stack_sp;
2953 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
2957 const char tmpchr = chr;
2958 SV * const tmpsv = amagic_call(arg,
2959 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2960 ftest_amg, AMGf_unary);
2965 return SvTRUE(tmpsv)
2966 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
2976 /* Not const, because things tweak this below. Not bool, because there's
2977 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2978 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2979 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2980 /* Giving some sort of initial value silences compilers. */
2982 int access_mode = R_OK;
2984 int access_mode = 0;
2987 /* access_mode is never used, but leaving use_access in makes the
2988 conditional compiling below much clearer. */
2991 Mode_t stat_mode = S_IRUSR;
2993 bool effective = FALSE;
2996 switch (PL_op->op_type) {
2997 case OP_FTRREAD: opchar = 'R'; break;
2998 case OP_FTRWRITE: opchar = 'W'; break;
2999 case OP_FTREXEC: opchar = 'X'; break;
3000 case OP_FTEREAD: opchar = 'r'; break;
3001 case OP_FTEWRITE: opchar = 'w'; break;
3002 case OP_FTEEXEC: opchar = 'x'; break;
3004 tryAMAGICftest_MG(opchar);
3006 switch (PL_op->op_type) {
3008 #if !(defined(HAS_ACCESS) && defined(R_OK))
3014 #if defined(HAS_ACCESS) && defined(W_OK)
3019 stat_mode = S_IWUSR;
3023 #if defined(HAS_ACCESS) && defined(X_OK)
3028 stat_mode = S_IXUSR;
3032 #ifdef PERL_EFF_ACCESS
3035 stat_mode = S_IWUSR;
3039 #ifndef PERL_EFF_ACCESS
3046 #ifdef PERL_EFF_ACCESS
3051 stat_mode = S_IXUSR;
3057 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3058 const char *name = SvPV_nolen(*PL_stack_sp);
3060 # ifdef PERL_EFF_ACCESS
3061 result = PERL_EFF_ACCESS(name, access_mode);
3063 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3069 result = access(name, access_mode);
3071 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3082 result = my_stat_flags(0);
3085 if (cando(stat_mode, effective, &PL_statcache))
3094 const int op_type = PL_op->op_type;
3098 case OP_FTIS: opchar = 'e'; break;
3099 case OP_FTSIZE: opchar = 's'; break;
3100 case OP_FTMTIME: opchar = 'M'; break;
3101 case OP_FTCTIME: opchar = 'C'; break;
3102 case OP_FTATIME: opchar = 'A'; break;
3104 tryAMAGICftest_MG(opchar);
3106 result = my_stat_flags(0);
3109 if (op_type == OP_FTIS)
3112 /* You can't dTARGET inside OP_FTIS, because you'll get
3113 "panic: pad_sv po" - the op is not flagged to have a target. */
3117 #if Off_t_size > IVSIZE
3118 sv_setnv(TARG, (NV)PL_statcache.st_size);
3120 sv_setiv(TARG, (IV)PL_statcache.st_size);
3125 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3129 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3133 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3137 return SvTRUE_nomg(TARG)
3138 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3148 switch (PL_op->op_type) {
3149 case OP_FTROWNED: opchar = 'O'; break;
3150 case OP_FTEOWNED: opchar = 'o'; break;
3151 case OP_FTZERO: opchar = 'z'; break;
3152 case OP_FTSOCK: opchar = 'S'; break;
3153 case OP_FTCHR: opchar = 'c'; break;
3154 case OP_FTBLK: opchar = 'b'; break;
3155 case OP_FTFILE: opchar = 'f'; break;
3156 case OP_FTDIR: opchar = 'd'; break;
3157 case OP_FTPIPE: opchar = 'p'; break;
3158 case OP_FTSUID: opchar = 'u'; break;
3159 case OP_FTSGID: opchar = 'g'; break;
3160 case OP_FTSVTX: opchar = 'k'; break;
3162 tryAMAGICftest_MG(opchar);
3164 /* I believe that all these three are likely to be defined on most every
3165 system these days. */
3167 if(PL_op->op_type == OP_FTSUID) {
3172 if(PL_op->op_type == OP_FTSGID) {
3177 if(PL_op->op_type == OP_FTSVTX) {
3182 result = my_stat_flags(0);
3185 switch (PL_op->op_type) {
3187 if (PL_statcache.st_uid == PerlProc_getuid())
3191 if (PL_statcache.st_uid == PerlProc_geteuid())
3195 if (PL_statcache.st_size == 0)
3199 if (S_ISSOCK(PL_statcache.st_mode))
3203 if (S_ISCHR(PL_statcache.st_mode))
3207 if (S_ISBLK(PL_statcache.st_mode))
3211 if (S_ISREG(PL_statcache.st_mode))
3215 if (S_ISDIR(PL_statcache.st_mode))
3219 if (S_ISFIFO(PL_statcache.st_mode))
3224 if (PL_statcache.st_mode & S_ISUID)
3230 if (PL_statcache.st_mode & S_ISGID)
3236 if (PL_statcache.st_mode & S_ISVTX)
3249 tryAMAGICftest_MG('l');
3250 result = my_lstat_flags(0);
3254 if (S_ISLNK(PL_statcache.st_mode))
3267 tryAMAGICftest_MG('t');
3269 if (PL_op->op_flags & OPf_REF)
3272 SV *tmpsv = *PL_stack_sp;
3273 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3274 name = SvPV_nomg(tmpsv, namelen);
3275 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3279 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3280 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3281 else if (name && isDIGIT(*name))
3285 if (PerlLIO_isatty(fd))
3303 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3305 if (PL_op->op_flags & OPf_REF)
3307 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3312 gv = MAYBE_DEREF_GV_nomg(sv);
3316 if (gv == PL_defgv) {
3318 io = SvTYPE(PL_statgv) == SVt_PVIO
3322 goto really_filename;
3327 sv_setpvs(PL_statname, "");
3328 io = GvIO(PL_statgv);
3330 PL_laststatval = -1;
3331 PL_laststype = OP_STAT;
3332 if (io && IoIFP(io)) {
3333 if (! PerlIO_has_base(IoIFP(io)))
3334 DIE(aTHX_ "-T and -B not implemented on filehandles");
3335 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3336 if (PL_laststatval < 0)
3338 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3339 if (PL_op->op_type == OP_FTTEXT)
3344 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3345 i = PerlIO_getc(IoIFP(io));
3347 (void)PerlIO_ungetc(IoIFP(io),i);
3349 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3351 len = PerlIO_get_bufsiz(IoIFP(io));
3352 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3353 /* sfio can have large buffers - limit to 512 */
3358 SETERRNO(EBADF,RMS_IFI);
3360 SETERRNO(EBADF,RMS_IFI);
3365 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3368 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3370 PL_laststatval = -1;
3371 PL_laststype = OP_STAT;
3373 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3375 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3378 PL_laststype = OP_STAT;
3379 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3380 if (PL_laststatval < 0) {
3381 (void)PerlIO_close(fp);
3384 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3385 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3386 (void)PerlIO_close(fp);
3388 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3389 FT_RETURNNO; /* special case NFS directories */
3390 FT_RETURNYES; /* null file is anything */
3395 /* now scan s to look for textiness */
3396 /* XXX ASCII dependent code */
3398 #if defined(DOSISH) || defined(USEMYBINMODE)
3399 /* ignore trailing ^Z on short files */
3400 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3404 for (i = 0; i < len; i++, s++) {
3405 if (!*s) { /* null never allowed in text */
3410 else if (!(isPRINT(*s) || isSPACE(*s)))
3413 else if (*s & 128) {
3415 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3418 /* utf8 characters don't count as odd */
3419 if (UTF8_IS_START(*s)) {
3420 int ulen = UTF8SKIP(s);
3421 if (ulen < len - i) {
3423 for (j = 1; j < ulen; j++) {
3424 if (!UTF8_IS_CONTINUATION(s[j]))
3427 --ulen; /* loop does extra increment */
3437 *s != '\n' && *s != '\r' && *s != '\b' &&
3438 *s != '\t' && *s != '\f' && *s != 27)
3443 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3454 const char *tmps = NULL;
3458 SV * const sv = POPs;
3459 if (PL_op->op_flags & OPf_SPECIAL) {
3460 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3462 else if (!(gv = MAYBE_DEREF_GV(sv)))
3463 tmps = SvPV_nomg_const_nolen(sv);
3466 if( !gv && (!tmps || !*tmps) ) {
3467 HV * const table = GvHVn(PL_envgv);
3470 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3471 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3473 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3478 deprecate("chdir('') or chdir(undef) as chdir()");
3479 tmps = SvPV_nolen_const(*svp);
3483 TAINT_PROPER("chdir");
3488 TAINT_PROPER("chdir");
3491 IO* const io = GvIO(gv);
3494 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3495 } else if (IoIFP(io)) {
3496 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3500 SETERRNO(EBADF, RMS_IFI);
3506 SETERRNO(EBADF,RMS_IFI);
3510 DIE(aTHX_ PL_no_func, "fchdir");
3514 PUSHi( PerlDir_chdir(tmps) >= 0 );
3516 /* Clear the DEFAULT element of ENV so we'll get the new value
3518 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3525 dVAR; dSP; dMARK; dTARGET;
3526 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3537 char * const tmps = POPpx;
3538 TAINT_PROPER("chroot");
3539 PUSHi( chroot(tmps) >= 0 );
3542 DIE(aTHX_ PL_no_func, "chroot");
3550 const char * const tmps2 = POPpconstx;
3551 const char * const tmps = SvPV_nolen_const(TOPs);
3552 TAINT_PROPER("rename");
3554 anum = PerlLIO_rename(tmps, tmps2);
3556 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3557 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3560 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3561 (void)UNLINK(tmps2);
3562 if (!(anum = link(tmps, tmps2)))
3563 anum = UNLINK(tmps);
3571 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3575 const int op_type = PL_op->op_type;
3579 if (op_type == OP_LINK)
3580 DIE(aTHX_ PL_no_func, "link");
3582 # ifndef HAS_SYMLINK
3583 if (op_type == OP_SYMLINK)
3584 DIE(aTHX_ PL_no_func, "symlink");
3588 const char * const tmps2 = POPpconstx;
3589 const char * const tmps = SvPV_nolen_const(TOPs);
3590 TAINT_PROPER(PL_op_desc[op_type]);
3592 # if defined(HAS_LINK)
3593 # if defined(HAS_SYMLINK)
3594 /* Both present - need to choose which. */
3595 (op_type == OP_LINK) ?
3596 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3598 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3599 PerlLIO_link(tmps, tmps2);
3602 # if defined(HAS_SYMLINK)
3603 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3604 symlink(tmps, tmps2);
3609 SETi( result >= 0 );
3616 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3627 char buf[MAXPATHLEN];
3630 #ifndef INCOMPLETE_TAINTS
3634 len = readlink(tmps, buf, sizeof(buf) - 1);
3641 RETSETUNDEF; /* just pretend it's a normal file */
3645 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3647 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3649 char * const save_filename = filename;
3654 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3656 PERL_ARGS_ASSERT_DOONELINER;
3658 Newx(cmdline, size, char);
3659 my_strlcpy(cmdline, cmd, size);
3660 my_strlcat(cmdline, " ", size);
3661 for (s = cmdline + strlen(cmdline); *filename; ) {
3665 if (s - cmdline < size)
3666 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3667 myfp = PerlProc_popen(cmdline, "r");
3671 SV * const tmpsv = sv_newmortal();
3672 /* Need to save/restore 'PL_rs' ?? */
3673 s = sv_gets(tmpsv, myfp, 0);
3674 (void)PerlProc_pclose(myfp);
3678 #ifdef HAS_SYS_ERRLIST
3683 /* you don't see this */
3684 const char * const errmsg =
3685 #ifdef HAS_SYS_ERRLIST
3693 if (instr(s, errmsg)) {
3700 #define EACCES EPERM
3702 if (instr(s, "cannot make"))
3703 SETERRNO(EEXIST,RMS_FEX);
3704 else if (instr(s, "existing file"))
3705 SETERRNO(EEXIST,RMS_FEX);
3706 else if (instr(s, "ile exists"))
3707 SETERRNO(EEXIST,RMS_FEX);
3708 else if (instr(s, "non-exist"))
3709 SETERRNO(ENOENT,RMS_FNF);
3710 else if (instr(s, "does not exist"))
3711 SETERRNO(ENOENT,RMS_FNF);
3712 else if (instr(s, "not empty"))
3713 SETERRNO(EBUSY,SS_DEVOFFLINE);
3714 else if (instr(s, "cannot access"))
3715 SETERRNO(EACCES,RMS_PRV);
3717 SETERRNO(EPERM,RMS_PRV);
3720 else { /* some mkdirs return no failure indication */
3721 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3722 if (PL_op->op_type == OP_RMDIR)
3727 SETERRNO(EACCES,RMS_PRV); /* a guess */
3736 /* This macro removes trailing slashes from a directory name.
3737 * Different operating and file systems take differently to
3738 * trailing slashes. According to POSIX 1003.1 1996 Edition
3739 * any number of trailing slashes should be allowed.
3740 * Thusly we snip them away so that even non-conforming
3741 * systems are happy.
3742 * We should probably do this "filtering" for all
3743 * the functions that expect (potentially) directory names:
3744 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3745 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3747 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3748 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3751 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3752 (tmps) = savepvn((tmps), (len)); \
3762 const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3764 TRIMSLASHES(tmps,len,copy);
3766 TAINT_PROPER("mkdir");
3768 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3772 SETi( dooneliner("mkdir", tmps) );
3773 oldumask = PerlLIO_umask(0);
3774 PerlLIO_umask(oldumask);
3775 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3790 TRIMSLASHES(tmps,len,copy);
3791 TAINT_PROPER("rmdir");
3793 SETi( PerlDir_rmdir(tmps) >= 0 );
3795 SETi( dooneliner("rmdir", tmps) );
3802 /* Directory calls. */
3806 #if defined(Direntry_t) && defined(HAS_READDIR)
3808 const char * const dirname = POPpconstx;
3809 GV * const gv = MUTABLE_GV(POPs);
3810 IO * const io = GvIOn(gv);
3815 if ((IoIFP(io) || IoOFP(io)))
3816 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3817 "Opening filehandle %"HEKf" also as a directory",
3818 HEKfARG(GvENAME_HEK(gv)) );
3820 PerlDir_close(IoDIRP(io));
3821 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3827 SETERRNO(EBADF,RMS_DIR);
3830 DIE(aTHX_ PL_no_dir_func, "opendir");
3836 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3837 DIE(aTHX_ PL_no_dir_func, "readdir");
3839 #if !defined(I_DIRENT) && !defined(VMS)
3840 Direntry_t *readdir (DIR *);
3846 const I32 gimme = GIMME;
3847 GV * const gv = MUTABLE_GV(POPs);
3848 const Direntry_t *dp;
3849 IO * const io = GvIOn(gv);
3851 if (!io || !IoDIRP(io)) {
3852 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3853 "readdir() attempted on invalid dirhandle %"HEKf,
3854 HEKfARG(GvENAME_HEK(gv)));
3859 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3863 sv = newSVpvn(dp->d_name, dp->d_namlen);
3865 sv = newSVpv(dp->d_name, 0);
3867 #ifndef INCOMPLETE_TAINTS
3868 if (!(IoFLAGS(io) & IOf_UNTAINT))
3872 } while (gimme == G_ARRAY);
3874 if (!dp && gimme != G_ARRAY)
3881 SETERRNO(EBADF,RMS_ISI);
3882 if (GIMME == G_ARRAY)
3891 #if defined(HAS_TELLDIR) || defined(telldir)
3893 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3894 /* XXX netbsd still seemed to.
3895 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3896 --JHI 1999-Feb-02 */
3897 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3898 long telldir (DIR *);
3900 GV * const gv = MUTABLE_GV(POPs);
3901 IO * const io = GvIOn(gv);
3903 if (!io || !IoDIRP(io)) {
3904 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3905 "telldir() attempted on invalid dirhandle %"HEKf,
3906 HEKfARG(GvENAME_HEK(gv)));
3910 PUSHi( PerlDir_tell(IoDIRP(io)) );
3914 SETERRNO(EBADF,RMS_ISI);
3917 DIE(aTHX_ PL_no_dir_func, "telldir");
3923 #if defined(HAS_SEEKDIR) || defined(seekdir)
3925 const long along = POPl;
3926 GV * const gv = MUTABLE_GV(POPs);
3927 IO * const io = GvIOn(gv);
3929 if (!io || !IoDIRP(io)) {
3930 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3931 "seekdir() attempted on invalid dirhandle %"HEKf,
3932 HEKfARG(GvENAME_HEK(gv)));
3935 (void)PerlDir_seek(IoDIRP(io), along);
3940 SETERRNO(EBADF,RMS_ISI);
3943 DIE(aTHX_ PL_no_dir_func, "seekdir");
3949 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3951 GV * const gv = MUTABLE_GV(POPs);
3952 IO * const io = GvIOn(gv);
3954 if (!io || !IoDIRP(io)) {
3955 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3956 "rewinddir() attempted on invalid dirhandle %"HEKf,
3957 HEKfARG(GvENAME_HEK(gv)));
3960 (void)PerlDir_rewind(IoDIRP(io));
3964 SETERRNO(EBADF,RMS_ISI);
3967 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3973 #if defined(Direntry_t) && defined(HAS_READDIR)
3975 GV * const gv = MUTABLE_GV(POPs);
3976 IO * const io = GvIOn(gv);
3978 if (!io || !IoDIRP(io)) {
3979 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3980 "closedir() attempted on invalid dirhandle %"HEKf,
3981 HEKfARG(GvENAME_HEK(gv)));
3984 #ifdef VOID_CLOSEDIR
3985 PerlDir_close(IoDIRP(io));
3987 if (PerlDir_close(IoDIRP(io)) < 0) {
3988 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3997 SETERRNO(EBADF,RMS_IFI);
4000 DIE(aTHX_ PL_no_dir_func, "closedir");
4004 /* Process control. */
4011 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4012 sigset_t oldmask, newmask;
4016 PERL_FLUSHALL_FOR_CHILD;
4017 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4018 sigfillset(&newmask);
4019 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4021 childpid = PerlProc_fork();
4022 if (childpid == 0) {
4026 for (sig = 1; sig < SIG_SIZE; sig++)
4027 PL_psig_pend[sig] = 0;
4029 #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4032 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4039 #ifdef PERL_USES_PL_PIDSTATUS
4040 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4046 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4051 PERL_FLUSHALL_FOR_CHILD;
4052 childpid = PerlProc_fork();
4058 DIE(aTHX_ PL_no_func, "fork");
4065 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4070 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4071 childpid = wait4pid(-1, &argflags, 0);
4073 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4078 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4079 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4080 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4082 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4087 DIE(aTHX_ PL_no_func, "wait");
4093 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4095 const int optype = POPi;
4096 const Pid_t pid = TOPi;
4100 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4101 result = wait4pid(pid, &argflags, optype);
4103 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4108 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4109 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4110 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4112 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4117 DIE(aTHX_ PL_no_func, "waitpid");
4123 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4124 #if defined(__LIBCATAMOUNT__)
4125 PL_statusvalue = -1;
4134 while (++MARK <= SP) {
4135 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4140 TAINT_PROPER("system");
4142 PERL_FLUSHALL_FOR_CHILD;
4143 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4148 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4149 sigset_t newset, oldset;
4152 if (PerlProc_pipe(pp) >= 0)
4154 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4155 sigemptyset(&newset);
4156 sigaddset(&newset, SIGCHLD);
4157 sigprocmask(SIG_BLOCK, &newset, &oldset);
4159 while ((childpid = PerlProc_fork()) == -1) {
4160 if (errno != EAGAIN) {
4165 PerlLIO_close(pp[0]);
4166 PerlLIO_close(pp[1]);
4168 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4169 sigprocmask(SIG_SETMASK, &oldset, NULL);
4176 Sigsave_t ihand,qhand; /* place to save signals during system() */
4180 PerlLIO_close(pp[1]);
4182 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4183 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4186 result = wait4pid(childpid, &status, 0);
4187 } while (result == -1 && errno == EINTR);
4189 #ifdef HAS_SIGPROCMASK
4190 sigprocmask(SIG_SETMASK, &oldset, NULL);
4192 (void)rsignal_restore(SIGINT, &ihand);
4193 (void)rsignal_restore(SIGQUIT, &qhand);
4195 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4196 do_execfree(); /* free any memory child malloced on fork */
4203 while (n < sizeof(int)) {
4204 n1 = PerlLIO_read(pp[0],
4205 (void*)(((char*)&errkid)+n),
4211 PerlLIO_close(pp[0]);
4212 if (n) { /* Error */
4213 if (n != sizeof(int))
4214 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4215 errno = errkid; /* Propagate errno from kid */
4216 STATUS_NATIVE_CHILD_SET(-1);
4219 XPUSHi(STATUS_CURRENT);
4222 #if (defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO))
4223 sigprocmask(SIG_SETMASK, &oldset, NULL);
4226 PerlLIO_close(pp[0]);
4227 #if defined(HAS_FCNTL) && defined(F_SETFD)
4228 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4231 if (PL_op->op_flags & OPf_STACKED) {
4232 SV * const really = *++MARK;
4233 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4235 else if (SP - MARK != 1)
4236 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4238 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4242 #else /* ! FORK or VMS or OS/2 */
4245 if (PL_op->op_flags & OPf_STACKED) {
4246 SV * const really = *++MARK;
4247 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4248 value = (I32)do_aspawn(really, MARK, SP);
4250 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4253 else if (SP - MARK != 1) {
4254 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4255 value = (I32)do_aspawn(NULL, MARK, SP);
4257 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4261 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4263 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4265 STATUS_NATIVE_CHILD_SET(value);
4268 XPUSHi(result ? value : STATUS_CURRENT);
4269 #endif /* !FORK or VMS or OS/2 */
4276 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4281 while (++MARK <= SP) {
4282 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4287 TAINT_PROPER("exec");
4289 PERL_FLUSHALL_FOR_CHILD;
4290 if (PL_op->op_flags & OPf_STACKED) {
4291 SV * const really = *++MARK;
4292 value = (I32)do_aexec(really, MARK, SP);
4294 else if (SP - MARK != 1)
4296 value = (I32)vms_do_aexec(NULL, MARK, SP);
4298 value = (I32)do_aexec(NULL, MARK, SP);
4302 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4304 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4317 XPUSHi( getppid() );
4320 DIE(aTHX_ PL_no_func, "getppid");
4330 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4333 pgrp = (I32)BSD_GETPGRP(pid);
4335 if (pid != 0 && pid != PerlProc_getpid())
4336 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4342 DIE(aTHX_ PL_no_func, "getpgrp()");
4352 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4353 if (MAXARG > 0) pid = TOPs && TOPi;
4359 TAINT_PROPER("setpgrp");
4361 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4363 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4364 || (pid != 0 && pid != PerlProc_getpid()))
4366 DIE(aTHX_ "setpgrp can't take arguments");
4368 SETi( setpgrp() >= 0 );
4369 #endif /* USE_BSDPGRP */
4372 DIE(aTHX_ PL_no_func, "setpgrp()");
4376 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4377 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4379 # define PRIORITY_WHICH_T(which) which
4384 #ifdef HAS_GETPRIORITY
4386 const int who = POPi;
4387 const int which = TOPi;
4388 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4391 DIE(aTHX_ PL_no_func, "getpriority()");
4397 #ifdef HAS_SETPRIORITY
4399 const int niceval = POPi;
4400 const int who = POPi;
4401 const int which = TOPi;
4402 TAINT_PROPER("setpriority");
4403 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4406 DIE(aTHX_ PL_no_func, "setpriority()");
4410 #undef PRIORITY_WHICH_T
4418 XPUSHn( time(NULL) );
4420 XPUSHi( time(NULL) );
4432 (void)PerlProc_times(&PL_timesbuf);
4434 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4435 /* struct tms, though same data */
4439 mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4440 if (GIMME == G_ARRAY) {
4441 mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4442 mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4443 mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4451 if (GIMME == G_ARRAY) {
4458 DIE(aTHX_ "times not implemented");
4460 #endif /* HAS_TIMES */
4463 /* The 32 bit int year limits the times we can represent to these
4464 boundaries with a few days wiggle room to account for time zone
4467 /* Sat Jan 3 00:00:00 -2147481748 */
4468 #define TIME_LOWER_BOUND -67768100567755200.0
4469 /* Sun Dec 29 12:00:00 2147483647 */
4470 #define TIME_UPPER_BOUND 67767976233316800.0
4479 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4480 static const char * const dayname[] =
4481 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4482 static const char * const monname[] =
4483 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4484 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4486 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4489 when = (Time64_T)now;
4492 NV input = Perl_floor(POPn);
4493 when = (Time64_T)input;
4494 if (when != input) {
4495 /* diag_listed_as: gmtime(%f) too large */
4496 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4497 "%s(%.0" NVff ") too large", opname, input);
4501 if ( TIME_LOWER_BOUND > when ) {
4502 /* diag_listed_as: gmtime(%f) too small */
4503 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4504 "%s(%.0" NVff ") too small", opname, when);
4507 else if( when > TIME_UPPER_BOUND ) {
4508 /* diag_listed_as: gmtime(%f) too small */
4509 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4510 "%s(%.0" NVff ") too large", opname, when);
4514 if (PL_op->op_type == OP_LOCALTIME)
4515 err = S_localtime64_r(&when, &tmbuf);
4517 err = S_gmtime64_r(&when, &tmbuf);
4521 /* XXX %lld broken for quads */
4522 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4523 "%s(%.0" NVff ") failed", opname, when);
4526 if (GIMME != G_ARRAY) { /* scalar context */
4528 /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4529 double year = (double)tmbuf.tm_year + 1900;
4536 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4537 dayname[tmbuf.tm_wday],
4538 monname[tmbuf.tm_mon],
4546 else { /* list context */
4552 mPUSHi(tmbuf.tm_sec);
4553 mPUSHi(tmbuf.tm_min);
4554 mPUSHi(tmbuf.tm_hour);
4555 mPUSHi(tmbuf.tm_mday);
4556 mPUSHi(tmbuf.tm_mon);
4557 mPUSHn(tmbuf.tm_year);
4558 mPUSHi(tmbuf.tm_wday);
4559 mPUSHi(tmbuf.tm_yday);
4560 mPUSHi(tmbuf.tm_isdst);
4571 anum = alarm((unsigned int)anum);
4577 DIE(aTHX_ PL_no_func, "alarm");
4588 (void)time(&lasttime);
4589 if (MAXARG < 1 || (!TOPs && !POPs))
4593 PerlProc_sleep((unsigned int)duration);
4596 XPUSHi(when - lasttime);
4600 /* Shared memory. */
4601 /* Merged with some message passing. */
4605 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4606 dVAR; dSP; dMARK; dTARGET;
4607 const int op_type = PL_op->op_type;
4612 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4615 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4618 value = (I32)(do_semop(MARK, SP) >= 0);
4621 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4629 return Perl_pp_semget(aTHX);
4637 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4638 dVAR; dSP; dMARK; dTARGET;
4639 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4646 DIE(aTHX_ "System V IPC is not implemented on this machine");
4652 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4653 dVAR; dSP; dMARK; dTARGET;
4654 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4662 PUSHp(zero_but_true, ZBTLEN);
4666 return Perl_pp_semget(aTHX);
4670 /* I can't const this further without getting warnings about the types of
4671 various arrays passed in from structures. */
4673 S_space_join_names_mortal(pTHX_ char *const *array)
4677 PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4679 if (array && *array) {
4680 target = newSVpvs_flags("", SVs_TEMP);
4682 sv_catpv(target, *array);
4685 sv_catpvs(target, " ");
4688 target = sv_mortalcopy(&PL_sv_no);
4693 /* Get system info. */
4697 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4699 I32 which = PL_op->op_type;
4702 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4703 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4704 struct hostent *gethostbyname(Netdb_name_t);
4705 struct hostent *gethostent(void);
4707 struct hostent *hent = NULL;
4711 if (which == OP_GHBYNAME) {
4712 #ifdef HAS_GETHOSTBYNAME
4713 const char* const name = POPpbytex;
4714 hent = PerlSock_gethostbyname(name);
4716 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4719 else if (which == OP_GHBYADDR) {
4720 #ifdef HAS_GETHOSTBYADDR
4721 const int addrtype = POPi;
4722 SV * const addrsv = POPs;
4724 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4726 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4728 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4732 #ifdef HAS_GETHOSTENT
4733 hent = PerlSock_gethostent();
4735 DIE(aTHX_ PL_no_sock_func, "gethostent");
4738 #ifdef HOST_NOT_FOUND
4740 #ifdef USE_REENTRANT_API
4741 # ifdef USE_GETHOSTENT_ERRNO
4742 h_errno = PL_reentrant_buffer->_gethostent_errno;
4745 STATUS_UNIX_SET(h_errno);
4749 if (GIMME != G_ARRAY) {
4750 PUSHs(sv = sv_newmortal());
4752 if (which == OP_GHBYNAME) {
4754 sv_setpvn(sv, hent->h_addr, hent->h_length);
4757 sv_setpv(sv, (char*)hent->h_name);
4763 mPUSHs(newSVpv((char*)hent->h_name, 0));
4764 PUSHs(space_join_names_mortal(hent->h_aliases));
4765 mPUSHi(hent->h_addrtype);
4766 len = hent->h_length;
4769 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4770 mXPUSHp(*elem, len);
4774 mPUSHp(hent->h_addr, len);
4776 PUSHs(sv_mortalcopy(&PL_sv_no));
4781 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4787 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4789 I32 which = PL_op->op_type;
4791 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4792 struct netent *getnetbyaddr(Netdb_net_t, int);
4793 struct netent *getnetbyname(Netdb_name_t);
4794 struct netent *getnetent(void);
4796 struct netent *nent;
4798 if (which == OP_GNBYNAME){
4799 #ifdef HAS_GETNETBYNAME
4800 const char * const name = POPpbytex;
4801 nent = PerlSock_getnetbyname(name);
4803 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4806 else if (which == OP_GNBYADDR) {
4807 #ifdef HAS_GETNETBYADDR
4808 const int addrtype = POPi;
4809 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4810 nent = PerlSock_getnetbyaddr(addr, addrtype);
4812 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4816 #ifdef HAS_GETNETENT
4817 nent = PerlSock_getnetent();
4819 DIE(aTHX_ PL_no_sock_func, "getnetent");
4822 #ifdef HOST_NOT_FOUND
4824 #ifdef USE_REENTRANT_API
4825 # ifdef USE_GETNETENT_ERRNO
4826 h_errno = PL_reentrant_buffer->_getnetent_errno;
4829 STATUS_UNIX_SET(h_errno);
4834 if (GIMME != G_ARRAY) {
4835 PUSHs(sv = sv_newmortal());
4837 if (which == OP_GNBYNAME)
4838 sv_setiv(sv, (IV)nent->n_net);
4840 sv_setpv(sv, nent->n_name);
4846 mPUSHs(newSVpv(nent->n_name, 0));
4847 PUSHs(space_join_names_mortal(nent->n_aliases));
4848 mPUSHi(nent->n_addrtype);
4849 mPUSHi(nent->n_net);
4854 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4860 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4862 I32 which = PL_op->op_type;
4864 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4865 struct protoent *getprotobyname(Netdb_name_t);
4866 struct protoent *getprotobynumber(int);
4867 struct protoent *getprotoent(void);
4869 struct protoent *pent;
4871 if (which == OP_GPBYNAME) {
4872 #ifdef HAS_GETPROTOBYNAME
4873 const char* const name = POPpbytex;
4874 pent = PerlSock_getprotobyname(name);
4876 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4879 else if (which == OP_GPBYNUMBER) {
4880 #ifdef HAS_GETPROTOBYNUMBER
4881 const int number = POPi;
4882 pent = PerlSock_getprotobynumber(number);
4884 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4888 #ifdef HAS_GETPROTOENT
4889 pent = PerlSock_getprotoent();
4891 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4895 if (GIMME != G_ARRAY) {
4896 PUSHs(sv = sv_newmortal());
4898 if (which == OP_GPBYNAME)
4899 sv_setiv(sv, (IV)pent->p_proto);
4901 sv_setpv(sv, pent->p_name);
4907 mPUSHs(newSVpv(pent->p_name, 0));
4908 PUSHs(space_join_names_mortal(pent->p_aliases));
4909 mPUSHi(pent->p_proto);
4914 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4920 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4922 I32 which = PL_op->op_type;
4924 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4925 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4926 struct servent *getservbyport(int, Netdb_name_t);
4927 struct servent *getservent(void);
4929 struct servent *sent;
4931 if (which == OP_GSBYNAME) {
4932 #ifdef HAS_GETSERVBYNAME
4933 const char * const proto = POPpbytex;
4934 const char * const name = POPpbytex;
4935 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4937 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4940 else if (which == OP_GSBYPORT) {
4941 #ifdef HAS_GETSERVBYPORT
4942 const char * const proto = POPpbytex;
4943 unsigned short port = (unsigned short)POPu;
4945 port = PerlSock_htons(port);
4947 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4949 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4953 #ifdef HAS_GETSERVENT
4954 sent = PerlSock_getservent();
4956 DIE(aTHX_ PL_no_sock_func, "getservent");
4960 if (GIMME != G_ARRAY) {
4961 PUSHs(sv = sv_newmortal());
4963 if (which == OP_GSBYNAME) {
4965 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4967 sv_setiv(sv, (IV)(sent->s_port));
4971 sv_setpv(sv, sent->s_name);
4977 mPUSHs(newSVpv(sent->s_name, 0));
4978 PUSHs(space_join_names_mortal(sent->s_aliases));
4980 mPUSHi(PerlSock_ntohs(sent->s_port));
4982 mPUSHi(sent->s_port);
4984 mPUSHs(newSVpv(sent->s_proto, 0));
4989 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4996 const int stayopen = TOPi;
4997 switch(PL_op->op_type) {
4999 #ifdef HAS_SETHOSTENT
5000 PerlSock_sethostent(stayopen);
5002 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5005 #ifdef HAS_SETNETENT
5007 PerlSock_setnetent(stayopen);
5009 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5013 #ifdef HAS_SETPROTOENT
5014 PerlSock_setprotoent(stayopen);
5016 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5020 #ifdef HAS_SETSERVENT
5021 PerlSock_setservent(stayopen);
5023 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5033 switch(PL_op->op_type) {
5035 #ifdef HAS_ENDHOSTENT
5036 PerlSock_endhostent();
5038 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5042 #ifdef HAS_ENDNETENT
5043 PerlSock_endnetent();
5045 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5049 #ifdef HAS_ENDPROTOENT
5050 PerlSock_endprotoent();
5052 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5056 #ifdef HAS_ENDSERVENT
5057 PerlSock_endservent();
5059 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5063 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5066 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5070 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5073 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5077 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5080 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5084 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5087 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5099 I32 which = PL_op->op_type;
5101 struct passwd *pwent = NULL;
5103 * We currently support only the SysV getsp* shadow password interface.
5104 * The interface is declared in <shadow.h> and often one needs to link
5105 * with -lsecurity or some such.
5106 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5109 * AIX getpwnam() is clever enough to return the encrypted password
5110 * only if the caller (euid?) is root.
5112 * There are at least three other shadow password APIs. Many platforms
5113 * seem to contain more than one interface for accessing the shadow
5114 * password databases, possibly for compatibility reasons.
5115 * The getsp*() is by far he simplest one, the other two interfaces
5116 * are much more complicated, but also very similar to each other.
5121 * struct pr_passwd *getprpw*();
5122 * The password is in
5123 * char getprpw*(...).ufld.fd_encrypt[]
5124 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5129 * struct es_passwd *getespw*();
5130 * The password is in
5131 * char *(getespw*(...).ufld.fd_encrypt)
5132 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5135 * struct userpw *getuserpw();
5136 * The password is in
5137 * char *(getuserpw(...)).spw_upw_passwd
5138 * (but the de facto standard getpwnam() should work okay)
5140 * Mention I_PROT here so that Configure probes for it.
5142 * In HP-UX for getprpw*() the manual page claims that one should include
5143 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5144 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5145 * and pp_sys.c already includes <shadow.h> if there is such.
5147 * Note that <sys/security.h> is already probed for, but currently
5148 * it is only included in special cases.
5150 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5151 * be preferred interface, even though also the getprpw*() interface
5152 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5153 * One also needs to call set_auth_parameters() in main() before
5154 * doing anything else, whether one is using getespw*() or getprpw*().
5156 * Note that accessing the shadow databases can be magnitudes
5157 * slower than accessing the standard databases.
5162 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5163 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5164 * the pw_comment is left uninitialized. */
5165 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5171 const char* const name = POPpbytex;
5172 pwent = getpwnam(name);
5178 pwent = getpwuid(uid);
5182 # ifdef HAS_GETPWENT
5184 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5185 if (pwent) pwent = getpwnam(pwent->pw_name);
5188 DIE(aTHX_ PL_no_func, "getpwent");
5194 if (GIMME != G_ARRAY) {
5195 PUSHs(sv = sv_newmortal());
5197 if (which == OP_GPWNAM)
5198 # if Uid_t_sign <= 0
5199 sv_setiv(sv, (IV)pwent->pw_uid);
5201 sv_setuv(sv, (UV)pwent->pw_uid);
5204 sv_setpv(sv, pwent->pw_name);
5210 mPUSHs(newSVpv(pwent->pw_name, 0));
5214 /* If we have getspnam(), we try to dig up the shadow
5215 * password. If we are underprivileged, the shadow
5216 * interface will set the errno to EACCES or similar,
5217 * and return a null pointer. If this happens, we will
5218 * use the dummy password (usually "*" or "x") from the
5219 * standard password database.
5221 * In theory we could skip the shadow call completely
5222 * if euid != 0 but in practice we cannot know which
5223 * security measures are guarding the shadow databases
5224 * on a random platform.
5226 * Resist the urge to use additional shadow interfaces.
5227 * Divert the urge to writing an extension instead.
5230 /* Some AIX setups falsely(?) detect some getspnam(), which
5231 * has a different API than the Solaris/IRIX one. */
5232 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5235 const struct spwd * const spwent = getspnam(pwent->pw_name);
5236 /* Save and restore errno so that
5237 * underprivileged attempts seem
5238 * to have never made the unsuccessful
5239 * attempt to retrieve the shadow password. */
5241 if (spwent && spwent->sp_pwdp)
5242 sv_setpv(sv, spwent->sp_pwdp);
5246 if (!SvPOK(sv)) /* Use the standard password, then. */
5247 sv_setpv(sv, pwent->pw_passwd);
5250 # ifndef INCOMPLETE_TAINTS
5251 /* passwd is tainted because user himself can diddle with it.
5252 * admittedly not much and in a very limited way, but nevertheless. */
5256 # if Uid_t_sign <= 0
5257 mPUSHi(pwent->pw_uid);
5259 mPUSHu(pwent->pw_uid);
5262 # if Uid_t_sign <= 0
5263 mPUSHi(pwent->pw_gid);
5265 mPUSHu(pwent->pw_gid);
5267 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5268 * because of the poor interface of the Perl getpw*(),
5269 * not because there's some standard/convention saying so.
5270 * A better interface would have been to return a hash,
5271 * but we are accursed by our history, alas. --jhi. */
5273 mPUSHi(pwent->pw_change);
5276 mPUSHi(pwent->pw_quota);
5279 mPUSHs(newSVpv(pwent->pw_age, 0));
5281 /* I think that you can never get this compiled, but just in case. */
5282 PUSHs(sv_mortalcopy(&PL_sv_no));
5287 /* pw_class and pw_comment are mutually exclusive--.
5288 * see the above note for pw_change, pw_quota, and pw_age. */
5290 mPUSHs(newSVpv(pwent->pw_class, 0));
5293 mPUSHs(newSVpv(pwent->pw_comment, 0));
5295 /* I think that you can never get this compiled, but just in case. */
5296 PUSHs(sv_mortalcopy(&PL_sv_no));
5301 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5303 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5305 # ifndef INCOMPLETE_TAINTS
5306 /* pw_gecos is tainted because user himself can diddle with it. */
5310 mPUSHs(newSVpv(pwent->pw_dir, 0));
5312 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5313 # ifndef INCOMPLETE_TAINTS
5314 /* pw_shell is tainted because user himself can diddle with it. */
5319 mPUSHi(pwent->pw_expire);
5324 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5332 const I32 which = PL_op->op_type;
5333 const struct group *grent;
5335 if (which == OP_GGRNAM) {
5336 const char* const name = POPpbytex;
5337 grent = (const struct group *)getgrnam(name);
5339 else if (which == OP_GGRGID) {
5340 const Gid_t gid = POPi;
5341 grent = (const struct group *)getgrgid(gid);
5345 grent = (struct group *)getgrent();
5347 DIE(aTHX_ PL_no_func, "getgrent");
5351 if (GIMME != G_ARRAY) {
5352 SV * const sv = sv_newmortal();
5356 if (which == OP_GGRNAM)
5358 sv_setiv(sv, (IV)grent->gr_gid);
5360 sv_setuv(sv, (UV)grent->gr_gid);
5363 sv_setpv(sv, grent->gr_name);
5369 mPUSHs(newSVpv(grent->gr_name, 0));
5372 mPUSHs(newSVpv(grent->gr_passwd, 0));
5374 PUSHs(sv_mortalcopy(&PL_sv_no));
5378 mPUSHi(grent->gr_gid);
5380 mPUSHu(grent->gr_gid);
5383 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5384 /* In UNICOS/mk (_CRAYMPP) the multithreading
5385 * versions (getgrnam_r, getgrgid_r)
5386 * seem to return an illegal pointer
5387 * as the group members list, gr_mem.
5388 * getgrent() doesn't even have a _r version
5389 * but the gr_mem is poisonous anyway.
5390 * So yes, you cannot get the list of group
5391 * members if building multithreaded in UNICOS/mk. */
5392 PUSHs(space_join_names_mortal(grent->gr_mem));
5398 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5408 if (!(tmps = PerlProc_getlogin()))
5410 sv_setpv_mg(TARG, tmps);
5414 DIE(aTHX_ PL_no_func, "getlogin");
5418 /* Miscellaneous. */
5423 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5424 I32 items = SP - MARK;
5425 unsigned long a[20];
5430 while (++MARK <= SP) {
5431 if (SvTAINTED(*MARK)) {
5437 TAINT_PROPER("syscall");
5440 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5441 * or where sizeof(long) != sizeof(char*). But such machines will
5442 * not likely have syscall implemented either, so who cares?
5444 while (++MARK <= SP) {
5445 if (SvNIOK(*MARK) || !i)
5446 a[i++] = SvIV(*MARK);
5447 else if (*MARK == &PL_sv_undef)
5450 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5456 DIE(aTHX_ "Too many args to syscall");
5458 DIE(aTHX_ "Too few args to syscall");
5460 retval = syscall(a[0]);
5463 retval = syscall(a[0],a[1]);
5466 retval = syscall(a[0],a[1],a[2]);
5469 retval = syscall(a[0],a[1],a[2],a[3]);
5472 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5475 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5478 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5481 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5488 DIE(aTHX_ PL_no_func, "syscall");
5492 #ifdef FCNTL_EMULATE_FLOCK
5494 /* XXX Emulate flock() with fcntl().
5495 What's really needed is a good file locking module.
5499 fcntl_emulate_flock(int fd, int operation)
5504 switch (operation & ~LOCK_NB) {
5506 flock.l_type = F_RDLCK;
5509 flock.l_type = F_WRLCK;
5512 flock.l_type = F_UNLCK;
5518 flock.l_whence = SEEK_SET;
5519 flock.l_start = flock.l_len = (Off_t)0;
5521 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5522 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5523 errno = EWOULDBLOCK;
5527 #endif /* FCNTL_EMULATE_FLOCK */
5529 #ifdef LOCKF_EMULATE_FLOCK
5531 /* XXX Emulate flock() with lockf(). This is just to increase
5532 portability of scripts. The calls are not completely
5533 interchangeable. What's really needed is a good file
5537 /* The lockf() constants might have been defined in <unistd.h>.
5538 Unfortunately, <unistd.h> causes troubles on some mixed
5539 (BSD/POSIX) systems, such as SunOS 4.1.3.
5541 Further, the lockf() constants aren't POSIX, so they might not be
5542 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5543 just stick in the SVID values and be done with it. Sigh.
5547 # define F_ULOCK 0 /* Unlock a previously locked region */
5550 # define F_LOCK 1 /* Lock a region for exclusive use */
5553 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5556 # define F_TEST 3 /* Test a region for other processes locks */
5560 lockf_emulate_flock(int fd, int operation)
5566 /* flock locks entire file so for lockf we need to do the same */
5567 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5568 if (pos > 0) /* is seekable and needs to be repositioned */
5569 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5570 pos = -1; /* seek failed, so don't seek back afterwards */
5573 switch (operation) {
5575 /* LOCK_SH - get a shared lock */
5577 /* LOCK_EX - get an exclusive lock */
5579 i = lockf (fd, F_LOCK, 0);
5582 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5583 case LOCK_SH|LOCK_NB:
5584 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5585 case LOCK_EX|LOCK_NB:
5586 i = lockf (fd, F_TLOCK, 0);
5588 if ((errno == EAGAIN) || (errno == EACCES))
5589 errno = EWOULDBLOCK;
5592 /* LOCK_UN - unlock (non-blocking is a no-op) */
5594 case LOCK_UN|LOCK_NB:
5595 i = lockf (fd, F_ULOCK, 0);
5598 /* Default - can't decipher operation */
5605 if (pos > 0) /* need to restore position of the handle */
5606 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5611 #endif /* LOCKF_EMULATE_FLOCK */
5615 * c-indentation-style: bsd
5617 * indent-tabs-mode: nil
5620 * ex: set ts=8 sts=4 sw=4 et: