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
35 /* Shadow password support for solaris - pdo@cs.umd.edu
36 * Not just Solaris: at least HP-UX, IRIX, Linux.
37 * The API is from SysV.
39 * There are at least two more shadow interfaces,
40 * see the comments in pp_gpwent().
44 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
45 * and another MAXINT from "perl.h" <- <sys/param.h>. */
52 # include <sys/resource.h>
61 # include <sys/select.h>
65 /* XXX Configure test needed.
66 h_errno might not be a simple 'int', especially for multi-threaded
67 applications, see "extern int errno in perl.h". Creating such
68 a test requires taking into account the differences between
69 compiling multithreaded and singlethreaded ($ccflags et al).
70 HOST_NOT_FOUND is typically defined in <netdb.h>.
72 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
81 struct passwd *getpwnam (char *);
82 struct passwd *getpwuid (Uid_t);
87 struct passwd *getpwent (void);
88 #elif defined (VMS) && defined (my_getpwent)
89 struct passwd *Perl_my_getpwent (pTHX);
98 struct group *getgrnam (char *);
99 struct group *getgrgid (Gid_t);
103 struct group *getgrent (void);
109 # if defined(_MSC_VER) || defined(__MINGW32__)
110 # include <sys/utime.h>
117 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
120 # define my_chsize PerlLIO_chsize
123 # define my_chsize PerlLIO_chsize
125 I32 my_chsize(int fd, Off_t length);
131 #else /* no flock() */
133 /* fcntl.h might not have been included, even if it exists, because
134 the current Configure only sets I_FCNTL if it's needed to pick up
135 the *_OK constants. Make sure it has been included before testing
136 the fcntl() locking constants. */
137 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
141 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
142 # define FLOCK fcntl_emulate_flock
143 # define FCNTL_EMULATE_FLOCK
144 # else /* no flock() or fcntl(F_SETLK,...) */
146 # define FLOCK lockf_emulate_flock
147 # define LOCKF_EMULATE_FLOCK
149 # endif /* no flock() or fcntl(F_SETLK,...) */
152 static int FLOCK (int, int);
155 * These are the flock() constants. Since this sytems doesn't have
156 * flock(), the values of the constants are probably not available.
170 # endif /* emulating flock() */
172 #endif /* no flock() */
175 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
177 #if defined(I_SYS_ACCESS) && !defined(R_OK)
178 # include <sys/access.h>
184 /* Missing protos on LynxOS */
185 void sethostent(int);
186 void endhostent(void);
188 void endnetent(void);
189 void setprotoent(int);
190 void endprotoent(void);
191 void setservent(int);
192 void endservent(void);
196 # include "amigaos4/amigaio.h"
199 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
201 /* F_OK unused: if stat() cannot find it... */
203 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
204 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
205 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
208 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
209 # ifdef I_SYS_SECURITY
210 # include <sys/security.h>
214 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
217 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
221 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
223 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
227 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
228 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
229 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
232 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
234 const Uid_t ruid = getuid();
235 const Uid_t euid = geteuid();
236 const Gid_t rgid = getgid();
237 const Gid_t egid = getegid();
240 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
241 Perl_croak(aTHX_ "switching effective uid is not implemented");
244 if (setreuid(euid, ruid))
247 if (setresuid(euid, ruid, (Uid_t)-1))
250 /* diag_listed_as: entering effective %s failed */
251 Perl_croak(aTHX_ "entering effective uid failed");
254 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
255 Perl_croak(aTHX_ "switching effective gid is not implemented");
258 if (setregid(egid, rgid))
261 if (setresgid(egid, rgid, (Gid_t)-1))
264 /* diag_listed_as: entering effective %s failed */
265 Perl_croak(aTHX_ "entering effective gid failed");
268 res = access(path, mode);
271 if (setreuid(ruid, euid))
274 if (setresuid(ruid, euid, (Uid_t)-1))
277 /* diag_listed_as: leaving effective %s failed */
278 Perl_croak(aTHX_ "leaving effective uid failed");
281 if (setregid(rgid, egid))
284 if (setresgid(rgid, egid, (Gid_t)-1))
287 /* diag_listed_as: leaving effective %s failed */
288 Perl_croak(aTHX_ "leaving effective gid failed");
292 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
299 const char * const tmps = POPpconstx;
300 const U8 gimme = GIMME_V;
301 const char *mode = "r";
304 if (PL_op->op_private & OPpOPEN_IN_RAW)
306 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
308 fp = PerlProc_popen(tmps, mode);
310 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
312 PerlIO_apply_layers(aTHX_ fp,mode,type);
314 if (gimme == G_VOID) {
316 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
319 else if (gimme == G_SCALAR) {
320 ENTER_with_name("backtick");
322 PL_rs = &PL_sv_undef;
323 SvPVCLEAR(TARG); /* note that this preserves previous buffer */
324 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
326 LEAVE_with_name("backtick");
332 SV * const sv = newSV(79);
333 if (sv_gets(sv, fp, 0) == NULL) {
338 if (SvLEN(sv) - SvCUR(sv) > 20) {
339 SvPV_shrink_to_cur(sv);
344 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
345 TAINT; /* "I believe that this is not gratuitous!" */
348 STATUS_NATIVE_CHILD_SET(-1);
349 if (gimme == G_SCALAR)
360 GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs;
364 /* make a copy of the pattern if it is gmagical, to ensure that magic
365 * is called once and only once */
366 if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs));
368 tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL));
370 if (PL_op->op_flags & OPf_SPECIAL) {
371 /* call Perl-level glob function instead. Stack args are:
373 * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
382 /* Note that we only ever get here if File::Glob fails to load
383 * without at the same time croaking, for some reason, or if
384 * perl was built with PERL_EXTERNAL_GLOB */
386 ENTER_with_name("glob");
391 * The external globbing program may use things we can't control,
392 * so for security reasons we must assume the worst.
395 taint_proper(PL_no_security, "glob");
399 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
402 SAVESPTR(PL_rs); /* This is not permanent, either. */
403 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
406 *SvPVX(PL_rs) = '\n';
410 result = do_readline();
411 LEAVE_with_name("glob");
417 PL_last_in_gv = cGVOP_gv;
418 return do_readline();
428 do_join(TARG, &PL_sv_no, MARK, SP);
432 else if (SP == MARK) {
439 if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
442 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
443 /* well-formed exception supplied */
446 SV * const errsv = ERRSV;
449 if (SvGMAGICAL(errsv)) {
450 exsv = sv_newmortal();
451 sv_setsv_nomg(exsv, errsv);
455 else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) {
456 exsv = sv_newmortal();
457 sv_setsv_nomg(exsv, errsv);
458 sv_catpvs(exsv, "\t...caught");
461 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
464 if (SvROK(exsv) && !PL_warnhook)
465 Perl_warn(aTHX_ "%" SVf, SVfARG(exsv));
477 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
479 if (SP - MARK != 1) {
481 do_join(TARG, &PL_sv_no, MARK, SP);
489 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
490 /* well-formed exception supplied */
493 SV * const errsv = ERRSV;
497 if (sv_isobject(exsv)) {
498 HV * const stash = SvSTASH(SvRV(exsv));
499 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
501 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
502 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
509 call_sv(MUTABLE_SV(GvCV(gv)),
510 G_SCALAR|G_EVAL|G_KEEPERR);
511 exsv = sv_mortalcopy(*PL_stack_sp--);
515 else if (SvPOK(errsv) && SvCUR(errsv)) {
516 exsv = sv_mortalcopy(errsv);
517 sv_catpvs(exsv, "\t...propagated");
520 exsv = newSVpvs_flags("Died", SVs_TEMP);
524 NOT_REACHED; /* NOTREACHED */
525 return NULL; /* avoid missing return from non-void function warning */
531 Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv,
532 const MAGIC *const mg, const U32 flags, U32 argc, ...)
538 PERL_ARGS_ASSERT_TIED_METHOD;
540 /* Ensure that our flag bits do not overlap. */
541 STATIC_ASSERT_STMT((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
542 STATIC_ASSERT_STMT((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
543 STATIC_ASSERT_STMT((TIED_METHOD_SAY & G_WANT) == 0);
545 PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
546 PUSHSTACKi(PERLSI_MAGIC);
547 /* extend for object + args. If argc might wrap/truncate when cast
548 * to SSize_t and incremented, set to -1, which will trigger a panic in
550 * The weird way this is written is because g++ is dumb enough to
551 * warn "comparison is always false" on something like:
553 * sizeof(a) >= sizeof(b) && a >= B_t_MAX -1
555 * (where the LH condition is false)
558 (argc > (sizeof(argc) >= sizeof(SSize_t) ? SSize_t_MAX - 1 : argc))
559 ? -1 : (SSize_t)argc + 1;
560 EXTEND(SP, extend_size);
562 PUSHs(SvTIED_obj(sv, mg));
563 if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
564 Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
568 const U32 mortalize_not_needed
569 = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
571 va_start(args, argc);
573 SV *const arg = va_arg(args, SV *);
574 if(mortalize_not_needed)
583 ENTER_with_name("call_tied_method");
584 if (flags & TIED_METHOD_SAY) {
585 /* local $\ = "\n" */
586 SAVEGENERICSV(PL_ors_sv);
587 PL_ors_sv = newSVpvs("\n");
589 ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED);
594 if (ret_args) { /* copy results back to original stack */
595 EXTEND(sp, ret_args);
596 Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
600 LEAVE_with_name("call_tied_method");
604 #define tied_method0(a,b,c,d) \
605 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
606 #define tied_method1(a,b,c,d,e) \
607 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
608 #define tied_method2(a,b,c,d,e,f) \
609 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
622 GV * const gv = MUTABLE_GV(*++MARK);
624 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
625 DIE(aTHX_ PL_no_usym, "filehandle");
627 if ((io = GvIOp(gv))) {
629 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
632 Perl_croak(aTHX_ "Cannot open %" HEKf " as a filehandle: it is already open as a dirhandle",
633 HEKfARG(GvENAME_HEK(gv)));
635 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
637 /* Method's args are same as ours ... */
638 /* ... except handle is replaced by the object */
639 return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg,
640 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
652 tmps = SvPV_const(sv, len);
653 ok = do_open6(gv, tmps, len, NULL, MARK+1, (SP-MARK));
656 PUSHi( (I32)PL_forkprocess );
657 else if (PL_forkprocess == 0) /* we are a new child */
667 /* pp_coreargs pushes a NULL to indicate no args passed to
670 MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
676 IO * const io = GvIO(gv);
678 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
680 return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg);
684 PUSHs(boolSV(do_close(gv, TRUE)));
696 GV * const wgv = MUTABLE_GV(POPs);
697 GV * const rgv = MUTABLE_GV(POPs);
701 do_close(rgv, FALSE);
705 do_close(wgv, FALSE);
707 if (PerlProc_pipe(fd) < 0)
710 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r" PIPE_OPEN_MODE);
711 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w" PIPE_OPEN_MODE);
712 IoOFP(rstio) = IoIFP(rstio);
713 IoIFP(wstio) = IoOFP(wstio);
714 IoTYPE(rstio) = IoTYPE_RDONLY;
715 IoTYPE(wstio) = IoTYPE_WRONLY;
717 if (!IoIFP(rstio) || !IoOFP(wstio)) {
719 PerlIO_close(IoIFP(rstio));
721 PerlLIO_close(fd[0]);
723 PerlIO_close(IoOFP(wstio));
725 PerlLIO_close(fd[1]);
728 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
729 /* ensure close-on-exec */
730 if ((fd[0] > PL_maxsysfd && fcntl(fd[0], F_SETFD, FD_CLOEXEC) < 0) ||
731 (fd[1] > PL_maxsysfd && fcntl(fd[1], F_SETFD, FD_CLOEXEC) < 0))
739 DIE(aTHX_ PL_no_func, "pipe");
753 gv = MUTABLE_GV(POPs);
757 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
759 return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg);
762 if (io && IoDIRP(io)) {
763 #if defined(HAS_DIRFD) || defined(HAS_DIR_DD_FD)
764 PUSHi(my_dirfd(IoDIRP(io)));
766 #elif defined(ENOTSUP)
767 errno = ENOTSUP; /* Operation not supported */
769 #elif defined(EOPNOTSUPP)
770 errno = EOPNOTSUPP; /* Operation not supported on socket */
773 errno = EINVAL; /* Invalid argument */
778 if (!io || !(fp = IoIFP(io))) {
779 /* Can't do this because people seem to do things like
780 defined(fileno($foo)) to check whether $foo is a valid fh.
787 PUSHi(PerlIO_fileno(fp));
798 if (MAXARG < 1 || (!TOPs && !POPs)) {
799 anum = PerlLIO_umask(022);
800 /* setting it to 022 between the two calls to umask avoids
801 * to have a window where the umask is set to 0 -- meaning
802 * that another thread could create world-writeable files. */
804 (void)PerlLIO_umask(anum);
807 anum = PerlLIO_umask(POPi);
808 TAINT_PROPER("umask");
811 /* Only DIE if trying to restrict permissions on "user" (self).
812 * Otherwise it's harmless and more useful to just return undef
813 * since 'group' and 'other' concepts probably don't exist here. */
814 if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
815 DIE(aTHX_ "umask not implemented");
816 XPUSHs(&PL_sv_undef);
835 gv = MUTABLE_GV(POPs);
839 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
841 /* This takes advantage of the implementation of the varargs
842 function, which I don't think that the optimiser will be able to
843 figure out. Although, as it's a static function, in theory it
845 return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg,
846 G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
847 discp ? 1 : 0, discp);
851 if (!io || !(fp = IoIFP(io))) {
853 SETERRNO(EBADF,RMS_IFI);
860 const char *d = NULL;
863 d = SvPV_const(discp, len);
864 mode = mode_from_discipline(d, len);
865 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
866 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
867 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
888 const I32 markoff = MARK - PL_stack_base;
889 const char *methname;
890 int how = PERL_MAGIC_tied;
894 switch(SvTYPE(varsv)) {
898 methname = "TIEHASH";
899 if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
900 HvLAZYDEL_off(varsv);
901 hv_free_ent((HV *)varsv, entry);
903 HvEITER_set(MUTABLE_HV(varsv), 0);
907 methname = "TIEARRAY";
908 if (!AvREAL(varsv)) {
910 Perl_croak(aTHX_ "Cannot tie unreifiable array");
911 av_clear((AV *)varsv);
918 if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
919 methname = "TIEHANDLE";
920 how = PERL_MAGIC_tiedscalar;
921 /* For tied filehandles, we apply tiedscalar magic to the IO
922 slot of the GP rather than the GV itself. AMS 20010812 */
924 GvIOp(varsv) = newIO();
925 varsv = MUTABLE_SV(GvIOp(varsv));
928 if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
929 vivify_defelem(varsv);
930 varsv = LvTARG(varsv);
934 methname = "TIESCALAR";
935 how = PERL_MAGIC_tiedscalar;
939 if (sv_isobject(*MARK)) { /* Calls GET magic. */
940 ENTER_with_name("call_TIE");
941 PUSHSTACKi(PERLSI_MAGIC);
943 EXTEND(SP,(I32)items);
947 call_method(methname, G_SCALAR);
950 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
951 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
952 * wrong error message, and worse case, supreme action at a distance.
953 * (Sorry obfuscation writers. You're not going to be given this one.)
955 stash = gv_stashsv(*MARK, 0);
958 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"",
959 methname, SVfARG(*MARK));
960 else if (isGV(*MARK)) {
961 /* If the glob doesn't name an existing package, using
962 * SVfARG(*MARK) would yield "*Foo::Bar" or *main::Foo. So
963 * generate the name for the error message explicitly. */
964 SV *stashname = sv_2mortal(newSV(0));
965 gv_fullname4(stashname, (GV *) *MARK, NULL, FALSE);
966 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"",
967 methname, SVfARG(stashname));
970 SV *stashname = !SvPOK(*MARK) ? &PL_sv_no
971 : SvCUR(*MARK) ? *MARK
972 : sv_2mortal(newSVpvs("main"));
973 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\""
974 " (perhaps you forgot to load \"%" SVf "\"?)",
975 methname, SVfARG(stashname), SVfARG(stashname));
978 else if (!(gv = gv_fetchmethod(stash, methname))) {
979 /* The effective name can only be NULL for stashes that have
980 * been deleted from the symbol table, which this one can't
981 * be, since we just looked it up by name.
983 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" HEKf "\"",
984 methname, HvENAME_HEK_NN(stash));
986 ENTER_with_name("call_TIE");
987 PUSHSTACKi(PERLSI_MAGIC);
989 EXTEND(SP,(I32)items);
993 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
999 if (sv_isobject(sv)) {
1000 sv_unmagic(varsv, how);
1001 /* Croak if a self-tie on an aggregate is attempted. */
1002 if (varsv == SvRV(sv) &&
1003 (SvTYPE(varsv) == SVt_PVAV ||
1004 SvTYPE(varsv) == SVt_PVHV))
1006 "Self-ties of arrays and hashes are not supported");
1007 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
1009 LEAVE_with_name("call_TIE");
1010 SP = PL_stack_base + markoff;
1016 /* also used for: pp_dbmclose() */
1023 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1024 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1026 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1029 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1030 !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
1032 if ((mg = SvTIED_mg(sv, how))) {
1033 SV * const obj = SvRV(SvTIED_obj(sv, mg));
1035 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
1037 if (gv && isGV(gv) && (cv = GvCV(gv))) {
1039 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
1040 mXPUSHi(SvREFCNT(obj) - 1);
1042 ENTER_with_name("call_UNTIE");
1043 call_sv(MUTABLE_SV(cv), G_VOID);
1044 LEAVE_with_name("call_UNTIE");
1047 else if (mg && SvREFCNT(obj) > 1) {
1048 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
1049 "untie attempted while %" UVuf " inner references still exist",
1050 (UV)SvREFCNT(obj) - 1 ) ;
1054 sv_unmagic(sv, how) ;
1063 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1064 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1066 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1069 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1070 !(sv = defelem_target(sv, NULL))) goto ret_undef;
1072 if ((mg = SvTIED_mg(sv, how))) {
1073 SETs(SvTIED_obj(sv, mg));
1074 return NORMAL; /* PUTBACK not needed, pp_tied never moves SP */
1088 HV * const hv = MUTABLE_HV(POPs);
1089 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1090 stash = gv_stashsv(sv, 0);
1091 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1093 require_pv("AnyDBM_File.pm");
1095 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1096 DIE(aTHX_ "No dbm on this machine");
1106 mPUSHu(O_RDWR|O_CREAT);
1110 if (!SvOK(right)) right = &PL_sv_no;
1114 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1117 if (!sv_isobject(TOPs)) {
1125 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1127 if (sv_isobject(TOPs))
1132 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1133 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1150 struct timeval timebuf;
1151 struct timeval *tbuf = &timebuf;
1155 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1160 # if BYTEORDER & 0xf0000
1161 # define ORDERBYTE (0x88888888 - BYTEORDER)
1163 # define ORDERBYTE (0x4444 - BYTEORDER)
1169 for (i = 1; i <= 3; i++) {
1170 SV * const sv = svs[i] = SP[i];
1174 if (SvREADONLY(sv)) {
1175 if (!(SvPOK(sv) && SvCUR(sv) == 0))
1176 Perl_croak_no_modify();
1178 else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
1181 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1182 "Non-string passed as bitmask");
1183 if (SvGAMAGIC(sv)) {
1184 svs[i] = sv_newmortal();
1185 sv_copypv_nomg(svs[i], sv);
1188 SvPV_force_nomg_nolen(sv); /* force string conversion */
1195 /* little endians can use vecs directly */
1196 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1203 masksize = NFDBITS / NBBY;
1205 masksize = sizeof(long); /* documented int, everyone seems to use long */
1207 Zero(&fd_sets[0], 4, char*);
1210 # if SELECT_MIN_BITS == 1
1211 growsize = sizeof(fd_set);
1213 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1214 # undef SELECT_MIN_BITS
1215 # define SELECT_MIN_BITS __FD_SETSIZE
1217 /* If SELECT_MIN_BITS is greater than one we most probably will want
1218 * to align the sizes with SELECT_MIN_BITS/8 because for example
1219 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1220 * UNIX, Solaris, Darwin) the smallest quantum select() operates
1221 * on (sets/tests/clears bits) is 32 bits. */
1222 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1228 value = SvNV_nomg(sv);
1231 timebuf.tv_sec = (long)value;
1232 value -= (NV)timebuf.tv_sec;
1233 timebuf.tv_usec = (long)(value * 1000000.0);
1238 for (i = 1; i <= 3; i++) {
1240 if (!SvOK(sv) || SvCUR(sv) == 0) {
1247 Sv_Grow(sv, growsize);
1251 while (++j <= growsize) {
1255 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1257 Newx(fd_sets[i], growsize, char);
1258 for (offset = 0; offset < growsize; offset += masksize) {
1259 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1260 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1263 fd_sets[i] = SvPVX(sv);
1267 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1268 /* Can't make just the (void*) conditional because that would be
1269 * cpp #if within cpp macro, and not all compilers like that. */
1270 nfound = PerlSock_select(
1272 (Select_fd_set_t) fd_sets[1],
1273 (Select_fd_set_t) fd_sets[2],
1274 (Select_fd_set_t) fd_sets[3],
1275 (void*) tbuf); /* Workaround for compiler bug. */
1277 nfound = PerlSock_select(
1279 (Select_fd_set_t) fd_sets[1],
1280 (Select_fd_set_t) fd_sets[2],
1281 (Select_fd_set_t) fd_sets[3],
1284 for (i = 1; i <= 3; i++) {
1287 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1289 for (offset = 0; offset < growsize; offset += masksize) {
1290 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1291 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1293 Safefree(fd_sets[i]);
1296 SvSetMagicSV(SP[i], sv);
1303 if (GIMME_V == G_ARRAY && tbuf) {
1304 value = (NV)(timebuf.tv_sec) +
1305 (NV)(timebuf.tv_usec) / 1000000.0;
1310 DIE(aTHX_ "select not implemented");
1318 =for apidoc setdefout
1320 Sets C<PL_defoutgv>, the default file handle for output, to the passed in
1321 typeglob. As C<PL_defoutgv> "owns" a reference on its typeglob, the reference
1322 count of the passed in typeglob is increased by one, and the reference count
1323 of the typeglob that C<PL_defoutgv> points to is decreased by one.
1329 Perl_setdefout(pTHX_ GV *gv)
1331 GV *oldgv = PL_defoutgv;
1333 PERL_ARGS_ASSERT_SETDEFOUT;
1335 SvREFCNT_inc_simple_void_NN(gv);
1337 SvREFCNT_dec(oldgv);
1344 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1345 GV * egv = GvEGVx(PL_defoutgv);
1350 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1351 gvp = hv && HvENAME(hv)
1352 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1354 if (gvp && *gvp == egv) {
1355 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1359 mXPUSHs(newRV(MUTABLE_SV(egv)));
1363 if (!GvIO(newdefout))
1364 gv_IOadd(newdefout);
1365 setdefout(newdefout);
1374 /* pp_coreargs pushes a NULL to indicate no args passed to
1377 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1378 IO *const io = GvIO(gv);
1384 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1386 const U8 gimme = GIMME_V;
1387 Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1388 if (gimme == G_SCALAR) {
1390 SvSetMagicSV_nosteal(TARG, TOPs);
1395 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1396 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1398 SETERRNO(EBADF,RMS_IFI);
1402 sv_setpvs(TARG, " ");
1403 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1404 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1405 /* Find out how many bytes the char needs */
1406 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1409 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1410 SvCUR_set(TARG,1+len);
1414 else SvUTF8_off(TARG);
1420 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1423 const U8 gimme = GIMME_V;
1425 PERL_ARGS_ASSERT_DOFORM;
1428 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1430 cx = cx_pushblock(CXt_FORMAT, gimme, PL_stack_sp, PL_savestack_ix);
1431 cx_pushformat(cx, cv, retop, gv);
1432 if (CvDEPTH(cv) >= 2)
1433 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1434 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1436 setdefout(gv); /* locally select filehandle so $% et al work */
1453 gv = MUTABLE_GV(POPs);
1470 SV * const tmpsv = sv_newmortal();
1471 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1472 DIE(aTHX_ "Undefined format \"%" SVf "\" called", SVfARG(tmpsv));
1474 IoFLAGS(io) &= ~IOf_DIDTOP;
1475 RETURNOP(doform(cv,gv,PL_op->op_next));
1481 GV * const gv = CX_CUR()->blk_format.gv;
1482 IO * const io = GvIOp(gv);
1487 bool is_return = cBOOL(PL_op->op_type == OP_RETURN);
1489 if (is_return || !io || !(ofp = IoOFP(io)))
1492 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1493 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1495 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1496 PL_formtarget != PL_toptarget)
1500 if (!IoTOP_GV(io)) {
1503 if (!IoTOP_NAME(io)) {
1505 if (!IoFMT_NAME(io))
1506 IoFMT_NAME(io) = savepv(GvNAME(gv));
1507 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%" HEKf "_TOP",
1508 HEKfARG(GvNAME_HEK(gv))));
1509 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1510 if ((topgv && GvFORM(topgv)) ||
1511 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1512 IoTOP_NAME(io) = savesvpv(topname);
1514 IoTOP_NAME(io) = savepvs("top");
1516 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1517 if (!topgv || !GvFORM(topgv)) {
1518 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1521 IoTOP_GV(io) = topgv;
1523 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1524 I32 lines = IoLINES_LEFT(io);
1525 const char *s = SvPVX_const(PL_formtarget);
1526 if (lines <= 0) /* Yow, header didn't even fit!!! */
1528 while (lines-- > 0) {
1529 s = strchr(s, '\n');
1535 const STRLEN save = SvCUR(PL_formtarget);
1536 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1537 do_print(PL_formtarget, ofp);
1538 SvCUR_set(PL_formtarget, save);
1539 sv_chop(PL_formtarget, s);
1540 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1543 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1544 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1545 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1547 PL_formtarget = PL_toptarget;
1548 IoFLAGS(io) |= IOf_DIDTOP;
1550 assert(fgv); /* IoTOP_GV(io) should have been set above */
1553 SV * const sv = sv_newmortal();
1554 gv_efullname4(sv, fgv, NULL, FALSE);
1555 DIE(aTHX_ "Undefined top format \"%" SVf "\" called", SVfARG(sv));
1557 return doform(cv, gv, PL_op);
1562 assert(CxTYPE(cx) == CXt_FORMAT);
1563 SP = PL_stack_base + cx->blk_oldsp; /* ignore retval of formline */
1567 retop = cx->blk_sub.retop;
1573 /* XXX the semantics of doing 'return' in a format aren't documented.
1574 * Currently we ignore any args to 'return' and just return
1575 * a single undef in both scalar and list contexts
1577 PUSHs(&PL_sv_undef);
1578 else if (!io || !(fp = IoOFP(io))) {
1579 if (io && IoIFP(io))
1580 report_wrongway_fh(gv, '<');
1586 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1587 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1589 if (!do_print(PL_formtarget, fp))
1592 FmLINES(PL_formtarget) = 0;
1593 SvCUR_set(PL_formtarget, 0);
1594 *SvEND(PL_formtarget) = '\0';
1595 if (IoFLAGS(io) & IOf_FLUSH)
1596 (void)PerlIO_flush(fp);
1600 PL_formtarget = PL_bodytarget;
1606 dSP; dMARK; dORIGMARK;
1610 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1611 IO *const io = GvIO(gv);
1613 /* Treat empty list as "" */
1614 if (MARK == SP) XPUSHs(&PL_sv_no);
1617 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1619 if (MARK == ORIGMARK) {
1622 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1625 return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1627 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1634 SETERRNO(EBADF,RMS_IFI);
1637 else if (!(fp = IoOFP(io))) {
1639 report_wrongway_fh(gv, '<');
1640 else if (ckWARN(WARN_CLOSED))
1642 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1646 SV *sv = sv_newmortal();
1647 do_sprintf(sv, SP - MARK, MARK + 1);
1648 if (!do_print(sv, fp))
1651 if (IoFLAGS(io) & IOf_FLUSH)
1652 if (PerlIO_flush(fp) == EOF)
1661 PUSHs(&PL_sv_undef);
1668 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1669 const int mode = POPi;
1670 SV * const sv = POPs;
1671 GV * const gv = MUTABLE_GV(POPs);
1674 /* Need TIEHANDLE method ? */
1675 const char * const tmps = SvPV_const(sv, len);
1676 if (do_open_raw(gv, tmps, len, mode, perm, NULL)) {
1677 IoLINES(GvIOp(gv)) = 0;
1681 PUSHs(&PL_sv_undef);
1687 /* also used for: pp_read() and pp_recv() (where supported) */
1691 dSP; dMARK; dORIGMARK; dTARGET;
1705 bool charstart = FALSE;
1706 STRLEN charskip = 0;
1708 GV * const gv = MUTABLE_GV(*++MARK);
1711 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1712 && gv && (io = GvIO(gv)) )
1714 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1716 return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1717 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1727 length = SvIVx(*++MARK);
1729 DIE(aTHX_ "Negative length");
1732 offset = SvIVx(*++MARK);
1736 if (!io || !IoIFP(io)) {
1738 SETERRNO(EBADF,RMS_IFI);
1742 /* Note that fd can here validly be -1, don't check it yet. */
1743 fd = PerlIO_fileno(IoIFP(io));
1745 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1746 if (PL_op->op_type == OP_SYSREAD || PL_op->op_type == OP_RECV) {
1747 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1748 "%s() is deprecated on :utf8 handles. "
1749 "This will be a fatal error in Perl 5.30",
1752 buffer = SvPVutf8_force(bufsv, blen);
1753 /* UTF-8 may not have been set if they are all low bytes */
1758 buffer = SvPV_force(bufsv, blen);
1759 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1761 if (DO_UTF8(bufsv)) {
1762 blen = sv_len_utf8_nomg(bufsv);
1771 if (PL_op->op_type == OP_RECV) {
1772 Sock_size_t bufsize;
1773 char namebuf[MAXPATHLEN];
1775 SETERRNO(EBADF,SS_IVCHAN);
1778 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1779 bufsize = sizeof (struct sockaddr_in);
1781 bufsize = sizeof namebuf;
1783 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1787 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1788 /* 'offset' means 'flags' here */
1789 count = PerlSock_recvfrom(fd, buffer, length, offset,
1790 (struct sockaddr *)namebuf, &bufsize);
1793 /* MSG_TRUNC can give oversized count; quietly lose it */
1796 SvCUR_set(bufsv, count);
1797 *SvEND(bufsv) = '\0';
1798 (void)SvPOK_only(bufsv);
1802 /* This should not be marked tainted if the fp is marked clean */
1803 if (!(IoFLAGS(io) & IOf_UNTAINT))
1804 SvTAINTED_on(bufsv);
1806 #if defined(__CYGWIN__)
1807 /* recvfrom() on cygwin doesn't set bufsize at all for
1808 connected sockets, leaving us with trash in the returned
1809 name, so use the same test as the Win32 code to check if it
1810 wasn't set, and set it [perl #118843] */
1811 if (bufsize == sizeof namebuf)
1814 sv_setpvn(TARG, namebuf, bufsize);
1820 if (-offset > (SSize_t)blen)
1821 DIE(aTHX_ "Offset outside string");
1824 if (DO_UTF8(bufsv)) {
1825 /* convert offset-as-chars to offset-as-bytes */
1826 if (offset >= (SSize_t)blen)
1827 offset += SvCUR(bufsv) - blen;
1829 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1833 /* Reestablish the fd in case it shifted from underneath us. */
1834 fd = PerlIO_fileno(IoIFP(io));
1836 orig_size = SvCUR(bufsv);
1837 /* Allocating length + offset + 1 isn't perfect in the case of reading
1838 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1840 (should be 2 * length + offset + 1, or possibly something longer if
1841 IN_ENCODING Is true) */
1842 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1843 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1844 Zero(buffer+orig_size, offset-orig_size, char);
1846 buffer = buffer + offset;
1848 read_target = bufsv;
1850 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1851 concatenate it to the current buffer. */
1853 /* Truncate the existing buffer to the start of where we will be
1855 SvCUR_set(bufsv, offset);
1857 read_target = sv_newmortal();
1858 SvUPGRADE(read_target, SVt_PV);
1859 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1862 if (PL_op->op_type == OP_SYSREAD) {
1863 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1864 if (IoTYPE(io) == IoTYPE_SOCKET) {
1866 SETERRNO(EBADF,SS_IVCHAN);
1870 count = PerlSock_recv(fd, buffer, length, 0);
1876 SETERRNO(EBADF,RMS_IFI);
1880 count = PerlLIO_read(fd, buffer, length);
1885 count = PerlIO_read(IoIFP(io), buffer, length);
1886 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1887 if (count == 0 && PerlIO_error(IoIFP(io)))
1891 if (IoTYPE(io) == IoTYPE_WRONLY)
1892 report_wrongway_fh(gv, '>');
1895 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1896 *SvEND(read_target) = '\0';
1897 (void)SvPOK_only(read_target);
1898 if (fp_utf8 && !IN_BYTES) {
1899 /* Look at utf8 we got back and count the characters */
1900 const char *bend = buffer + count;
1901 while (buffer < bend) {
1903 skip = UTF8SKIP(buffer);
1906 if (buffer - charskip + skip > bend) {
1907 /* partial character - try for rest of it */
1908 length = skip - (bend-buffer);
1909 offset = bend - SvPVX_const(bufsv);
1921 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1922 provided amount read (count) was what was requested (length)
1924 if (got < wanted && count == length) {
1925 length = wanted - got;
1926 offset = bend - SvPVX_const(bufsv);
1929 /* return value is character count */
1933 else if (buffer_utf8) {
1934 /* Let svcatsv upgrade the bytes we read in to utf8.
1935 The buffer is a mortal so will be freed soon. */
1936 sv_catsv_nomg(bufsv, read_target);
1939 /* This should not be marked tainted if the fp is marked clean */
1940 if (!(IoFLAGS(io) & IOf_UNTAINT))
1941 SvTAINTED_on(bufsv);
1952 /* also used for: pp_send() where defined */
1956 dSP; dMARK; dORIGMARK; dTARGET;
1961 STRLEN orig_blen_bytes;
1962 const int op_type = PL_op->op_type;
1965 GV *const gv = MUTABLE_GV(*++MARK);
1966 IO *const io = GvIO(gv);
1969 if (op_type == OP_SYSWRITE && io) {
1970 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1972 if (MARK == SP - 1) {
1974 mXPUSHi(sv_len(sv));
1978 return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1979 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1989 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1991 if (io && IoIFP(io))
1992 report_wrongway_fh(gv, '<');
1995 SETERRNO(EBADF,RMS_IFI);
1998 fd = PerlIO_fileno(IoIFP(io));
2000 SETERRNO(EBADF,SS_IVCHAN);
2005 /* Do this first to trigger any overloading. */
2006 buffer = SvPV_const(bufsv, blen);
2007 orig_blen_bytes = blen;
2008 doing_utf8 = DO_UTF8(bufsv);
2010 if (PerlIO_isutf8(IoIFP(io))) {
2011 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
2012 "%s() is deprecated on :utf8 handles. "
2013 "This will be a fatal error in Perl 5.30",
2015 if (!SvUTF8(bufsv)) {
2016 /* We don't modify the original scalar. */
2017 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
2018 buffer = (char *) tmpbuf;
2022 else if (doing_utf8) {
2023 STRLEN tmplen = blen;
2024 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
2027 buffer = (char *) tmpbuf;
2031 assert((char *)result == buffer);
2032 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
2037 if (op_type == OP_SEND) {
2038 const int flags = SvIVx(*++MARK);
2041 char * const sockbuf = SvPVx(*++MARK, mlen);
2042 retval = PerlSock_sendto(fd, buffer, blen,
2043 flags, (struct sockaddr *)sockbuf, mlen);
2046 retval = PerlSock_send(fd, buffer, blen, flags);
2052 Size_t length = 0; /* This length is in characters. */
2058 /* The SV is bytes, and we've had to upgrade it. */
2059 blen_chars = orig_blen_bytes;
2061 /* The SV really is UTF-8. */
2062 /* Don't call sv_len_utf8 on a magical or overloaded
2063 scalar, as we might get back a different result. */
2064 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
2071 length = blen_chars;
2073 #if Size_t_size > IVSIZE
2074 length = (Size_t)SvNVx(*++MARK);
2076 length = (Size_t)SvIVx(*++MARK);
2078 if ((SSize_t)length < 0) {
2080 DIE(aTHX_ "Negative length");
2085 offset = SvIVx(*++MARK);
2087 if (-offset > (IV)blen_chars) {
2089 DIE(aTHX_ "Offset outside string");
2091 offset += blen_chars;
2092 } else if (offset > (IV)blen_chars) {
2094 DIE(aTHX_ "Offset outside string");
2098 if (length > blen_chars - offset)
2099 length = blen_chars - offset;
2101 /* Here we convert length from characters to bytes. */
2102 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
2103 /* Either we had to convert the SV, or the SV is magical, or
2104 the SV has overloading, in which case we can't or mustn't
2105 or mustn't call it again. */
2107 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
2108 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
2110 /* It's a real UTF-8 SV, and it's not going to change under
2111 us. Take advantage of any cache. */
2113 I32 len_I32 = length;
2115 /* Convert the start and end character positions to bytes.
2116 Remember that the second argument to sv_pos_u2b is relative
2118 sv_pos_u2b(bufsv, &start, &len_I32);
2125 buffer = buffer+offset;
2127 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2128 if (IoTYPE(io) == IoTYPE_SOCKET) {
2129 retval = PerlSock_send(fd, buffer, length, 0);
2134 /* See the note at doio.c:do_print about filesize limits. --jhi */
2135 retval = PerlLIO_write(fd, buffer, length);
2143 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2146 #if Size_t_size > IVSIZE
2166 * in Perl 5.12 and later, the additional parameter is a bitmask:
2169 * 2 = eof() <- ARGV magic
2171 * I'll rely on the compiler's trace flow analysis to decide whether to
2172 * actually assign this out here, or punt it into the only block where it is
2173 * used. Doing it out here is DRY on the condition logic.
2178 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2184 if (PL_op->op_flags & OPf_SPECIAL) {
2185 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2189 gv = PL_last_in_gv; /* eof */
2197 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2198 return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2201 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2202 if (io && !IoIFP(io)) {
2203 if ((IoFLAGS(io) & IOf_START) && av_tindex(GvAVn(gv)) < 0) {
2206 IoFLAGS(io) &= ~IOf_START;
2207 do_open6(gv, "-", 1, NULL, NULL, 0);
2215 *svp = newSVpvs("-");
2217 else if (!nextargv(gv, FALSE))
2222 PUSHs(boolSV(do_eof(gv)));
2232 if (MAXARG != 0 && (TOPs || POPs))
2233 PL_last_in_gv = MUTABLE_GV(POPs);
2240 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2242 return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2247 SETERRNO(EBADF,RMS_IFI);
2252 #if LSEEKSIZE > IVSIZE
2253 PUSHn( do_tell(gv) );
2255 PUSHi( do_tell(gv) );
2261 /* also used for: pp_seek() */
2266 const int whence = POPi;
2267 #if LSEEKSIZE > IVSIZE
2268 const Off_t offset = (Off_t)SvNVx(POPs);
2270 const Off_t offset = (Off_t)SvIVx(POPs);
2273 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2274 IO *const io = GvIO(gv);
2277 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2279 #if LSEEKSIZE > IVSIZE
2280 SV *const offset_sv = newSVnv((NV) offset);
2282 SV *const offset_sv = newSViv(offset);
2285 return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2290 if (PL_op->op_type == OP_SEEK)
2291 PUSHs(boolSV(do_seek(gv, offset, whence)));
2293 const Off_t sought = do_sysseek(gv, offset, whence);
2295 PUSHs(&PL_sv_undef);
2297 SV* const sv = sought ?
2298 #if LSEEKSIZE > IVSIZE
2303 : newSVpvn(zero_but_true, ZBTLEN);
2313 /* There seems to be no consensus on the length type of truncate()
2314 * and ftruncate(), both off_t and size_t have supporters. In
2315 * general one would think that when using large files, off_t is
2316 * at least as wide as size_t, so using an off_t should be okay. */
2317 /* XXX Configure probe for the length type of *truncate() needed XXX */
2320 #if Off_t_size > IVSIZE
2325 /* Checking for length < 0 is problematic as the type might or
2326 * might not be signed: if it is not, clever compilers will moan. */
2327 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2330 SV * const sv = POPs;
2335 if (PL_op->op_flags & OPf_SPECIAL
2336 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2337 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2344 TAINT_PROPER("truncate");
2345 if (!(fp = IoIFP(io))) {
2349 int fd = PerlIO_fileno(fp);
2351 SETERRNO(EBADF,RMS_IFI);
2355 SETERRNO(EINVAL, LIB_INVARG);
2360 if (ftruncate(fd, len) < 0)
2362 if (my_chsize(fd, len) < 0)
2370 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2371 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2372 goto do_ftruncate_io;
2375 const char * const name = SvPV_nomg_const_nolen(sv);
2376 TAINT_PROPER("truncate");
2378 if (truncate(name, len) < 0)
2385 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
2386 mode |= O_LARGEFILE; /* Transparently largefiley. */
2389 /* On open(), the Win32 CRT tries to seek around text
2390 * files using 32-bit offsets, which causes the open()
2391 * to fail on large files, so open in binary mode.
2395 tmpfd = PerlLIO_open(name, mode);
2400 if (my_chsize(tmpfd, len) < 0)
2402 PerlLIO_close(tmpfd);
2411 SETERRNO(EBADF,RMS_IFI);
2417 /* also used for: pp_fcntl() */
2422 SV * const argsv = POPs;
2423 const unsigned int func = POPu;
2425 GV * const gv = MUTABLE_GV(POPs);
2426 IO * const io = GvIOn(gv);
2432 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2436 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2439 s = SvPV_force(argsv, len);
2440 need = IOCPARM_LEN(func);
2442 s = Sv_Grow(argsv, need + 1);
2443 SvCUR_set(argsv, need);
2446 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2449 retval = SvIV(argsv);
2450 s = INT2PTR(char*,retval); /* ouch */
2453 optype = PL_op->op_type;
2454 TAINT_PROPER(PL_op_desc[optype]);
2456 if (optype == OP_IOCTL)
2458 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2460 DIE(aTHX_ "ioctl is not implemented");
2464 DIE(aTHX_ "fcntl is not implemented");
2466 #if defined(OS2) && defined(__EMX__)
2467 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2469 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2473 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2475 if (s[SvCUR(argsv)] != 17)
2476 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2478 s[SvCUR(argsv)] = 0; /* put our null back */
2479 SvSETMAGIC(argsv); /* Assume it has changed */
2488 PUSHp(zero_but_true, ZBTLEN);
2499 const int argtype = POPi;
2500 GV * const gv = MUTABLE_GV(POPs);
2501 IO *const io = GvIO(gv);
2502 PerlIO *const fp = io ? IoIFP(io) : NULL;
2504 /* XXX Looks to me like io is always NULL at this point */
2506 (void)PerlIO_flush(fp);
2507 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2512 SETERRNO(EBADF,RMS_IFI);
2517 DIE(aTHX_ PL_no_func, "flock");
2528 const int protocol = POPi;
2529 const int type = POPi;
2530 const int domain = POPi;
2531 GV * const gv = MUTABLE_GV(POPs);
2532 IO * const io = GvIOn(gv);
2536 do_close(gv, FALSE);
2538 TAINT_PROPER("socket");
2539 fd = PerlSock_socket(domain, type, protocol);
2543 IoIFP(io) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2544 IoOFP(io) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE);
2545 IoTYPE(io) = IoTYPE_SOCKET;
2546 if (!IoIFP(io) || !IoOFP(io)) {
2547 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2548 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2549 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2552 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2553 /* ensure close-on-exec */
2554 if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0)
2564 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2567 const int protocol = POPi;
2568 const int type = POPi;
2569 const int domain = POPi;
2571 GV * const gv2 = MUTABLE_GV(POPs);
2572 IO * const io2 = GvIOn(gv2);
2573 GV * const gv1 = MUTABLE_GV(POPs);
2574 IO * const io1 = GvIOn(gv1);
2577 do_close(gv1, FALSE);
2579 do_close(gv2, FALSE);
2581 TAINT_PROPER("socketpair");
2582 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2584 IoIFP(io1) = PerlIO_fdopen(fd[0], "r" SOCKET_OPEN_MODE);
2585 IoOFP(io1) = PerlIO_fdopen(fd[0], "w" SOCKET_OPEN_MODE);
2586 IoTYPE(io1) = IoTYPE_SOCKET;
2587 IoIFP(io2) = PerlIO_fdopen(fd[1], "r" SOCKET_OPEN_MODE);
2588 IoOFP(io2) = PerlIO_fdopen(fd[1], "w" SOCKET_OPEN_MODE);
2589 IoTYPE(io2) = IoTYPE_SOCKET;
2590 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2591 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2592 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2593 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2594 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2595 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2596 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2599 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2600 /* ensure close-on-exec */
2601 if ((fd[0] > PL_maxsysfd && fcntl(fd[0], F_SETFD, FD_CLOEXEC) < 0) ||
2602 (fd[1] > PL_maxsysfd && fcntl(fd[1], F_SETFD, FD_CLOEXEC) < 0))
2608 DIE(aTHX_ PL_no_sock_func, "socketpair");
2614 /* also used for: pp_connect() */
2619 SV * const addrsv = POPs;
2620 /* OK, so on what platform does bind modify addr? */
2622 GV * const gv = MUTABLE_GV(POPs);
2623 IO * const io = GvIOn(gv);
2630 fd = PerlIO_fileno(IoIFP(io));
2634 addr = SvPV_const(addrsv, len);
2635 op_type = PL_op->op_type;
2636 TAINT_PROPER(PL_op_desc[op_type]);
2637 if ((op_type == OP_BIND
2638 ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
2639 : PerlSock_connect(fd, (struct sockaddr *)addr, len))
2647 SETERRNO(EBADF,SS_IVCHAN);
2654 const int backlog = POPi;
2655 GV * const gv = MUTABLE_GV(POPs);
2656 IO * const io = GvIOn(gv);
2661 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2668 SETERRNO(EBADF,SS_IVCHAN);
2676 char namebuf[MAXPATHLEN];
2677 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2678 Sock_size_t len = sizeof (struct sockaddr_in);
2680 Sock_size_t len = sizeof namebuf;
2682 GV * const ggv = MUTABLE_GV(POPs);
2683 GV * const ngv = MUTABLE_GV(POPs);
2686 IO * const gstio = GvIO(ggv);
2687 if (!gstio || !IoIFP(gstio))
2691 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2694 /* Some platforms indicate zero length when an AF_UNIX client is
2695 * not bound. Simulate a non-zero-length sockaddr structure in
2697 namebuf[0] = 0; /* sun_len */
2698 namebuf[1] = AF_UNIX; /* sun_family */
2706 do_close(ngv, FALSE);
2707 IoIFP(nstio) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE);
2708 IoOFP(nstio) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE);
2709 IoTYPE(nstio) = IoTYPE_SOCKET;
2710 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2711 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2712 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2713 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2716 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2717 /* ensure close-on-exec */
2718 if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0)
2722 #ifdef __SCO_VERSION__
2723 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2726 PUSHp(namebuf, len);
2730 report_evil_fh(ggv);
2731 SETERRNO(EBADF,SS_IVCHAN);
2741 const int how = POPi;
2742 GV * const gv = MUTABLE_GV(POPs);
2743 IO * const io = GvIOn(gv);
2748 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2753 SETERRNO(EBADF,SS_IVCHAN);
2758 /* also used for: pp_gsockopt() */
2763 const int optype = PL_op->op_type;
2764 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2765 const unsigned int optname = (unsigned int) POPi;
2766 const unsigned int lvl = (unsigned int) POPi;
2767 GV * const gv = MUTABLE_GV(POPs);
2768 IO * const io = GvIOn(gv);
2775 fd = PerlIO_fileno(IoIFP(io));
2781 (void)SvPOK_only(sv);
2785 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2788 /* XXX Configure test: does getsockopt set the length properly? */
2797 #if defined(__SYMBIAN32__)
2798 # define SETSOCKOPT_OPTION_VALUE_T void *
2800 # define SETSOCKOPT_OPTION_VALUE_T const char *
2802 /* XXX TODO: We need to have a proper type (a Configure probe,
2803 * etc.) for what the C headers think of the third argument of
2804 * setsockopt(), the option_value read-only buffer: is it
2805 * a "char *", or a "void *", const or not. Some compilers
2806 * don't take kindly to e.g. assuming that "char *" implicitly
2807 * promotes to a "void *", or to explicitly promoting/demoting
2808 * consts to non/vice versa. The "const void *" is the SUS
2809 * definition, but that does not fly everywhere for the above
2811 SETSOCKOPT_OPTION_VALUE_T buf;
2815 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2819 aint = (int)SvIV(sv);
2820 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2823 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2833 SETERRNO(EBADF,SS_IVCHAN);
2840 /* also used for: pp_getsockname() */
2845 const int optype = PL_op->op_type;
2846 GV * const gv = MUTABLE_GV(POPs);
2847 IO * const io = GvIOn(gv);
2855 sv = sv_2mortal(newSV(257));
2856 (void)SvPOK_only(sv);
2860 fd = PerlIO_fileno(IoIFP(io));
2864 case OP_GETSOCKNAME:
2865 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2868 case OP_GETPEERNAME:
2869 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2871 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2873 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";
2874 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2875 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2876 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2877 sizeof(u_short) + sizeof(struct in_addr))) {
2884 #ifdef BOGUS_GETNAME_RETURN
2885 /* Interactive Unix, getpeername() and getsockname()
2886 does not return valid namelen */
2887 if (len == BOGUS_GETNAME_RETURN)
2888 len = sizeof(struct sockaddr);
2897 SETERRNO(EBADF,SS_IVCHAN);
2906 /* also used for: pp_lstat() */
2917 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2918 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2919 if (PL_op->op_type == OP_LSTAT) {
2920 if (gv != PL_defgv) {
2921 do_fstat_warning_check:
2922 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2923 "lstat() on filehandle%s%" SVf,
2926 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2928 } else if (PL_laststype != OP_LSTAT)
2929 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2930 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2933 if (gv != PL_defgv) {
2937 PL_laststype = OP_STAT;
2938 PL_statgv = gv ? gv : (GV *)io;
2939 SvPVCLEAR(PL_statname);
2945 int fd = PerlIO_fileno(IoIFP(io));
2947 PL_laststatval = -1;
2948 SETERRNO(EBADF,RMS_IFI);
2950 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
2953 } else if (IoDIRP(io)) {
2955 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2958 PL_laststatval = -1;
2961 else PL_laststatval = -1;
2962 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2965 if (PL_laststatval < 0) {
2971 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2972 io = MUTABLE_IO(SvRV(sv));
2973 if (PL_op->op_type == OP_LSTAT)
2974 goto do_fstat_warning_check;
2975 goto do_fstat_have_io;
2978 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2979 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2981 PL_laststype = PL_op->op_type;
2982 file = SvPV_nolen_const(PL_statname);
2983 if (PL_op->op_type == OP_LSTAT)
2984 PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
2986 PL_laststatval = PerlLIO_stat(file, &PL_statcache);
2987 if (PL_laststatval < 0) {
2988 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
2989 /* PL_warn_nl is constant */
2990 GCC_DIAG_IGNORE(-Wformat-nonliteral);
2991 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2999 if (gimme != G_ARRAY) {
3000 if (gimme != G_VOID)
3001 XPUSHs(boolSV(max));
3007 mPUSHi(PL_statcache.st_dev);
3008 #if ST_INO_SIZE > IVSIZE
3009 mPUSHn(PL_statcache.st_ino);
3011 # if ST_INO_SIGN <= 0
3012 mPUSHi(PL_statcache.st_ino);
3014 mPUSHu(PL_statcache.st_ino);
3017 mPUSHu(PL_statcache.st_mode);
3018 mPUSHu(PL_statcache.st_nlink);
3020 sv_setuid(PUSHmortal, PL_statcache.st_uid);
3021 sv_setgid(PUSHmortal, PL_statcache.st_gid);
3023 #ifdef USE_STAT_RDEV
3024 mPUSHi(PL_statcache.st_rdev);
3026 PUSHs(newSVpvs_flags("", SVs_TEMP));
3028 #if Off_t_size > IVSIZE
3029 mPUSHn(PL_statcache.st_size);
3031 mPUSHi(PL_statcache.st_size);
3034 mPUSHn(PL_statcache.st_atime);
3035 mPUSHn(PL_statcache.st_mtime);
3036 mPUSHn(PL_statcache.st_ctime);
3038 mPUSHi(PL_statcache.st_atime);
3039 mPUSHi(PL_statcache.st_mtime);
3040 mPUSHi(PL_statcache.st_ctime);
3042 #ifdef USE_STAT_BLOCKS
3043 mPUSHu(PL_statcache.st_blksize);
3044 mPUSHu(PL_statcache.st_blocks);
3046 PUSHs(newSVpvs_flags("", SVs_TEMP));
3047 PUSHs(newSVpvs_flags("", SVs_TEMP));
3053 /* All filetest ops avoid manipulating the perl stack pointer in their main
3054 bodies (since commit d2c4d2d1e22d3125), and return using either
3055 S_ft_return_false() or S_ft_return_true(). These two helper functions are
3056 the only two which manipulate the perl stack. To ensure that no stack
3057 manipulation macros are used, the filetest ops avoid defining a local copy
3058 of the stack pointer with dSP. */
3060 /* If the next filetest is stacked up with this one
3061 (PL_op->op_private & OPpFT_STACKING), we leave
3062 the original argument on the stack for success,
3063 and skip the stacked operators on failure.
3064 The next few macros/functions take care of this.
3068 S_ft_return_false(pTHX_ SV *ret) {
3072 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
3076 if (PL_op->op_private & OPpFT_STACKING) {
3077 while (OP_IS_FILETEST(next->op_type)
3078 && next->op_private & OPpFT_STACKED)
3079 next = next->op_next;
3084 PERL_STATIC_INLINE OP *
3085 S_ft_return_true(pTHX_ SV *ret) {
3087 if (PL_op->op_flags & OPf_REF)
3088 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
3089 else if (!(PL_op->op_private & OPpFT_STACKING))
3095 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
3096 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
3097 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
3099 #define tryAMAGICftest_MG(chr) STMT_START { \
3100 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
3101 && PL_op->op_flags & OPf_KIDS) { \
3102 OP *next = S_try_amagic_ftest(aTHX_ chr); \
3103 if (next) return next; \
3108 S_try_amagic_ftest(pTHX_ char chr) {
3109 SV *const arg = *PL_stack_sp;
3112 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
3116 const char tmpchr = chr;
3117 SV * const tmpsv = amagic_call(arg,
3118 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
3119 ftest_amg, AMGf_unary);
3124 return SvTRUE(tmpsv)
3125 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
3131 /* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec()
3137 /* Not const, because things tweak this below. Not bool, because there's
3138 no guarantee that OPpFT_ACCESS is <= CHAR_MAX */
3139 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3140 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3141 /* Giving some sort of initial value silences compilers. */
3143 int access_mode = R_OK;
3145 int access_mode = 0;
3148 /* access_mode is never used, but leaving use_access in makes the
3149 conditional compiling below much clearer. */
3152 Mode_t stat_mode = S_IRUSR;
3154 bool effective = FALSE;
3157 switch (PL_op->op_type) {
3158 case OP_FTRREAD: opchar = 'R'; break;
3159 case OP_FTRWRITE: opchar = 'W'; break;
3160 case OP_FTREXEC: opchar = 'X'; break;
3161 case OP_FTEREAD: opchar = 'r'; break;
3162 case OP_FTEWRITE: opchar = 'w'; break;
3163 case OP_FTEEXEC: opchar = 'x'; break;
3165 tryAMAGICftest_MG(opchar);
3167 switch (PL_op->op_type) {
3169 #if !(defined(HAS_ACCESS) && defined(R_OK))
3175 #if defined(HAS_ACCESS) && defined(W_OK)
3180 stat_mode = S_IWUSR;
3184 #if defined(HAS_ACCESS) && defined(X_OK)
3189 stat_mode = S_IXUSR;
3193 #ifdef PERL_EFF_ACCESS
3196 stat_mode = S_IWUSR;
3200 #ifndef PERL_EFF_ACCESS
3207 #ifdef PERL_EFF_ACCESS
3212 stat_mode = S_IXUSR;
3218 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3219 const char *name = SvPV_nolen(*PL_stack_sp);
3221 # ifdef PERL_EFF_ACCESS
3222 result = PERL_EFF_ACCESS(name, access_mode);
3224 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3230 result = access(name, access_mode);
3232 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3243 result = my_stat_flags(0);
3246 if (cando(stat_mode, effective, &PL_statcache))
3252 /* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */
3257 const int op_type = PL_op->op_type;
3261 case OP_FTIS: opchar = 'e'; break;
3262 case OP_FTSIZE: opchar = 's'; break;
3263 case OP_FTMTIME: opchar = 'M'; break;
3264 case OP_FTCTIME: opchar = 'C'; break;
3265 case OP_FTATIME: opchar = 'A'; break;
3267 tryAMAGICftest_MG(opchar);
3269 result = my_stat_flags(0);
3272 if (op_type == OP_FTIS)
3275 /* You can't dTARGET inside OP_FTIS, because you'll get
3276 "panic: pad_sv po" - the op is not flagged to have a target. */
3280 #if Off_t_size > IVSIZE
3281 sv_setnv(TARG, (NV)PL_statcache.st_size);
3283 sv_setiv(TARG, (IV)PL_statcache.st_size);
3288 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3292 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3296 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3300 return SvTRUE_nomg_NN(TARG)
3301 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3306 /* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned()
3307 * pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock()
3308 * pp_ftsuid() pp_ftsvtx() pp_ftzero() */
3315 switch (PL_op->op_type) {
3316 case OP_FTROWNED: opchar = 'O'; break;
3317 case OP_FTEOWNED: opchar = 'o'; break;
3318 case OP_FTZERO: opchar = 'z'; break;
3319 case OP_FTSOCK: opchar = 'S'; break;
3320 case OP_FTCHR: opchar = 'c'; break;
3321 case OP_FTBLK: opchar = 'b'; break;
3322 case OP_FTFILE: opchar = 'f'; break;
3323 case OP_FTDIR: opchar = 'd'; break;
3324 case OP_FTPIPE: opchar = 'p'; break;
3325 case OP_FTSUID: opchar = 'u'; break;
3326 case OP_FTSGID: opchar = 'g'; break;
3327 case OP_FTSVTX: opchar = 'k'; break;
3329 tryAMAGICftest_MG(opchar);
3331 /* I believe that all these three are likely to be defined on most every
3332 system these days. */
3334 if(PL_op->op_type == OP_FTSUID) {
3339 if(PL_op->op_type == OP_FTSGID) {
3344 if(PL_op->op_type == OP_FTSVTX) {
3349 result = my_stat_flags(0);
3352 switch (PL_op->op_type) {
3354 if (PL_statcache.st_uid == PerlProc_getuid())
3358 if (PL_statcache.st_uid == PerlProc_geteuid())
3362 if (PL_statcache.st_size == 0)
3366 if (S_ISSOCK(PL_statcache.st_mode))
3370 if (S_ISCHR(PL_statcache.st_mode))
3374 if (S_ISBLK(PL_statcache.st_mode))
3378 if (S_ISREG(PL_statcache.st_mode))
3382 if (S_ISDIR(PL_statcache.st_mode))
3386 if (S_ISFIFO(PL_statcache.st_mode))
3391 if (PL_statcache.st_mode & S_ISUID)
3397 if (PL_statcache.st_mode & S_ISGID)
3403 if (PL_statcache.st_mode & S_ISVTX)
3415 tryAMAGICftest_MG('l');
3416 result = my_lstat_flags(0);
3420 if (S_ISLNK(PL_statcache.st_mode))
3433 tryAMAGICftest_MG('t');
3435 if (PL_op->op_flags & OPf_REF)
3438 SV *tmpsv = *PL_stack_sp;
3439 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3440 name = SvPV_nomg(tmpsv, namelen);
3441 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3445 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3446 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3447 else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX)
3452 SETERRNO(EBADF,RMS_IFI);
3455 if (PerlLIO_isatty(fd))
3461 /* also used for: pp_ftbinary() */
3475 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3477 if (PL_op->op_flags & OPf_REF)
3479 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3484 gv = MAYBE_DEREF_GV_nomg(sv);
3488 if (gv == PL_defgv) {
3490 io = SvTYPE(PL_statgv) == SVt_PVIO
3494 goto really_filename;
3499 SvPVCLEAR(PL_statname);
3500 io = GvIO(PL_statgv);
3502 PL_laststatval = -1;
3503 PL_laststype = OP_STAT;
3504 if (io && IoIFP(io)) {
3506 if (! PerlIO_has_base(IoIFP(io)))
3507 DIE(aTHX_ "-T and -B not implemented on filehandles");
3508 fd = PerlIO_fileno(IoIFP(io));
3510 SETERRNO(EBADF,RMS_IFI);
3513 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3514 if (PL_laststatval < 0)
3516 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3517 if (PL_op->op_type == OP_FTTEXT)
3522 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3523 i = PerlIO_getc(IoIFP(io));
3525 (void)PerlIO_ungetc(IoIFP(io),i);
3527 /* null file is anything */
3530 len = PerlIO_get_bufsiz(IoIFP(io));
3531 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3532 /* sfio can have large buffers - limit to 512 */
3537 SETERRNO(EBADF,RMS_IFI);
3539 SETERRNO(EBADF,RMS_IFI);
3548 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3550 file = SvPVX_const(PL_statname);
3552 if (!(fp = PerlIO_open(file, "r"))) {
3554 PL_laststatval = -1;
3555 PL_laststype = OP_STAT;
3557 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
3558 /* PL_warn_nl is constant */
3559 GCC_DIAG_IGNORE(-Wformat-nonliteral);
3560 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3565 PL_laststype = OP_STAT;
3566 fd = PerlIO_fileno(fp);
3568 (void)PerlIO_close(fp);
3569 SETERRNO(EBADF,RMS_IFI);
3572 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3573 if (PL_laststatval < 0) {
3575 (void)PerlIO_close(fp);
3579 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3580 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3581 (void)PerlIO_close(fp);
3583 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3584 FT_RETURNNO; /* special case NFS directories */
3585 FT_RETURNYES; /* null file is anything */
3590 /* now scan s to look for textiness */
3592 #if defined(DOSISH) || defined(USEMYBINMODE)
3593 /* ignore trailing ^Z on short files */
3594 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3599 if (! is_utf8_invariant_string((U8 *) s, len)) {
3601 /* Here contains a variant under UTF-8 . See if the entire string is
3603 if (is_utf8_fixed_width_buf_flags((U8 *) s, len, 0)) {
3604 if (PL_op->op_type == OP_FTTEXT) {
3613 /* Here, is not UTF-8 or is entirely ASCII. Look through the buffer for
3614 * things that wouldn't be in ASCII text or rich ASCII text. Count these
3616 for (i = 0; i < len; i++, s++) {
3617 if (!*s) { /* null never allowed in text */
3621 #ifdef USE_LOCALE_CTYPE
3622 if (IN_LC_RUNTIME(LC_CTYPE)) {
3623 if ( isPRINT_LC(*s) || isSPACE_LC(*s)) {
3630 /* VT occurs so rarely in text, that we consider it odd */
3631 || (isSPACE_A(*s) && *s != VT_NATIVE)
3633 /* But there is a fair amount of backspaces and escapes in
3636 || *s == ESC_NATIVE)
3643 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3654 const char *tmps = NULL;
3658 SV * const sv = POPs;
3659 if (PL_op->op_flags & OPf_SPECIAL) {
3660 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3662 if (ckWARN(WARN_UNOPENED)) {
3663 Perl_warner(aTHX_ packWARN(WARN_UNOPENED),
3664 "chdir() on unopened filehandle %" SVf, sv);
3666 SETERRNO(EBADF,RMS_IFI);
3668 TAINT_PROPER("chdir");
3672 else if (!(gv = MAYBE_DEREF_GV(sv)))
3673 tmps = SvPV_nomg_const_nolen(sv);
3676 HV * const table = GvHVn(PL_envgv);
3680 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3681 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3683 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3687 tmps = SvPV_nolen_const(*svp);
3691 SETERRNO(EINVAL, LIB_INVARG);
3692 TAINT_PROPER("chdir");
3697 TAINT_PROPER("chdir");
3700 IO* const io = GvIO(gv);
3703 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3704 } else if (IoIFP(io)) {
3705 int fd = PerlIO_fileno(IoIFP(io));
3709 PUSHi(fchdir(fd) >= 0);
3719 DIE(aTHX_ PL_no_func, "fchdir");
3723 PUSHi( PerlDir_chdir(tmps) >= 0 );
3725 /* Clear the DEFAULT element of ENV so we'll get the new value
3727 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3734 SETERRNO(EBADF,RMS_IFI);
3741 /* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */
3745 dSP; dMARK; dTARGET;
3746 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3757 char * const tmps = POPpx;
3758 TAINT_PROPER("chroot");
3759 PUSHi( chroot(tmps) >= 0 );
3762 DIE(aTHX_ PL_no_func, "chroot");
3773 const char * const tmps2 = POPpconstx;
3774 const char * const tmps = SvPV_nolen_const(TOPs);
3775 TAINT_PROPER("rename");
3777 anum = PerlLIO_rename(tmps, tmps2);
3779 if (!(anum = PerlLIO_stat(tmps, &statbuf))) {
3780 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3783 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
3784 (void)UNLINK(tmps2);
3785 if (!(anum = link(tmps, tmps2)))
3786 anum = UNLINK(tmps);
3795 /* also used for: pp_symlink() */
3797 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3801 const int op_type = PL_op->op_type;
3805 if (op_type == OP_LINK)
3806 DIE(aTHX_ PL_no_func, "link");
3808 # ifndef HAS_SYMLINK
3809 if (op_type == OP_SYMLINK)
3810 DIE(aTHX_ PL_no_func, "symlink");
3814 const char * const tmps2 = POPpconstx;
3815 const char * const tmps = SvPV_nolen_const(TOPs);
3816 TAINT_PROPER(PL_op_desc[op_type]);
3818 # if defined(HAS_LINK)
3819 # if defined(HAS_SYMLINK)
3820 /* Both present - need to choose which. */
3821 (op_type == OP_LINK) ?
3822 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3824 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3825 PerlLIO_link(tmps, tmps2);
3828 # if defined(HAS_SYMLINK)
3829 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3830 symlink(tmps, tmps2);
3835 SETi( result >= 0 );
3840 /* also used for: pp_symlink() */
3845 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3855 char buf[MAXPATHLEN];
3860 /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
3861 * it is impossible to know whether the result was truncated. */
3862 len = readlink(tmps, buf, sizeof(buf) - 1);
3871 RETSETUNDEF; /* just pretend it's a normal file */
3875 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3877 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3879 char * const save_filename = filename;
3884 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3886 PERL_ARGS_ASSERT_DOONELINER;
3888 Newx(cmdline, size, char);
3889 my_strlcpy(cmdline, cmd, size);
3890 my_strlcat(cmdline, " ", size);
3891 for (s = cmdline + strlen(cmdline); *filename; ) {
3895 if (s - cmdline < size)
3896 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3897 myfp = PerlProc_popen(cmdline, "r");
3901 SV * const tmpsv = sv_newmortal();
3902 /* Need to save/restore 'PL_rs' ?? */
3903 s = sv_gets(tmpsv, myfp, 0);
3904 (void)PerlProc_pclose(myfp);
3908 #ifdef HAS_SYS_ERRLIST
3913 /* you don't see this */
3914 const char * const errmsg = Strerror(e) ;
3917 if (instr(s, errmsg)) {
3924 #define EACCES EPERM
3926 if (instr(s, "cannot make"))
3927 SETERRNO(EEXIST,RMS_FEX);
3928 else if (instr(s, "existing file"))
3929 SETERRNO(EEXIST,RMS_FEX);
3930 else if (instr(s, "ile exists"))
3931 SETERRNO(EEXIST,RMS_FEX);
3932 else if (instr(s, "non-exist"))
3933 SETERRNO(ENOENT,RMS_FNF);
3934 else if (instr(s, "does not exist"))
3935 SETERRNO(ENOENT,RMS_FNF);
3936 else if (instr(s, "not empty"))
3937 SETERRNO(EBUSY,SS_DEVOFFLINE);
3938 else if (instr(s, "cannot access"))
3939 SETERRNO(EACCES,RMS_PRV);
3941 SETERRNO(EPERM,RMS_PRV);
3944 else { /* some mkdirs return no failure indication */
3946 anum = (PerlLIO_stat(save_filename, &statbuf) >= 0);
3947 if (PL_op->op_type == OP_RMDIR)
3952 SETERRNO(EACCES,RMS_PRV); /* a guess */
3961 /* This macro removes trailing slashes from a directory name.
3962 * Different operating and file systems take differently to
3963 * trailing slashes. According to POSIX 1003.1 1996 Edition
3964 * any number of trailing slashes should be allowed.
3965 * Thusly we snip them away so that even non-conforming
3966 * systems are happy.
3967 * We should probably do this "filtering" for all
3968 * the functions that expect (potentially) directory names:
3969 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3970 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3972 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3973 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3976 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3977 (tmps) = savepvn((tmps), (len)); \
3987 const unsigned int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPu : 0777;
3989 TRIMSLASHES(tmps,len,copy);
3991 TAINT_PROPER("mkdir");
3993 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3997 SETi( dooneliner("mkdir", tmps) );
3998 oldumask = PerlLIO_umask(0);
3999 PerlLIO_umask(oldumask);
4000 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
4015 TRIMSLASHES(tmps,len,copy);
4016 TAINT_PROPER("rmdir");
4018 SETi( PerlDir_rmdir(tmps) >= 0 );
4020 SETi( dooneliner("rmdir", tmps) );
4027 /* Directory calls. */
4031 #if defined(Direntry_t) && defined(HAS_READDIR)
4033 const char * const dirname = POPpconstx;
4034 GV * const gv = MUTABLE_GV(POPs);
4035 IO * const io = GvIOn(gv);
4037 if ((IoIFP(io) || IoOFP(io)))
4038 Perl_croak(aTHX_ "Cannot open %" HEKf " as a dirhandle: it is already open as a filehandle",
4039 HEKfARG(GvENAME_HEK(gv)));
4041 PerlDir_close(IoDIRP(io));
4042 if (!(IoDIRP(io) = PerlDir_open(dirname)))
4048 SETERRNO(EBADF,RMS_DIR);
4051 DIE(aTHX_ PL_no_dir_func, "opendir");
4057 #if !defined(Direntry_t) || !defined(HAS_READDIR)
4058 DIE(aTHX_ PL_no_dir_func, "readdir");
4060 #if !defined(I_DIRENT) && !defined(VMS)
4061 Direntry_t *readdir (DIR *);
4066 const U8 gimme = GIMME_V;
4067 GV * const gv = MUTABLE_GV(POPs);
4068 const Direntry_t *dp;
4069 IO * const io = GvIOn(gv);
4072 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4073 "readdir() attempted on invalid dirhandle %" HEKf,
4074 HEKfARG(GvENAME_HEK(gv)));
4079 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
4083 sv = newSVpvn(dp->d_name, dp->d_namlen);
4085 sv = newSVpv(dp->d_name, 0);
4087 if (!(IoFLAGS(io) & IOf_UNTAINT))
4090 } while (gimme == G_ARRAY);
4092 if (!dp && gimme != G_ARRAY)
4099 SETERRNO(EBADF,RMS_ISI);
4100 if (gimme == G_ARRAY)
4109 #if defined(HAS_TELLDIR) || defined(telldir)
4111 /* XXX does _anyone_ need this? --AD 2/20/1998 */
4112 /* XXX netbsd still seemed to.
4113 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
4114 --JHI 1999-Feb-02 */
4115 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
4116 long telldir (DIR *);
4118 GV * const gv = MUTABLE_GV(POPs);
4119 IO * const io = GvIOn(gv);
4122 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4123 "telldir() attempted on invalid dirhandle %" HEKf,
4124 HEKfARG(GvENAME_HEK(gv)));
4128 PUSHi( PerlDir_tell(IoDIRP(io)) );
4132 SETERRNO(EBADF,RMS_ISI);
4135 DIE(aTHX_ PL_no_dir_func, "telldir");
4141 #if defined(HAS_SEEKDIR) || defined(seekdir)
4143 const long along = POPl;
4144 GV * const gv = MUTABLE_GV(POPs);
4145 IO * const io = GvIOn(gv);
4148 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4149 "seekdir() attempted on invalid dirhandle %" HEKf,
4150 HEKfARG(GvENAME_HEK(gv)));
4153 (void)PerlDir_seek(IoDIRP(io), along);
4158 SETERRNO(EBADF,RMS_ISI);
4161 DIE(aTHX_ PL_no_dir_func, "seekdir");
4167 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4169 GV * const gv = MUTABLE_GV(POPs);
4170 IO * const io = GvIOn(gv);
4173 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4174 "rewinddir() attempted on invalid dirhandle %" HEKf,
4175 HEKfARG(GvENAME_HEK(gv)));
4178 (void)PerlDir_rewind(IoDIRP(io));
4182 SETERRNO(EBADF,RMS_ISI);
4185 DIE(aTHX_ PL_no_dir_func, "rewinddir");
4191 #if defined(Direntry_t) && defined(HAS_READDIR)
4193 GV * const gv = MUTABLE_GV(POPs);
4194 IO * const io = GvIOn(gv);
4197 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4198 "closedir() attempted on invalid dirhandle %" HEKf,
4199 HEKfARG(GvENAME_HEK(gv)));
4202 #ifdef VOID_CLOSEDIR
4203 PerlDir_close(IoDIRP(io));
4205 if (PerlDir_close(IoDIRP(io)) < 0) {
4206 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4215 SETERRNO(EBADF,RMS_IFI);
4218 DIE(aTHX_ PL_no_dir_func, "closedir");
4222 /* Process control. */
4229 #ifdef HAS_SIGPROCMASK
4230 sigset_t oldmask, newmask;
4234 PERL_FLUSHALL_FOR_CHILD;
4235 #ifdef HAS_SIGPROCMASK
4236 sigfillset(&newmask);
4237 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4239 childpid = PerlProc_fork();
4240 if (childpid == 0) {
4244 for (sig = 1; sig < SIG_SIZE; sig++)
4245 PL_psig_pend[sig] = 0;
4247 #ifdef HAS_SIGPROCMASK
4250 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4257 #ifdef PERL_USES_PL_PIDSTATUS
4258 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4264 # if (defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)) || defined(__amigaos4__)
4269 PERL_FLUSHALL_FOR_CHILD;
4270 childpid = PerlProc_fork();
4276 DIE(aTHX_ PL_no_func, "fork");
4283 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4288 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4289 childpid = wait4pid(-1, &argflags, 0);
4291 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4296 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4297 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4298 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4300 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4305 DIE(aTHX_ PL_no_func, "wait");
4311 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4313 const int optype = POPi;
4314 const Pid_t pid = TOPi;
4318 result = amigaos_waitpid(aTHX_ optype, pid, &argflags);
4319 STATUS_NATIVE_CHILD_SET((result >= 0) ? argflags : -1);
4320 result = result == 0 ? pid : -1;
4324 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4325 result = wait4pid(pid, &argflags, optype);
4327 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4332 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4333 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4334 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4336 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4338 # endif /* __amigaos4__ */
4342 DIE(aTHX_ PL_no_func, "waitpid");
4348 dSP; dMARK; dORIGMARK; dTARGET;
4349 #if defined(__LIBCATAMOUNT__)
4350 PL_statusvalue = -1;
4355 # ifdef __amigaos4__
4363 while (++MARK <= SP) {
4364 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4369 TAINT_PROPER("system");
4371 PERL_FLUSHALL_FOR_CHILD;
4372 #if (defined(HAS_FORK) || defined(__amigaos4__)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4375 struct UserData userdata;
4382 bool child_success = FALSE;
4383 #ifdef HAS_SIGPROCMASK
4384 sigset_t newset, oldset;
4387 if (PerlProc_pipe(pp) >= 0)
4390 amigaos_fork_set_userdata(aTHX_
4396 pthread_create(&proc,NULL,amigaos_system_child,(void *)&userdata);
4397 child_success = proc > 0;
4399 #ifdef HAS_SIGPROCMASK
4400 sigemptyset(&newset);
4401 sigaddset(&newset, SIGCHLD);
4402 sigprocmask(SIG_BLOCK, &newset, &oldset);
4404 while ((childpid = PerlProc_fork()) == -1) {
4405 if (errno != EAGAIN) {
4410 PerlLIO_close(pp[0]);
4411 PerlLIO_close(pp[1]);
4413 #ifdef HAS_SIGPROCMASK
4414 sigprocmask(SIG_SETMASK, &oldset, NULL);
4420 child_success = childpid > 0;
4422 if (child_success) {
4423 Sigsave_t ihand,qhand; /* place to save signals during system() */
4426 #ifndef __amigaos4__
4428 PerlLIO_close(pp[1]);
4431 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4432 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4435 result = pthread_join(proc, (void **)&status);
4438 result = wait4pid(childpid, &status, 0);
4439 } while (result == -1 && errno == EINTR);
4442 #ifdef HAS_SIGPROCMASK
4443 sigprocmask(SIG_SETMASK, &oldset, NULL);
4445 (void)rsignal_restore(SIGINT, &ihand);
4446 (void)rsignal_restore(SIGQUIT, &qhand);
4448 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4449 do_execfree(); /* free any memory child malloced on fork */
4455 while (n < sizeof(int)) {
4456 const SSize_t n1 = PerlLIO_read(pp[0],
4457 (void*)(((char*)&errkid)+n),
4463 PerlLIO_close(pp[0]);
4464 if (n) { /* Error */
4465 if (n != sizeof(int))
4466 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4467 errno = errkid; /* Propagate errno from kid */
4469 /* The pipe always has something in it
4470 * so n alone is not enough. */
4474 STATUS_NATIVE_CHILD_SET(-1);
4478 XPUSHi(STATUS_CURRENT);
4481 #ifndef __amigaos4__
4482 #ifdef HAS_SIGPROCMASK
4483 sigprocmask(SIG_SETMASK, &oldset, NULL);
4486 PerlLIO_close(pp[0]);
4487 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
4488 if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
4492 if (PL_op->op_flags & OPf_STACKED) {
4493 SV * const really = *++MARK;
4494 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4496 else if (SP - MARK != 1)
4497 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4499 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4501 #endif /* __amigaos4__ */
4504 #else /* ! FORK or VMS or OS/2 */
4507 if (PL_op->op_flags & OPf_STACKED) {
4508 SV * const really = *++MARK;
4509 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4510 value = (I32)do_aspawn(really, MARK, SP);
4512 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4515 else if (SP - MARK != 1) {
4516 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4517 value = (I32)do_aspawn(NULL, MARK, SP);
4519 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4523 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4525 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4527 STATUS_NATIVE_CHILD_SET(value);
4530 XPUSHi(result ? value : STATUS_CURRENT);
4531 #endif /* !FORK or VMS or OS/2 */
4538 dSP; dMARK; dORIGMARK; dTARGET;
4543 while (++MARK <= SP) {
4544 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4549 TAINT_PROPER("exec");
4552 PERL_FLUSHALL_FOR_CHILD;
4553 if (PL_op->op_flags & OPf_STACKED) {
4554 SV * const really = *++MARK;
4555 value = (I32)do_aexec(really, MARK, SP);
4557 else if (SP - MARK != 1)
4559 value = (I32)vms_do_aexec(NULL, MARK, SP);
4561 value = (I32)do_aexec(NULL, MARK, SP);
4565 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4567 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4579 XPUSHi( getppid() );
4582 DIE(aTHX_ PL_no_func, "getppid");
4592 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4595 pgrp = (I32)BSD_GETPGRP(pid);
4597 if (pid != 0 && pid != PerlProc_getpid())
4598 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4604 DIE(aTHX_ PL_no_func, "getpgrp");
4614 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4615 if (MAXARG > 0) pid = TOPs ? TOPi : 0;
4622 TAINT_PROPER("setpgrp");
4624 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4626 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4627 || (pid != 0 && pid != PerlProc_getpid()))
4629 DIE(aTHX_ "setpgrp can't take arguments");
4631 SETi( setpgrp() >= 0 );
4632 #endif /* USE_BSDPGRP */
4635 DIE(aTHX_ PL_no_func, "setpgrp");
4639 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4640 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4642 # define PRIORITY_WHICH_T(which) which
4647 #ifdef HAS_GETPRIORITY
4649 const int who = POPi;
4650 const int which = TOPi;
4651 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4654 DIE(aTHX_ PL_no_func, "getpriority");
4660 #ifdef HAS_SETPRIORITY
4662 const int niceval = POPi;
4663 const int who = POPi;
4664 const int which = TOPi;
4665 TAINT_PROPER("setpriority");
4666 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4669 DIE(aTHX_ PL_no_func, "setpriority");
4673 #undef PRIORITY_WHICH_T
4681 XPUSHn( time(NULL) );
4683 XPUSHi( time(NULL) );
4692 struct tms timesbuf;
4695 (void)PerlProc_times(×buf);
4697 mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
4698 if (GIMME_V == G_ARRAY) {
4699 mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
4700 mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
4701 mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
4709 if (GIMME_V == G_ARRAY) {
4716 DIE(aTHX_ "times not implemented");
4718 #endif /* HAS_TIMES */
4721 /* The 32 bit int year limits the times we can represent to these
4722 boundaries with a few days wiggle room to account for time zone
4725 /* Sat Jan 3 00:00:00 -2147481748 */
4726 #define TIME_LOWER_BOUND -67768100567755200.0
4727 /* Sun Dec 29 12:00:00 2147483647 */
4728 #define TIME_UPPER_BOUND 67767976233316800.0
4731 /* also used for: pp_localtime() */
4739 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4740 static const char * const dayname[] =
4741 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4742 static const char * const monname[] =
4743 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4744 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4746 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4749 when = (Time64_T)now;
4752 NV input = Perl_floor(POPn);
4753 const bool pl_isnan = Perl_isnan(input);
4754 when = (Time64_T)input;
4755 if (UNLIKELY(pl_isnan || when != input)) {
4756 /* diag_listed_as: gmtime(%f) too large */
4757 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4758 "%s(%.0" NVff ") too large", opname, input);
4766 if ( TIME_LOWER_BOUND > when ) {
4767 /* diag_listed_as: gmtime(%f) too small */
4768 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4769 "%s(%.0" NVff ") too small", opname, when);
4772 else if( when > TIME_UPPER_BOUND ) {
4773 /* diag_listed_as: gmtime(%f) too small */
4774 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4775 "%s(%.0" NVff ") too large", opname, when);
4779 if (PL_op->op_type == OP_LOCALTIME)
4780 err = Perl_localtime64_r(&when, &tmbuf);
4782 err = Perl_gmtime64_r(&when, &tmbuf);
4786 /* diag_listed_as: gmtime(%f) failed */
4787 /* XXX %lld broken for quads */
4789 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4790 "%s(%.0" NVff ") failed", opname, when);
4793 if (GIMME_V != G_ARRAY) { /* scalar context */
4800 Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %" IVdf,
4801 dayname[tmbuf.tm_wday],
4802 monname[tmbuf.tm_mon],
4807 (IV)tmbuf.tm_year + 1900);
4810 else { /* list context */
4816 mPUSHi(tmbuf.tm_sec);
4817 mPUSHi(tmbuf.tm_min);
4818 mPUSHi(tmbuf.tm_hour);
4819 mPUSHi(tmbuf.tm_mday);
4820 mPUSHi(tmbuf.tm_mon);
4821 mPUSHn(tmbuf.tm_year);
4822 mPUSHi(tmbuf.tm_wday);
4823 mPUSHi(tmbuf.tm_yday);
4824 mPUSHi(tmbuf.tm_isdst);
4833 /* alarm() takes an unsigned int number of seconds, and return the
4834 * unsigned int number of seconds remaining in the previous alarm
4835 * (alarms don't stack). Therefore negative return values are not
4839 /* Note that while the C library function alarm() as such has
4840 * no errors defined (or in other words, properly behaving client
4841 * code shouldn't expect any), alarm() being obsoleted by
4842 * setitimer() and often being implemented in terms of
4843 * setitimer(), can fail. */
4844 /* diag_listed_as: %s() with negative argument */
4845 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4846 "alarm() with negative argument");
4847 SETERRNO(EINVAL, LIB_INVARG);
4851 unsigned int retval = alarm(anum);
4852 if ((int)retval < 0) /* Strictly speaking "cannot happen". */
4858 DIE(aTHX_ PL_no_func, "alarm");
4868 (void)time(&lasttime);
4869 if (MAXARG < 1 || (!TOPs && !POPs))
4872 const I32 duration = POPi;
4874 /* diag_listed_as: %s() with negative argument */
4875 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4876 "sleep() with negative argument");
4877 SETERRNO(EINVAL, LIB_INVARG);
4878 XPUSHs(&PL_sv_zero);
4881 PerlProc_sleep((unsigned int)duration);
4885 XPUSHi(when - lasttime);
4889 /* Shared memory. */
4890 /* Merged with some message passing. */
4892 /* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */
4896 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4897 dSP; dMARK; dTARGET;
4898 const int op_type = PL_op->op_type;
4903 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4906 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4909 value = (I32)(do_semop(MARK, SP) >= 0);
4912 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4920 return Perl_pp_semget(aTHX);
4926 /* also used for: pp_msgget() pp_shmget() */
4930 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4931 dSP; dMARK; dTARGET;
4932 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4939 DIE(aTHX_ "System V IPC is not implemented on this machine");
4943 /* also used for: pp_msgctl() pp_shmctl() */
4947 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4948 dSP; dMARK; dTARGET;
4949 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4957 PUSHp(zero_but_true, ZBTLEN);
4961 return Perl_pp_semget(aTHX);
4965 /* I can't const this further without getting warnings about the types of
4966 various arrays passed in from structures. */
4968 S_space_join_names_mortal(pTHX_ char *const *array)
4972 if (array && *array) {
4973 target = newSVpvs_flags("", SVs_TEMP);
4975 sv_catpv(target, *array);
4978 sv_catpvs(target, " ");
4981 target = sv_mortalcopy(&PL_sv_no);
4986 /* Get system info. */
4988 /* also used for: pp_ghbyaddr() pp_ghbyname() */
4992 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4994 I32 which = PL_op->op_type;
4997 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4998 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4999 struct hostent *gethostbyname(Netdb_name_t);
5000 struct hostent *gethostent(void);
5002 struct hostent *hent = NULL;
5006 if (which == OP_GHBYNAME) {
5007 #ifdef HAS_GETHOSTBYNAME
5008 const char* const name = POPpbytex;
5009 hent = PerlSock_gethostbyname(name);
5011 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
5014 else if (which == OP_GHBYADDR) {
5015 #ifdef HAS_GETHOSTBYADDR
5016 const int addrtype = POPi;
5017 SV * const addrsv = POPs;
5019 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
5021 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
5023 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
5027 #ifdef HAS_GETHOSTENT
5028 hent = PerlSock_gethostent();
5030 DIE(aTHX_ PL_no_sock_func, "gethostent");
5033 #ifdef HOST_NOT_FOUND
5035 #ifdef USE_REENTRANT_API
5036 # ifdef USE_GETHOSTENT_ERRNO
5037 h_errno = PL_reentrant_buffer->_gethostent_errno;
5040 STATUS_UNIX_SET(h_errno);
5044 if (GIMME_V != G_ARRAY) {
5045 PUSHs(sv = sv_newmortal());
5047 if (which == OP_GHBYNAME) {
5049 sv_setpvn(sv, hent->h_addr, hent->h_length);
5052 sv_setpv(sv, (char*)hent->h_name);
5058 mPUSHs(newSVpv((char*)hent->h_name, 0));
5059 PUSHs(space_join_names_mortal(hent->h_aliases));
5060 mPUSHi(hent->h_addrtype);
5061 len = hent->h_length;
5064 for (elem = hent->h_addr_list; elem && *elem; elem++) {
5065 mXPUSHp(*elem, len);
5069 mPUSHp(hent->h_addr, len);
5071 PUSHs(sv_mortalcopy(&PL_sv_no));
5076 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5080 /* also used for: pp_gnbyaddr() pp_gnbyname() */
5084 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
5086 I32 which = PL_op->op_type;
5088 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
5089 struct netent *getnetbyaddr(Netdb_net_t, int);
5090 struct netent *getnetbyname(Netdb_name_t);
5091 struct netent *getnetent(void);
5093 struct netent *nent;
5095 if (which == OP_GNBYNAME){
5096 #ifdef HAS_GETNETBYNAME
5097 const char * const name = POPpbytex;
5098 nent = PerlSock_getnetbyname(name);
5100 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
5103 else if (which == OP_GNBYADDR) {
5104 #ifdef HAS_GETNETBYADDR
5105 const int addrtype = POPi;
5106 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
5107 nent = PerlSock_getnetbyaddr(addr, addrtype);
5109 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
5113 #ifdef HAS_GETNETENT
5114 nent = PerlSock_getnetent();
5116 DIE(aTHX_ PL_no_sock_func, "getnetent");
5119 #ifdef HOST_NOT_FOUND
5121 #ifdef USE_REENTRANT_API
5122 # ifdef USE_GETNETENT_ERRNO
5123 h_errno = PL_reentrant_buffer->_getnetent_errno;
5126 STATUS_UNIX_SET(h_errno);
5131 if (GIMME_V != G_ARRAY) {
5132 PUSHs(sv = sv_newmortal());
5134 if (which == OP_GNBYNAME)
5135 sv_setiv(sv, (IV)nent->n_net);
5137 sv_setpv(sv, nent->n_name);
5143 mPUSHs(newSVpv(nent->n_name, 0));
5144 PUSHs(space_join_names_mortal(nent->n_aliases));
5145 mPUSHi(nent->n_addrtype);
5146 mPUSHi(nent->n_net);
5151 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5156 /* also used for: pp_gpbyname() pp_gpbynumber() */
5160 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
5162 I32 which = PL_op->op_type;
5164 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
5165 struct protoent *getprotobyname(Netdb_name_t);
5166 struct protoent *getprotobynumber(int);
5167 struct protoent *getprotoent(void);
5169 struct protoent *pent;
5171 if (which == OP_GPBYNAME) {
5172 #ifdef HAS_GETPROTOBYNAME
5173 const char* const name = POPpbytex;
5174 pent = PerlSock_getprotobyname(name);
5176 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
5179 else if (which == OP_GPBYNUMBER) {
5180 #ifdef HAS_GETPROTOBYNUMBER
5181 const int number = POPi;
5182 pent = PerlSock_getprotobynumber(number);
5184 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
5188 #ifdef HAS_GETPROTOENT
5189 pent = PerlSock_getprotoent();
5191 DIE(aTHX_ PL_no_sock_func, "getprotoent");
5195 if (GIMME_V != G_ARRAY) {
5196 PUSHs(sv = sv_newmortal());
5198 if (which == OP_GPBYNAME)
5199 sv_setiv(sv, (IV)pent->p_proto);
5201 sv_setpv(sv, pent->p_name);
5207 mPUSHs(newSVpv(pent->p_name, 0));
5208 PUSHs(space_join_names_mortal(pent->p_aliases));
5209 mPUSHi(pent->p_proto);
5214 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5219 /* also used for: pp_gsbyname() pp_gsbyport() */
5223 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
5225 I32 which = PL_op->op_type;
5227 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
5228 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
5229 struct servent *getservbyport(int, Netdb_name_t);
5230 struct servent *getservent(void);
5232 struct servent *sent;
5234 if (which == OP_GSBYNAME) {
5235 #ifdef HAS_GETSERVBYNAME
5236 const char * const proto = POPpbytex;
5237 const char * const name = POPpbytex;
5238 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5240 DIE(aTHX_ PL_no_sock_func, "getservbyname");
5243 else if (which == OP_GSBYPORT) {
5244 #ifdef HAS_GETSERVBYPORT
5245 const char * const proto = POPpbytex;
5246 unsigned short port = (unsigned short)POPu;
5247 port = PerlSock_htons(port);
5248 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5250 DIE(aTHX_ PL_no_sock_func, "getservbyport");
5254 #ifdef HAS_GETSERVENT
5255 sent = PerlSock_getservent();
5257 DIE(aTHX_ PL_no_sock_func, "getservent");
5261 if (GIMME_V != G_ARRAY) {
5262 PUSHs(sv = sv_newmortal());
5264 if (which == OP_GSBYNAME) {
5265 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5268 sv_setpv(sv, sent->s_name);
5274 mPUSHs(newSVpv(sent->s_name, 0));
5275 PUSHs(space_join_names_mortal(sent->s_aliases));
5276 mPUSHi(PerlSock_ntohs(sent->s_port));
5277 mPUSHs(newSVpv(sent->s_proto, 0));
5282 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5287 /* also used for: pp_snetent() pp_sprotoent() pp_sservent() */
5292 const int stayopen = TOPi;
5293 switch(PL_op->op_type) {
5295 #ifdef HAS_SETHOSTENT
5296 PerlSock_sethostent(stayopen);
5298 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5301 #ifdef HAS_SETNETENT
5303 PerlSock_setnetent(stayopen);
5305 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5309 #ifdef HAS_SETPROTOENT
5310 PerlSock_setprotoent(stayopen);
5312 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5316 #ifdef HAS_SETSERVENT
5317 PerlSock_setservent(stayopen);
5319 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5327 /* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent()
5328 * pp_eservent() pp_sgrent() pp_spwent() */
5333 switch(PL_op->op_type) {
5335 #ifdef HAS_ENDHOSTENT
5336 PerlSock_endhostent();
5338 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5342 #ifdef HAS_ENDNETENT
5343 PerlSock_endnetent();
5345 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5349 #ifdef HAS_ENDPROTOENT
5350 PerlSock_endprotoent();
5352 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5356 #ifdef HAS_ENDSERVENT
5357 PerlSock_endservent();
5359 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5363 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5366 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5370 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5373 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5377 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5380 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5384 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5387 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5396 /* also used for: pp_gpwnam() pp_gpwuid() */
5402 I32 which = PL_op->op_type;
5404 struct passwd *pwent = NULL;
5406 * We currently support only the SysV getsp* shadow password interface.
5407 * The interface is declared in <shadow.h> and often one needs to link
5408 * with -lsecurity or some such.
5409 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5412 * AIX getpwnam() is clever enough to return the encrypted password
5413 * only if the caller (euid?) is root.
5415 * There are at least three other shadow password APIs. Many platforms
5416 * seem to contain more than one interface for accessing the shadow
5417 * password databases, possibly for compatibility reasons.
5418 * The getsp*() is by far he simplest one, the other two interfaces
5419 * are much more complicated, but also very similar to each other.
5424 * struct pr_passwd *getprpw*();
5425 * The password is in
5426 * char getprpw*(...).ufld.fd_encrypt[]
5427 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5432 * struct es_passwd *getespw*();
5433 * The password is in
5434 * char *(getespw*(...).ufld.fd_encrypt)
5435 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5438 * struct userpw *getuserpw();
5439 * The password is in
5440 * char *(getuserpw(...)).spw_upw_passwd
5441 * (but the de facto standard getpwnam() should work okay)
5443 * Mention I_PROT here so that Configure probes for it.
5445 * In HP-UX for getprpw*() the manual page claims that one should include
5446 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5447 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5448 * and pp_sys.c already includes <shadow.h> if there is such.
5450 * Note that <sys/security.h> is already probed for, but currently
5451 * it is only included in special cases.
5453 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5454 * be preferred interface, even though also the getprpw*() interface
5455 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5456 * One also needs to call set_auth_parameters() in main() before
5457 * doing anything else, whether one is using getespw*() or getprpw*().
5459 * Note that accessing the shadow databases can be magnitudes
5460 * slower than accessing the standard databases.
5465 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5466 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5467 * the pw_comment is left uninitialized. */
5468 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5474 const char* const name = POPpbytex;
5475 pwent = getpwnam(name);
5481 pwent = getpwuid(uid);
5485 # ifdef HAS_GETPWENT
5487 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5488 if (pwent) pwent = getpwnam(pwent->pw_name);
5491 DIE(aTHX_ PL_no_func, "getpwent");
5497 if (GIMME_V != G_ARRAY) {
5498 PUSHs(sv = sv_newmortal());
5500 if (which == OP_GPWNAM)
5501 sv_setuid(sv, pwent->pw_uid);
5503 sv_setpv(sv, pwent->pw_name);
5509 mPUSHs(newSVpv(pwent->pw_name, 0));
5513 /* If we have getspnam(), we try to dig up the shadow
5514 * password. If we are underprivileged, the shadow
5515 * interface will set the errno to EACCES or similar,
5516 * and return a null pointer. If this happens, we will
5517 * use the dummy password (usually "*" or "x") from the
5518 * standard password database.
5520 * In theory we could skip the shadow call completely
5521 * if euid != 0 but in practice we cannot know which
5522 * security measures are guarding the shadow databases
5523 * on a random platform.
5525 * Resist the urge to use additional shadow interfaces.
5526 * Divert the urge to writing an extension instead.
5529 /* Some AIX setups falsely(?) detect some getspnam(), which
5530 * has a different API than the Solaris/IRIX one. */
5531 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5534 const struct spwd * const spwent = getspnam(pwent->pw_name);
5535 /* Save and restore errno so that
5536 * underprivileged attempts seem
5537 * to have never made the unsuccessful
5538 * attempt to retrieve the shadow password. */
5540 if (spwent && spwent->sp_pwdp)
5541 sv_setpv(sv, spwent->sp_pwdp);
5545 if (!SvPOK(sv)) /* Use the standard password, then. */
5546 sv_setpv(sv, pwent->pw_passwd);
5549 /* passwd is tainted because user himself can diddle with it.
5550 * admittedly not much and in a very limited way, but nevertheless. */
5553 sv_setuid(PUSHmortal, pwent->pw_uid);
5554 sv_setgid(PUSHmortal, pwent->pw_gid);
5556 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5557 * because of the poor interface of the Perl getpw*(),
5558 * not because there's some standard/convention saying so.
5559 * A better interface would have been to return a hash,
5560 * but we are accursed by our history, alas. --jhi. */
5562 mPUSHi(pwent->pw_change);
5565 mPUSHi(pwent->pw_quota);
5568 mPUSHs(newSVpv(pwent->pw_age, 0));
5570 /* I think that you can never get this compiled, but just in case. */
5571 PUSHs(sv_mortalcopy(&PL_sv_no));
5576 /* pw_class and pw_comment are mutually exclusive--.
5577 * see the above note for pw_change, pw_quota, and pw_age. */
5579 mPUSHs(newSVpv(pwent->pw_class, 0));
5582 mPUSHs(newSVpv(pwent->pw_comment, 0));
5584 /* I think that you can never get this compiled, but just in case. */
5585 PUSHs(sv_mortalcopy(&PL_sv_no));
5590 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5592 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5594 /* pw_gecos is tainted because user himself can diddle with it. */
5597 mPUSHs(newSVpv(pwent->pw_dir, 0));
5599 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5600 /* pw_shell is tainted because user himself can diddle with it. */
5604 mPUSHi(pwent->pw_expire);
5609 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5614 /* also used for: pp_ggrgid() pp_ggrnam() */
5620 const I32 which = PL_op->op_type;
5621 const struct group *grent;
5623 if (which == OP_GGRNAM) {
5624 const char* const name = POPpbytex;
5625 grent = (const struct group *)getgrnam(name);
5627 else if (which == OP_GGRGID) {
5629 const Gid_t gid = POPu;
5630 #elif Gid_t_sign == -1
5631 const Gid_t gid = POPi;
5633 # error "Unexpected Gid_t_sign"
5635 grent = (const struct group *)getgrgid(gid);
5639 grent = (struct group *)getgrent();
5641 DIE(aTHX_ PL_no_func, "getgrent");
5645 if (GIMME_V != G_ARRAY) {
5646 SV * const sv = sv_newmortal();
5650 if (which == OP_GGRNAM)
5651 sv_setgid(sv, grent->gr_gid);
5653 sv_setpv(sv, grent->gr_name);
5659 mPUSHs(newSVpv(grent->gr_name, 0));
5662 mPUSHs(newSVpv(grent->gr_passwd, 0));
5664 PUSHs(sv_mortalcopy(&PL_sv_no));
5667 sv_setgid(PUSHmortal, grent->gr_gid);
5669 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5670 /* In UNICOS/mk (_CRAYMPP) the multithreading
5671 * versions (getgrnam_r, getgrgid_r)
5672 * seem to return an illegal pointer
5673 * as the group members list, gr_mem.
5674 * getgrent() doesn't even have a _r version
5675 * but the gr_mem is poisonous anyway.
5676 * So yes, you cannot get the list of group
5677 * members if building multithreaded in UNICOS/mk. */
5678 PUSHs(space_join_names_mortal(grent->gr_mem));
5684 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5694 if (!(tmps = PerlProc_getlogin()))
5696 sv_setpv_mg(TARG, tmps);
5700 DIE(aTHX_ PL_no_func, "getlogin");
5704 /* Miscellaneous. */
5709 dSP; dMARK; dORIGMARK; dTARGET;
5710 I32 items = SP - MARK;
5711 unsigned long a[20];
5716 while (++MARK <= SP) {
5717 if (SvTAINTED(*MARK)) {
5723 TAINT_PROPER("syscall");
5726 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5727 * or where sizeof(long) != sizeof(char*). But such machines will
5728 * not likely have syscall implemented either, so who cares?
5730 while (++MARK <= SP) {
5731 if (SvNIOK(*MARK) || !i)
5732 a[i++] = SvIV(*MARK);
5733 else if (*MARK == &PL_sv_undef)
5736 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5742 DIE(aTHX_ "Too many args to syscall");
5744 DIE(aTHX_ "Too few args to syscall");
5746 retval = syscall(a[0]);
5749 retval = syscall(a[0],a[1]);
5752 retval = syscall(a[0],a[1],a[2]);
5755 retval = syscall(a[0],a[1],a[2],a[3]);
5758 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5761 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5764 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5767 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5774 DIE(aTHX_ PL_no_func, "syscall");
5778 #ifdef FCNTL_EMULATE_FLOCK
5780 /* XXX Emulate flock() with fcntl().
5781 What's really needed is a good file locking module.
5785 fcntl_emulate_flock(int fd, int operation)
5790 switch (operation & ~LOCK_NB) {
5792 flock.l_type = F_RDLCK;
5795 flock.l_type = F_WRLCK;
5798 flock.l_type = F_UNLCK;
5804 flock.l_whence = SEEK_SET;
5805 flock.l_start = flock.l_len = (Off_t)0;
5807 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5808 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5809 errno = EWOULDBLOCK;
5813 #endif /* FCNTL_EMULATE_FLOCK */
5815 #ifdef LOCKF_EMULATE_FLOCK
5817 /* XXX Emulate flock() with lockf(). This is just to increase
5818 portability of scripts. The calls are not completely
5819 interchangeable. What's really needed is a good file
5823 /* The lockf() constants might have been defined in <unistd.h>.
5824 Unfortunately, <unistd.h> causes troubles on some mixed
5825 (BSD/POSIX) systems, such as SunOS 4.1.3.
5827 Further, the lockf() constants aren't POSIX, so they might not be
5828 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5829 just stick in the SVID values and be done with it. Sigh.
5833 # define F_ULOCK 0 /* Unlock a previously locked region */
5836 # define F_LOCK 1 /* Lock a region for exclusive use */
5839 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5842 # define F_TEST 3 /* Test a region for other processes locks */
5846 lockf_emulate_flock(int fd, int operation)
5852 /* flock locks entire file so for lockf we need to do the same */
5853 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5854 if (pos > 0) /* is seekable and needs to be repositioned */
5855 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5856 pos = -1; /* seek failed, so don't seek back afterwards */
5859 switch (operation) {
5861 /* LOCK_SH - get a shared lock */
5863 /* LOCK_EX - get an exclusive lock */
5865 i = lockf (fd, F_LOCK, 0);
5868 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5869 case LOCK_SH|LOCK_NB:
5870 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5871 case LOCK_EX|LOCK_NB:
5872 i = lockf (fd, F_TLOCK, 0);
5874 if ((errno == EAGAIN) || (errno == EACCES))
5875 errno = EWOULDBLOCK;
5878 /* LOCK_UN - unlock (non-blocking is a no-op) */
5880 case LOCK_UN|LOCK_NB:
5881 i = lockf (fd, F_ULOCK, 0);
5884 /* Default - can't decipher operation */
5891 if (pos > 0) /* need to restore position of the handle */
5892 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5897 #endif /* LOCKF_EMULATE_FLOCK */
5900 * ex: set ts=8 sts=4 sw=4 et: