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__)
80 struct passwd *getpwnam (char *);
81 struct passwd *getpwuid (Uid_t);
85 struct passwd *getpwent (void);
86 # elif defined (VMS) && defined (my_getpwent)
87 struct passwd *Perl_my_getpwent (pTHX);
96 struct group *getgrnam (char *);
97 struct group *getgrgid (Gid_t);
101 struct group *getgrent (void);
107 # if defined(_MSC_VER) || defined(__MINGW32__)
108 # include <sys/utime.h>
115 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
118 # define my_chsize PerlLIO_chsize
119 #elif defined(HAS_TRUNCATE)
120 # define my_chsize PerlLIO_chsize
122 I32 my_chsize(int fd, Off_t length);
127 #else /* no flock() */
129 /* fcntl.h might not have been included, even if it exists, because
130 the current Configure only sets I_FCNTL if it's needed to pick up
131 the *_OK constants. Make sure it has been included before testing
132 the fcntl() locking constants. */
133 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
137 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
138 # define FLOCK fcntl_emulate_flock
139 # define FCNTL_EMULATE_FLOCK
140 # elif defined(HAS_LOCKF)
141 # define FLOCK lockf_emulate_flock
142 # define LOCKF_EMULATE_FLOCK
146 static int FLOCK (int, int);
149 * These are the flock() constants. Since this sytems doesn't have
150 * flock(), the values of the constants are probably not available.
164 # endif /* emulating flock() */
166 #endif /* no flock() */
169 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
171 #if defined(I_SYS_ACCESS) && !defined(R_OK)
172 # include <sys/access.h>
178 /* Missing protos on LynxOS */
179 void sethostent(int);
180 void endhostent(void);
182 void endnetent(void);
183 void setprotoent(int);
184 void endprotoent(void);
185 void setservent(int);
186 void endservent(void);
190 # include "amigaos4/amigaio.h"
193 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
195 /* F_OK unused: if stat() cannot find it... */
197 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
198 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
199 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
202 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
203 # ifdef I_SYS_SECURITY
204 # include <sys/security.h>
208 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
211 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
215 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
217 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
221 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
222 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
223 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
226 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
228 const Uid_t ruid = getuid();
229 const Uid_t euid = geteuid();
230 const Gid_t rgid = getgid();
231 const Gid_t egid = getegid();
234 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
235 Perl_croak(aTHX_ "switching effective uid is not implemented");
238 if (setreuid(euid, ruid))
239 # elif defined(HAS_SETRESUID)
240 if (setresuid(euid, ruid, (Uid_t)-1))
242 /* diag_listed_as: entering effective %s failed */
243 Perl_croak(aTHX_ "entering effective uid failed");
246 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
247 Perl_croak(aTHX_ "switching effective gid is not implemented");
250 if (setregid(egid, rgid))
251 # elif defined(HAS_SETRESGID)
252 if (setresgid(egid, rgid, (Gid_t)-1))
254 /* diag_listed_as: entering effective %s failed */
255 Perl_croak(aTHX_ "entering effective gid failed");
258 res = access(path, mode);
261 if (setreuid(ruid, euid))
262 #elif defined(HAS_SETRESUID)
263 if (setresuid(ruid, euid, (Uid_t)-1))
265 /* diag_listed_as: leaving effective %s failed */
266 Perl_croak(aTHX_ "leaving effective uid failed");
269 if (setregid(rgid, egid))
270 #elif defined(HAS_SETRESGID)
271 if (setresgid(rgid, egid, (Gid_t)-1))
273 /* diag_listed_as: leaving effective %s failed */
274 Perl_croak(aTHX_ "leaving effective gid failed");
278 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
285 const char * const tmps = POPpconstx;
286 const U8 gimme = GIMME_V;
287 const char *mode = "r";
290 if (PL_op->op_private & OPpOPEN_IN_RAW)
292 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
294 fp = PerlProc_popen(tmps, mode);
296 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
298 PerlIO_apply_layers(aTHX_ fp,mode,type);
300 if (gimme == G_VOID) {
302 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
305 else if (gimme == G_SCALAR) {
306 ENTER_with_name("backtick");
308 PL_rs = &PL_sv_undef;
309 SvPVCLEAR(TARG); /* note that this preserves previous buffer */
310 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
312 LEAVE_with_name("backtick");
318 SV * const sv = newSV(79);
319 if (sv_gets(sv, fp, 0) == NULL) {
324 if (SvLEN(sv) - SvCUR(sv) > 20) {
325 SvPV_shrink_to_cur(sv);
330 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
331 TAINT; /* "I believe that this is not gratuitous!" */
334 STATUS_NATIVE_CHILD_SET(-1);
335 if (gimme == G_SCALAR)
346 GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs;
350 /* make a copy of the pattern if it is gmagical, to ensure that magic
351 * is called once and only once */
352 if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs));
354 tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL));
356 if (PL_op->op_flags & OPf_SPECIAL) {
357 /* call Perl-level glob function instead. Stack args are:
359 * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
368 /* Note that we only ever get here if File::Glob fails to load
369 * without at the same time croaking, for some reason, or if
370 * perl was built with PERL_EXTERNAL_GLOB */
372 ENTER_with_name("glob");
377 * The external globbing program may use things we can't control,
378 * so for security reasons we must assume the worst.
381 taint_proper(PL_no_security, "glob");
385 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
388 SAVESPTR(PL_rs); /* This is not permanent, either. */
389 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
392 *SvPVX(PL_rs) = '\n';
396 result = do_readline();
397 LEAVE_with_name("glob");
403 PL_last_in_gv = cGVOP_gv;
404 return do_readline();
414 do_join(TARG, &PL_sv_no, MARK, SP);
418 else if (SP == MARK) {
425 if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
428 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
429 /* well-formed exception supplied */
432 SV * const errsv = ERRSV;
435 if (SvGMAGICAL(errsv)) {
436 exsv = sv_newmortal();
437 sv_setsv_nomg(exsv, errsv);
441 else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) {
442 exsv = sv_newmortal();
443 sv_setsv_nomg(exsv, errsv);
444 sv_catpvs(exsv, "\t...caught");
447 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
450 if (SvROK(exsv) && !PL_warnhook)
451 Perl_warn(aTHX_ "%" SVf, SVfARG(exsv));
463 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
465 if (SP - MARK != 1) {
467 do_join(TARG, &PL_sv_no, MARK, SP);
475 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
476 /* well-formed exception supplied */
479 SV * const errsv = ERRSV;
483 if (sv_isobject(exsv)) {
484 HV * const stash = SvSTASH(SvRV(exsv));
485 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
487 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
488 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
495 call_sv(MUTABLE_SV(GvCV(gv)),
496 G_SCALAR|G_EVAL|G_KEEPERR);
497 exsv = sv_mortalcopy(*PL_stack_sp--);
501 else if (SvPOK(errsv) && SvCUR(errsv)) {
502 exsv = sv_mortalcopy(errsv);
503 sv_catpvs(exsv, "\t...propagated");
506 exsv = newSVpvs_flags("Died", SVs_TEMP);
510 NOT_REACHED; /* NOTREACHED */
511 return NULL; /* avoid missing return from non-void function warning */
517 Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv,
518 const MAGIC *const mg, const U32 flags, U32 argc, ...)
524 PERL_ARGS_ASSERT_TIED_METHOD;
526 /* Ensure that our flag bits do not overlap. */
527 STATIC_ASSERT_STMT((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
528 STATIC_ASSERT_STMT((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
529 STATIC_ASSERT_STMT((TIED_METHOD_SAY & G_WANT) == 0);
531 PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
532 PUSHSTACKi(PERLSI_MAGIC);
533 /* extend for object + args. If argc might wrap/truncate when cast
534 * to SSize_t and incremented, set to -1, which will trigger a panic in
536 * The weird way this is written is because g++ is dumb enough to
537 * warn "comparison is always false" on something like:
539 * sizeof(a) >= sizeof(b) && a >= B_t_MAX -1
541 * (where the LH condition is false)
544 (argc > (sizeof(argc) >= sizeof(SSize_t) ? SSize_t_MAX - 1 : argc))
545 ? -1 : (SSize_t)argc + 1;
546 EXTEND(SP, extend_size);
548 PUSHs(SvTIED_obj(sv, mg));
549 if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
550 Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
554 const U32 mortalize_not_needed
555 = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
557 va_start(args, argc);
559 SV *const arg = va_arg(args, SV *);
560 if(mortalize_not_needed)
569 ENTER_with_name("call_tied_method");
570 if (flags & TIED_METHOD_SAY) {
571 /* local $\ = "\n" */
572 SAVEGENERICSV(PL_ors_sv);
573 PL_ors_sv = newSVpvs("\n");
575 ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED);
580 if (ret_args) { /* copy results back to original stack */
581 EXTEND(sp, ret_args);
582 Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
586 LEAVE_with_name("call_tied_method");
590 #define tied_method0(a,b,c,d) \
591 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
592 #define tied_method1(a,b,c,d,e) \
593 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
594 #define tied_method2(a,b,c,d,e,f) \
595 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
608 GV * const gv = MUTABLE_GV(*++MARK);
610 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
611 DIE(aTHX_ PL_no_usym, "filehandle");
613 if ((io = GvIOp(gv))) {
615 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
618 Perl_croak(aTHX_ "Cannot open %" HEKf " as a filehandle: it is already open as a dirhandle",
619 HEKfARG(GvENAME_HEK(gv)));
621 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
623 /* Method's args are same as ours ... */
624 /* ... except handle is replaced by the object */
625 return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg,
626 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
638 tmps = SvPV_const(sv, len);
639 ok = do_open6(gv, tmps, len, NULL, MARK+1, (SP-MARK));
642 PUSHi( (I32)PL_forkprocess );
643 else if (PL_forkprocess == 0) /* we are a new child */
653 /* pp_coreargs pushes a NULL to indicate no args passed to
656 MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
662 IO * const io = GvIO(gv);
664 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
666 return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg);
670 PUSHs(boolSV(do_close(gv, TRUE)));
682 GV * const wgv = MUTABLE_GV(POPs);
683 GV * const rgv = MUTABLE_GV(POPs);
687 do_close(rgv, FALSE);
691 do_close(wgv, FALSE);
693 if (PerlProc_pipe(fd) < 0)
696 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r" PIPE_OPEN_MODE);
697 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w" PIPE_OPEN_MODE);
698 IoOFP(rstio) = IoIFP(rstio);
699 IoIFP(wstio) = IoOFP(wstio);
700 IoTYPE(rstio) = IoTYPE_RDONLY;
701 IoTYPE(wstio) = IoTYPE_WRONLY;
703 if (!IoIFP(rstio) || !IoOFP(wstio)) {
705 PerlIO_close(IoIFP(rstio));
707 PerlLIO_close(fd[0]);
709 PerlIO_close(IoOFP(wstio));
711 PerlLIO_close(fd[1]);
714 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
715 /* ensure close-on-exec */
716 if ((fd[0] > PL_maxsysfd && fcntl(fd[0], F_SETFD, FD_CLOEXEC) < 0) ||
717 (fd[1] > PL_maxsysfd && fcntl(fd[1], F_SETFD, FD_CLOEXEC) < 0))
725 DIE(aTHX_ PL_no_func, "pipe");
739 gv = MUTABLE_GV(POPs);
743 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
745 return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg);
748 if (io && IoDIRP(io)) {
749 #if defined(HAS_DIRFD) || defined(HAS_DIR_DD_FD)
750 PUSHi(my_dirfd(IoDIRP(io)));
752 #elif defined(ENOTSUP)
753 errno = ENOTSUP; /* Operation not supported */
755 #elif defined(EOPNOTSUPP)
756 errno = EOPNOTSUPP; /* Operation not supported on socket */
759 errno = EINVAL; /* Invalid argument */
764 if (!io || !(fp = IoIFP(io))) {
765 /* Can't do this because people seem to do things like
766 defined(fileno($foo)) to check whether $foo is a valid fh.
773 PUSHi(PerlIO_fileno(fp));
784 if (MAXARG < 1 || (!TOPs && !POPs)) {
785 anum = PerlLIO_umask(022);
786 /* setting it to 022 between the two calls to umask avoids
787 * to have a window where the umask is set to 0 -- meaning
788 * that another thread could create world-writeable files. */
790 (void)PerlLIO_umask(anum);
793 anum = PerlLIO_umask(POPi);
794 TAINT_PROPER("umask");
797 /* Only DIE if trying to restrict permissions on "user" (self).
798 * Otherwise it's harmless and more useful to just return undef
799 * since 'group' and 'other' concepts probably don't exist here. */
800 if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
801 DIE(aTHX_ "umask not implemented");
802 XPUSHs(&PL_sv_undef);
821 gv = MUTABLE_GV(POPs);
825 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
827 /* This takes advantage of the implementation of the varargs
828 function, which I don't think that the optimiser will be able to
829 figure out. Although, as it's a static function, in theory it
831 return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg,
832 G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
833 discp ? 1 : 0, discp);
837 if (!io || !(fp = IoIFP(io))) {
839 SETERRNO(EBADF,RMS_IFI);
846 const char *d = NULL;
849 d = SvPV_const(discp, len);
850 mode = mode_from_discipline(d, len);
851 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
852 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
853 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
874 const I32 markoff = MARK - PL_stack_base;
875 const char *methname;
876 int how = PERL_MAGIC_tied;
880 switch(SvTYPE(varsv)) {
884 methname = "TIEHASH";
885 if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
886 HvLAZYDEL_off(varsv);
887 hv_free_ent((HV *)varsv, entry);
889 HvEITER_set(MUTABLE_HV(varsv), 0);
893 methname = "TIEARRAY";
894 if (!AvREAL(varsv)) {
896 Perl_croak(aTHX_ "Cannot tie unreifiable array");
897 av_clear((AV *)varsv);
904 if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
905 methname = "TIEHANDLE";
906 how = PERL_MAGIC_tiedscalar;
907 /* For tied filehandles, we apply tiedscalar magic to the IO
908 slot of the GP rather than the GV itself. AMS 20010812 */
910 GvIOp(varsv) = newIO();
911 varsv = MUTABLE_SV(GvIOp(varsv));
914 if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
915 vivify_defelem(varsv);
916 varsv = LvTARG(varsv);
920 methname = "TIESCALAR";
921 how = PERL_MAGIC_tiedscalar;
925 if (sv_isobject(*MARK)) { /* Calls GET magic. */
926 ENTER_with_name("call_TIE");
927 PUSHSTACKi(PERLSI_MAGIC);
929 EXTEND(SP,(I32)items);
933 call_method(methname, G_SCALAR);
936 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
937 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
938 * wrong error message, and worse case, supreme action at a distance.
939 * (Sorry obfuscation writers. You're not going to be given this one.)
941 stash = gv_stashsv(*MARK, 0);
944 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"",
945 methname, SVfARG(*MARK));
946 else if (isGV(*MARK)) {
947 /* If the glob doesn't name an existing package, using
948 * SVfARG(*MARK) would yield "*Foo::Bar" or *main::Foo. So
949 * generate the name for the error message explicitly. */
950 SV *stashname = sv_2mortal(newSV(0));
951 gv_fullname4(stashname, (GV *) *MARK, NULL, FALSE);
952 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"",
953 methname, SVfARG(stashname));
956 SV *stashname = !SvPOK(*MARK) ? &PL_sv_no
957 : SvCUR(*MARK) ? *MARK
958 : sv_2mortal(newSVpvs("main"));
959 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\""
960 " (perhaps you forgot to load \"%" SVf "\"?)",
961 methname, SVfARG(stashname), SVfARG(stashname));
964 else if (!(gv = gv_fetchmethod(stash, methname))) {
965 /* The effective name can only be NULL for stashes that have
966 * been deleted from the symbol table, which this one can't
967 * be, since we just looked it up by name.
969 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" HEKf "\"",
970 methname, HvENAME_HEK_NN(stash));
972 ENTER_with_name("call_TIE");
973 PUSHSTACKi(PERLSI_MAGIC);
975 EXTEND(SP,(I32)items);
979 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
985 if (sv_isobject(sv)) {
986 sv_unmagic(varsv, how);
987 /* Croak if a self-tie on an aggregate is attempted. */
988 if (varsv == SvRV(sv) &&
989 (SvTYPE(varsv) == SVt_PVAV ||
990 SvTYPE(varsv) == SVt_PVHV))
992 "Self-ties of arrays and hashes are not supported");
993 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
995 LEAVE_with_name("call_TIE");
996 SP = PL_stack_base + markoff;
1002 /* also used for: pp_dbmclose() */
1009 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1010 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1012 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1015 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1016 !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
1018 if ((mg = SvTIED_mg(sv, how))) {
1019 SV * const obj = SvRV(SvTIED_obj(sv, mg));
1020 if (obj && SvSTASH(obj)) {
1021 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
1023 if (gv && isGV(gv) && (cv = GvCV(gv))) {
1025 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
1026 mXPUSHi(SvREFCNT(obj) - 1);
1028 ENTER_with_name("call_UNTIE");
1029 call_sv(MUTABLE_SV(cv), G_VOID);
1030 LEAVE_with_name("call_UNTIE");
1033 else if (mg && SvREFCNT(obj) > 1) {
1034 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
1035 "untie attempted while %" UVuf " inner references still exist",
1036 (UV)SvREFCNT(obj) - 1 ) ;
1040 sv_unmagic(sv, how) ;
1049 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1050 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1052 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1055 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1056 !(sv = defelem_target(sv, NULL))) goto ret_undef;
1058 if ((mg = SvTIED_mg(sv, how))) {
1059 SETs(SvTIED_obj(sv, mg));
1060 return NORMAL; /* PUTBACK not needed, pp_tied never moves SP */
1074 HV * const hv = MUTABLE_HV(POPs);
1075 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1076 stash = gv_stashsv(sv, 0);
1077 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1079 require_pv("AnyDBM_File.pm");
1081 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1082 DIE(aTHX_ "No dbm on this machine");
1092 mPUSHu(O_RDWR|O_CREAT);
1096 if (!SvOK(right)) right = &PL_sv_no;
1100 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1103 if (!sv_isobject(TOPs)) {
1111 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1113 if (sv_isobject(TOPs))
1118 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1119 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1136 struct timeval timebuf;
1137 struct timeval *tbuf = &timebuf;
1141 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1146 # if BYTEORDER & 0xf0000
1147 # define ORDERBYTE (0x88888888 - BYTEORDER)
1149 # define ORDERBYTE (0x4444 - BYTEORDER)
1155 for (i = 1; i <= 3; i++) {
1156 SV * const sv = svs[i] = SP[i];
1160 if (SvREADONLY(sv)) {
1161 if (!(SvPOK(sv) && SvCUR(sv) == 0))
1162 Perl_croak_no_modify();
1164 else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
1167 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1168 "Non-string passed as bitmask");
1169 if (SvGAMAGIC(sv)) {
1170 svs[i] = sv_newmortal();
1171 sv_copypv_nomg(svs[i], sv);
1174 SvPV_force_nomg_nolen(sv); /* force string conversion */
1181 /* little endians can use vecs directly */
1182 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1189 masksize = NFDBITS / NBBY;
1191 masksize = sizeof(long); /* documented int, everyone seems to use long */
1193 Zero(&fd_sets[0], 4, char*);
1196 # if SELECT_MIN_BITS == 1
1197 growsize = sizeof(fd_set);
1199 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1200 # undef SELECT_MIN_BITS
1201 # define SELECT_MIN_BITS __FD_SETSIZE
1203 /* If SELECT_MIN_BITS is greater than one we most probably will want
1204 * to align the sizes with SELECT_MIN_BITS/8 because for example
1205 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1206 * UNIX, Solaris, Darwin) the smallest quantum select() operates
1207 * on (sets/tests/clears bits) is 32 bits. */
1208 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1214 value = SvNV_nomg(sv);
1217 timebuf.tv_sec = (long)value;
1218 value -= (NV)timebuf.tv_sec;
1219 timebuf.tv_usec = (long)(value * 1000000.0);
1224 for (i = 1; i <= 3; i++) {
1226 if (!SvOK(sv) || SvCUR(sv) == 0) {
1233 Sv_Grow(sv, growsize);
1237 while (++j <= growsize) {
1241 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1243 Newx(fd_sets[i], growsize, char);
1244 for (offset = 0; offset < growsize; offset += masksize) {
1245 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1246 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1249 fd_sets[i] = SvPVX(sv);
1253 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1254 /* Can't make just the (void*) conditional because that would be
1255 * cpp #if within cpp macro, and not all compilers like that. */
1256 nfound = PerlSock_select(
1258 (Select_fd_set_t) fd_sets[1],
1259 (Select_fd_set_t) fd_sets[2],
1260 (Select_fd_set_t) fd_sets[3],
1261 (void*) tbuf); /* Workaround for compiler bug. */
1263 nfound = PerlSock_select(
1265 (Select_fd_set_t) fd_sets[1],
1266 (Select_fd_set_t) fd_sets[2],
1267 (Select_fd_set_t) fd_sets[3],
1270 for (i = 1; i <= 3; i++) {
1273 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1275 for (offset = 0; offset < growsize; offset += masksize) {
1276 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1277 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1279 Safefree(fd_sets[i]);
1282 SvSetMagicSV(SP[i], sv);
1289 if (GIMME_V == G_ARRAY && tbuf) {
1290 value = (NV)(timebuf.tv_sec) +
1291 (NV)(timebuf.tv_usec) / 1000000.0;
1296 DIE(aTHX_ "select not implemented");
1304 =for apidoc setdefout
1306 Sets C<PL_defoutgv>, the default file handle for output, to the passed in
1307 typeglob. As C<PL_defoutgv> "owns" a reference on its typeglob, the reference
1308 count of the passed in typeglob is increased by one, and the reference count
1309 of the typeglob that C<PL_defoutgv> points to is decreased by one.
1315 Perl_setdefout(pTHX_ GV *gv)
1317 GV *oldgv = PL_defoutgv;
1319 PERL_ARGS_ASSERT_SETDEFOUT;
1321 SvREFCNT_inc_simple_void_NN(gv);
1323 SvREFCNT_dec(oldgv);
1330 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1331 GV * egv = GvEGVx(PL_defoutgv);
1336 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1337 gvp = hv && HvENAME(hv)
1338 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1340 if (gvp && *gvp == egv) {
1341 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1345 mXPUSHs(newRV(MUTABLE_SV(egv)));
1349 if (!GvIO(newdefout))
1350 gv_IOadd(newdefout);
1351 setdefout(newdefout);
1360 /* pp_coreargs pushes a NULL to indicate no args passed to
1363 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1364 IO *const io = GvIO(gv);
1370 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1372 const U8 gimme = GIMME_V;
1373 Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1374 if (gimme == G_SCALAR) {
1376 SvSetMagicSV_nosteal(TARG, TOPs);
1381 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1382 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1384 SETERRNO(EBADF,RMS_IFI);
1388 sv_setpvs(TARG, " ");
1389 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1390 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1391 /* Find out how many bytes the char needs */
1392 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1395 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1396 SvCUR_set(TARG,1+len);
1400 else SvUTF8_off(TARG);
1406 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1409 const U8 gimme = GIMME_V;
1411 PERL_ARGS_ASSERT_DOFORM;
1414 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1416 cx = cx_pushblock(CXt_FORMAT, gimme, PL_stack_sp, PL_savestack_ix);
1417 cx_pushformat(cx, cv, retop, gv);
1418 if (CvDEPTH(cv) >= 2)
1419 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1420 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1422 setdefout(gv); /* locally select filehandle so $% et al work */
1439 gv = MUTABLE_GV(POPs);
1456 SV * const tmpsv = sv_newmortal();
1457 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1458 DIE(aTHX_ "Undefined format \"%" SVf "\" called", SVfARG(tmpsv));
1460 IoFLAGS(io) &= ~IOf_DIDTOP;
1461 RETURNOP(doform(cv,gv,PL_op->op_next));
1467 GV * const gv = CX_CUR()->blk_format.gv;
1468 IO * const io = GvIOp(gv);
1473 bool is_return = cBOOL(PL_op->op_type == OP_RETURN);
1475 if (is_return || !io || !(ofp = IoOFP(io)))
1478 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1479 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1481 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1482 PL_formtarget != PL_toptarget)
1486 if (!IoTOP_GV(io)) {
1489 if (!IoTOP_NAME(io)) {
1491 if (!IoFMT_NAME(io))
1492 IoFMT_NAME(io) = savepv(GvNAME(gv));
1493 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%" HEKf "_TOP",
1494 HEKfARG(GvNAME_HEK(gv))));
1495 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1496 if ((topgv && GvFORM(topgv)) ||
1497 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1498 IoTOP_NAME(io) = savesvpv(topname);
1500 IoTOP_NAME(io) = savepvs("top");
1502 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1503 if (!topgv || !GvFORM(topgv)) {
1504 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1507 IoTOP_GV(io) = topgv;
1509 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1510 I32 lines = IoLINES_LEFT(io);
1511 const char *s = SvPVX_const(PL_formtarget);
1512 const char *e = SvEND(PL_formtarget);
1513 if (lines <= 0) /* Yow, header didn't even fit!!! */
1515 while (lines-- > 0) {
1516 s = (char *) memchr(s, '\n', e - s);
1522 const STRLEN save = SvCUR(PL_formtarget);
1523 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1524 do_print(PL_formtarget, ofp);
1525 SvCUR_set(PL_formtarget, save);
1526 sv_chop(PL_formtarget, s);
1527 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1530 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1531 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1532 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1534 PL_formtarget = PL_toptarget;
1535 IoFLAGS(io) |= IOf_DIDTOP;
1537 assert(fgv); /* IoTOP_GV(io) should have been set above */
1540 SV * const sv = sv_newmortal();
1541 gv_efullname4(sv, fgv, NULL, FALSE);
1542 DIE(aTHX_ "Undefined top format \"%" SVf "\" called", SVfARG(sv));
1544 return doform(cv, gv, PL_op);
1549 assert(CxTYPE(cx) == CXt_FORMAT);
1550 SP = PL_stack_base + cx->blk_oldsp; /* ignore retval of formline */
1554 retop = cx->blk_sub.retop;
1560 /* XXX the semantics of doing 'return' in a format aren't documented.
1561 * Currently we ignore any args to 'return' and just return
1562 * a single undef in both scalar and list contexts
1564 PUSHs(&PL_sv_undef);
1565 else if (!io || !(fp = IoOFP(io))) {
1566 if (io && IoIFP(io))
1567 report_wrongway_fh(gv, '<');
1573 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1574 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1576 if (!do_print(PL_formtarget, fp))
1579 FmLINES(PL_formtarget) = 0;
1580 SvCUR_set(PL_formtarget, 0);
1581 *SvEND(PL_formtarget) = '\0';
1582 if (IoFLAGS(io) & IOf_FLUSH)
1583 (void)PerlIO_flush(fp);
1587 PL_formtarget = PL_bodytarget;
1593 dSP; dMARK; dORIGMARK;
1597 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1598 IO *const io = GvIO(gv);
1600 /* Treat empty list as "" */
1601 if (MARK == SP) XPUSHs(&PL_sv_no);
1604 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1606 if (MARK == ORIGMARK) {
1609 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1612 return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1614 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1621 SETERRNO(EBADF,RMS_IFI);
1624 else if (!(fp = IoOFP(io))) {
1626 report_wrongway_fh(gv, '<');
1627 else if (ckWARN(WARN_CLOSED))
1629 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1633 SV *sv = sv_newmortal();
1634 do_sprintf(sv, SP - MARK, MARK + 1);
1635 if (!do_print(sv, fp))
1638 if (IoFLAGS(io) & IOf_FLUSH)
1639 if (PerlIO_flush(fp) == EOF)
1648 PUSHs(&PL_sv_undef);
1655 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1656 const int mode = POPi;
1657 SV * const sv = POPs;
1658 GV * const gv = MUTABLE_GV(POPs);
1661 /* Need TIEHANDLE method ? */
1662 const char * const tmps = SvPV_const(sv, len);
1663 if (do_open_raw(gv, tmps, len, mode, perm, NULL)) {
1664 IoLINES(GvIOp(gv)) = 0;
1668 PUSHs(&PL_sv_undef);
1674 /* also used for: pp_read() and pp_recv() (where supported) */
1678 dSP; dMARK; dORIGMARK; dTARGET;
1692 bool charstart = FALSE;
1693 STRLEN charskip = 0;
1695 GV * const gv = MUTABLE_GV(*++MARK);
1698 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1699 && gv && (io = GvIO(gv)) )
1701 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1703 return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1704 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1714 length = SvIVx(*++MARK);
1716 DIE(aTHX_ "Negative length");
1719 offset = SvIVx(*++MARK);
1723 if (!io || !IoIFP(io)) {
1725 SETERRNO(EBADF,RMS_IFI);
1729 /* Note that fd can here validly be -1, don't check it yet. */
1730 fd = PerlIO_fileno(IoIFP(io));
1732 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1733 if (PL_op->op_type == OP_SYSREAD || PL_op->op_type == OP_RECV) {
1734 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1735 "%s() is deprecated on :utf8 handles. "
1736 "This will be a fatal error in Perl 5.30",
1739 buffer = SvPVutf8_force(bufsv, blen);
1740 /* UTF-8 may not have been set if they are all low bytes */
1745 buffer = SvPV_force(bufsv, blen);
1746 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1748 if (DO_UTF8(bufsv)) {
1749 blen = sv_len_utf8_nomg(bufsv);
1758 if (PL_op->op_type == OP_RECV) {
1759 Sock_size_t bufsize;
1760 char namebuf[MAXPATHLEN];
1762 SETERRNO(EBADF,SS_IVCHAN);
1765 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1766 bufsize = sizeof (struct sockaddr_in);
1768 bufsize = sizeof namebuf;
1770 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1774 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1775 /* 'offset' means 'flags' here */
1776 count = PerlSock_recvfrom(fd, buffer, length, offset,
1777 (struct sockaddr *)namebuf, &bufsize);
1780 /* MSG_TRUNC can give oversized count; quietly lose it */
1783 SvCUR_set(bufsv, count);
1784 *SvEND(bufsv) = '\0';
1785 (void)SvPOK_only(bufsv);
1789 /* This should not be marked tainted if the fp is marked clean */
1790 if (!(IoFLAGS(io) & IOf_UNTAINT))
1791 SvTAINTED_on(bufsv);
1793 #if defined(__CYGWIN__)
1794 /* recvfrom() on cygwin doesn't set bufsize at all for
1795 connected sockets, leaving us with trash in the returned
1796 name, so use the same test as the Win32 code to check if it
1797 wasn't set, and set it [perl #118843] */
1798 if (bufsize == sizeof namebuf)
1801 sv_setpvn(TARG, namebuf, bufsize);
1807 if (-offset > (SSize_t)blen)
1808 DIE(aTHX_ "Offset outside string");
1811 if (DO_UTF8(bufsv)) {
1812 /* convert offset-as-chars to offset-as-bytes */
1813 if (offset >= (SSize_t)blen)
1814 offset += SvCUR(bufsv) - blen;
1816 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1820 /* Reestablish the fd in case it shifted from underneath us. */
1821 fd = PerlIO_fileno(IoIFP(io));
1823 orig_size = SvCUR(bufsv);
1824 /* Allocating length + offset + 1 isn't perfect in the case of reading
1825 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1827 (should be 2 * length + offset + 1, or possibly something longer if
1828 IN_ENCODING Is true) */
1829 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1830 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1831 Zero(buffer+orig_size, offset-orig_size, char);
1833 buffer = buffer + offset;
1835 read_target = bufsv;
1837 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1838 concatenate it to the current buffer. */
1840 /* Truncate the existing buffer to the start of where we will be
1842 SvCUR_set(bufsv, offset);
1844 read_target = sv_newmortal();
1845 SvUPGRADE(read_target, SVt_PV);
1846 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1849 if (PL_op->op_type == OP_SYSREAD) {
1850 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1851 if (IoTYPE(io) == IoTYPE_SOCKET) {
1853 SETERRNO(EBADF,SS_IVCHAN);
1857 count = PerlSock_recv(fd, buffer, length, 0);
1863 SETERRNO(EBADF,RMS_IFI);
1867 count = PerlLIO_read(fd, buffer, length);
1872 count = PerlIO_read(IoIFP(io), buffer, length);
1873 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1874 if (count == 0 && PerlIO_error(IoIFP(io)))
1878 if (IoTYPE(io) == IoTYPE_WRONLY)
1879 report_wrongway_fh(gv, '>');
1882 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1883 *SvEND(read_target) = '\0';
1884 (void)SvPOK_only(read_target);
1885 if (fp_utf8 && !IN_BYTES) {
1886 /* Look at utf8 we got back and count the characters */
1887 const char *bend = buffer + count;
1888 while (buffer < bend) {
1890 skip = UTF8SKIP(buffer);
1893 if (buffer - charskip + skip > bend) {
1894 /* partial character - try for rest of it */
1895 length = skip - (bend-buffer);
1896 offset = bend - SvPVX_const(bufsv);
1908 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1909 provided amount read (count) was what was requested (length)
1911 if (got < wanted && count == length) {
1912 length = wanted - got;
1913 offset = bend - SvPVX_const(bufsv);
1916 /* return value is character count */
1920 else if (buffer_utf8) {
1921 /* Let svcatsv upgrade the bytes we read in to utf8.
1922 The buffer is a mortal so will be freed soon. */
1923 sv_catsv_nomg(bufsv, read_target);
1926 /* This should not be marked tainted if the fp is marked clean */
1927 if (!(IoFLAGS(io) & IOf_UNTAINT))
1928 SvTAINTED_on(bufsv);
1939 /* also used for: pp_send() where defined */
1943 dSP; dMARK; dORIGMARK; dTARGET;
1948 STRLEN orig_blen_bytes;
1949 const int op_type = PL_op->op_type;
1952 GV *const gv = MUTABLE_GV(*++MARK);
1953 IO *const io = GvIO(gv);
1956 if (op_type == OP_SYSWRITE && io) {
1957 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1959 if (MARK == SP - 1) {
1961 mXPUSHi(sv_len(sv));
1965 return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1966 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1976 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1978 if (io && IoIFP(io))
1979 report_wrongway_fh(gv, '<');
1982 SETERRNO(EBADF,RMS_IFI);
1985 fd = PerlIO_fileno(IoIFP(io));
1987 SETERRNO(EBADF,SS_IVCHAN);
1992 /* Do this first to trigger any overloading. */
1993 buffer = SvPV_const(bufsv, blen);
1994 orig_blen_bytes = blen;
1995 doing_utf8 = DO_UTF8(bufsv);
1997 if (PerlIO_isutf8(IoIFP(io))) {
1998 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
1999 "%s() is deprecated on :utf8 handles. "
2000 "This will be a fatal error in Perl 5.30",
2002 if (!SvUTF8(bufsv)) {
2003 /* We don't modify the original scalar. */
2004 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
2005 buffer = (char *) tmpbuf;
2009 else if (doing_utf8) {
2010 STRLEN tmplen = blen;
2011 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
2014 buffer = (char *) tmpbuf;
2018 assert((char *)result == buffer);
2019 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
2024 if (op_type == OP_SEND) {
2025 const int flags = SvIVx(*++MARK);
2028 char * const sockbuf = SvPVx(*++MARK, mlen);
2029 retval = PerlSock_sendto(fd, buffer, blen,
2030 flags, (struct sockaddr *)sockbuf, mlen);
2033 retval = PerlSock_send(fd, buffer, blen, flags);
2039 Size_t length = 0; /* This length is in characters. */
2045 /* The SV is bytes, and we've had to upgrade it. */
2046 blen_chars = orig_blen_bytes;
2048 /* The SV really is UTF-8. */
2049 /* Don't call sv_len_utf8 on a magical or overloaded
2050 scalar, as we might get back a different result. */
2051 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
2058 length = blen_chars;
2060 #if Size_t_size > IVSIZE
2061 length = (Size_t)SvNVx(*++MARK);
2063 length = (Size_t)SvIVx(*++MARK);
2065 if ((SSize_t)length < 0) {
2067 DIE(aTHX_ "Negative length");
2072 offset = SvIVx(*++MARK);
2074 if (-offset > (IV)blen_chars) {
2076 DIE(aTHX_ "Offset outside string");
2078 offset += blen_chars;
2079 } else if (offset > (IV)blen_chars) {
2081 DIE(aTHX_ "Offset outside string");
2085 if (length > blen_chars - offset)
2086 length = blen_chars - offset;
2088 /* Here we convert length from characters to bytes. */
2089 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
2090 /* Either we had to convert the SV, or the SV is magical, or
2091 the SV has overloading, in which case we can't or mustn't
2092 or mustn't call it again. */
2094 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
2095 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
2097 /* It's a real UTF-8 SV, and it's not going to change under
2098 us. Take advantage of any cache. */
2100 I32 len_I32 = length;
2102 /* Convert the start and end character positions to bytes.
2103 Remember that the second argument to sv_pos_u2b is relative
2105 sv_pos_u2b(bufsv, &start, &len_I32);
2112 buffer = buffer+offset;
2114 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2115 if (IoTYPE(io) == IoTYPE_SOCKET) {
2116 retval = PerlSock_send(fd, buffer, length, 0);
2121 /* See the note at doio.c:do_print about filesize limits. --jhi */
2122 retval = PerlLIO_write(fd, buffer, length);
2130 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2133 #if Size_t_size > IVSIZE
2153 * in Perl 5.12 and later, the additional parameter is a bitmask:
2156 * 2 = eof() <- ARGV magic
2158 * I'll rely on the compiler's trace flow analysis to decide whether to
2159 * actually assign this out here, or punt it into the only block where it is
2160 * used. Doing it out here is DRY on the condition logic.
2165 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2171 if (PL_op->op_flags & OPf_SPECIAL) {
2172 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2176 gv = PL_last_in_gv; /* eof */
2184 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2185 return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2188 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2189 if (io && !IoIFP(io)) {
2190 if ((IoFLAGS(io) & IOf_START) && av_tindex(GvAVn(gv)) < 0) {
2193 IoFLAGS(io) &= ~IOf_START;
2194 do_open6(gv, "-", 1, NULL, NULL, 0);
2202 *svp = newSVpvs("-");
2204 else if (!nextargv(gv, FALSE))
2209 PUSHs(boolSV(do_eof(gv)));
2219 if (MAXARG != 0 && (TOPs || POPs))
2220 PL_last_in_gv = MUTABLE_GV(POPs);
2227 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2229 return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2234 SETERRNO(EBADF,RMS_IFI);
2239 #if LSEEKSIZE > IVSIZE
2240 PUSHn( do_tell(gv) );
2242 PUSHi( do_tell(gv) );
2248 /* also used for: pp_seek() */
2253 const int whence = POPi;
2254 #if LSEEKSIZE > IVSIZE
2255 const Off_t offset = (Off_t)SvNVx(POPs);
2257 const Off_t offset = (Off_t)SvIVx(POPs);
2260 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2261 IO *const io = GvIO(gv);
2264 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2266 #if LSEEKSIZE > IVSIZE
2267 SV *const offset_sv = newSVnv((NV) offset);
2269 SV *const offset_sv = newSViv(offset);
2272 return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2277 if (PL_op->op_type == OP_SEEK)
2278 PUSHs(boolSV(do_seek(gv, offset, whence)));
2280 const Off_t sought = do_sysseek(gv, offset, whence);
2282 PUSHs(&PL_sv_undef);
2284 SV* const sv = sought ?
2285 #if LSEEKSIZE > IVSIZE
2290 : newSVpvn(zero_but_true, ZBTLEN);
2300 /* There seems to be no consensus on the length type of truncate()
2301 * and ftruncate(), both off_t and size_t have supporters. In
2302 * general one would think that when using large files, off_t is
2303 * at least as wide as size_t, so using an off_t should be okay. */
2304 /* XXX Configure probe for the length type of *truncate() needed XXX */
2307 #if Off_t_size > IVSIZE
2312 /* Checking for length < 0 is problematic as the type might or
2313 * might not be signed: if it is not, clever compilers will moan. */
2314 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2317 SV * const sv = POPs;
2322 if (PL_op->op_flags & OPf_SPECIAL
2323 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2324 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2331 TAINT_PROPER("truncate");
2332 if (!(fp = IoIFP(io))) {
2336 int fd = PerlIO_fileno(fp);
2338 SETERRNO(EBADF,RMS_IFI);
2342 SETERRNO(EINVAL, LIB_INVARG);
2347 if (ftruncate(fd, len) < 0)
2349 if (my_chsize(fd, len) < 0)
2357 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2358 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2359 goto do_ftruncate_io;
2362 const char * const name = SvPV_nomg_const_nolen(sv);
2363 TAINT_PROPER("truncate");
2365 if (truncate(name, len) < 0)
2372 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
2373 mode |= O_LARGEFILE; /* Transparently largefiley. */
2376 /* On open(), the Win32 CRT tries to seek around text
2377 * files using 32-bit offsets, which causes the open()
2378 * to fail on large files, so open in binary mode.
2382 tmpfd = PerlLIO_open(name, mode);
2387 if (my_chsize(tmpfd, len) < 0)
2389 PerlLIO_close(tmpfd);
2398 SETERRNO(EBADF,RMS_IFI);
2404 /* also used for: pp_fcntl() */
2409 SV * const argsv = POPs;
2410 const unsigned int func = POPu;
2412 GV * const gv = MUTABLE_GV(POPs);
2413 IO * const io = GvIOn(gv);
2419 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2423 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2426 s = SvPV_force(argsv, len);
2427 need = IOCPARM_LEN(func);
2429 s = Sv_Grow(argsv, need + 1);
2430 SvCUR_set(argsv, need);
2433 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2436 retval = SvIV(argsv);
2437 s = INT2PTR(char*,retval); /* ouch */
2440 optype = PL_op->op_type;
2441 TAINT_PROPER(PL_op_desc[optype]);
2443 if (optype == OP_IOCTL)
2445 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2447 DIE(aTHX_ "ioctl is not implemented");
2451 DIE(aTHX_ "fcntl is not implemented");
2452 #elif defined(OS2) && defined(__EMX__)
2453 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2455 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2458 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2460 if (s[SvCUR(argsv)] != 17)
2461 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2463 s[SvCUR(argsv)] = 0; /* put our null back */
2464 SvSETMAGIC(argsv); /* Assume it has changed */
2473 PUSHp(zero_but_true, ZBTLEN);
2484 const int argtype = POPi;
2485 GV * const gv = MUTABLE_GV(POPs);
2486 IO *const io = GvIO(gv);
2487 PerlIO *const fp = io ? IoIFP(io) : NULL;
2489 /* XXX Looks to me like io is always NULL at this point */
2491 (void)PerlIO_flush(fp);
2492 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2497 SETERRNO(EBADF,RMS_IFI);
2502 DIE(aTHX_ PL_no_func, "flock");
2513 const int protocol = POPi;
2514 const int type = POPi;
2515 const int domain = POPi;
2516 GV * const gv = MUTABLE_GV(POPs);
2517 IO * const io = GvIOn(gv);
2521 do_close(gv, FALSE);
2523 TAINT_PROPER("socket");
2524 fd = PerlSock_socket(domain, type, protocol);
2528 IoIFP(io) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2529 IoOFP(io) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE);
2530 IoTYPE(io) = IoTYPE_SOCKET;
2531 if (!IoIFP(io) || !IoOFP(io)) {
2532 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2533 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2534 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2537 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2538 /* ensure close-on-exec */
2539 if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0)
2549 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2552 const int protocol = POPi;
2553 const int type = POPi;
2554 const int domain = POPi;
2556 GV * const gv2 = MUTABLE_GV(POPs);
2557 IO * const io2 = GvIOn(gv2);
2558 GV * const gv1 = MUTABLE_GV(POPs);
2559 IO * const io1 = GvIOn(gv1);
2562 do_close(gv1, FALSE);
2564 do_close(gv2, FALSE);
2566 TAINT_PROPER("socketpair");
2567 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2569 IoIFP(io1) = PerlIO_fdopen(fd[0], "r" SOCKET_OPEN_MODE);
2570 IoOFP(io1) = PerlIO_fdopen(fd[0], "w" SOCKET_OPEN_MODE);
2571 IoTYPE(io1) = IoTYPE_SOCKET;
2572 IoIFP(io2) = PerlIO_fdopen(fd[1], "r" SOCKET_OPEN_MODE);
2573 IoOFP(io2) = PerlIO_fdopen(fd[1], "w" SOCKET_OPEN_MODE);
2574 IoTYPE(io2) = IoTYPE_SOCKET;
2575 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2576 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2577 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2578 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2579 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2580 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2581 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2584 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2585 /* ensure close-on-exec */
2586 if ((fd[0] > PL_maxsysfd && fcntl(fd[0], F_SETFD, FD_CLOEXEC) < 0) ||
2587 (fd[1] > PL_maxsysfd && fcntl(fd[1], F_SETFD, FD_CLOEXEC) < 0))
2593 DIE(aTHX_ PL_no_sock_func, "socketpair");
2599 /* also used for: pp_connect() */
2604 SV * const addrsv = POPs;
2605 /* OK, so on what platform does bind modify addr? */
2607 GV * const gv = MUTABLE_GV(POPs);
2608 IO * const io = GvIOn(gv);
2615 fd = PerlIO_fileno(IoIFP(io));
2619 addr = SvPV_const(addrsv, len);
2620 op_type = PL_op->op_type;
2621 TAINT_PROPER(PL_op_desc[op_type]);
2622 if ((op_type == OP_BIND
2623 ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
2624 : PerlSock_connect(fd, (struct sockaddr *)addr, len))
2632 SETERRNO(EBADF,SS_IVCHAN);
2639 const int backlog = POPi;
2640 GV * const gv = MUTABLE_GV(POPs);
2641 IO * const io = GvIOn(gv);
2646 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2653 SETERRNO(EBADF,SS_IVCHAN);
2661 char namebuf[MAXPATHLEN];
2662 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2663 Sock_size_t len = sizeof (struct sockaddr_in);
2665 Sock_size_t len = sizeof namebuf;
2667 GV * const ggv = MUTABLE_GV(POPs);
2668 GV * const ngv = MUTABLE_GV(POPs);
2671 IO * const gstio = GvIO(ggv);
2672 if (!gstio || !IoIFP(gstio))
2676 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2679 /* Some platforms indicate zero length when an AF_UNIX client is
2680 * not bound. Simulate a non-zero-length sockaddr structure in
2682 namebuf[0] = 0; /* sun_len */
2683 namebuf[1] = AF_UNIX; /* sun_family */
2691 do_close(ngv, FALSE);
2692 IoIFP(nstio) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE);
2693 IoOFP(nstio) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE);
2694 IoTYPE(nstio) = IoTYPE_SOCKET;
2695 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2696 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2697 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2698 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2701 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
2702 /* ensure close-on-exec */
2703 if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0)
2707 #ifdef __SCO_VERSION__
2708 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2711 PUSHp(namebuf, len);
2715 report_evil_fh(ggv);
2716 SETERRNO(EBADF,SS_IVCHAN);
2726 const int how = POPi;
2727 GV * const gv = MUTABLE_GV(POPs);
2728 IO * const io = GvIOn(gv);
2733 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2738 SETERRNO(EBADF,SS_IVCHAN);
2743 /* also used for: pp_gsockopt() */
2748 const int optype = PL_op->op_type;
2749 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2750 const unsigned int optname = (unsigned int) POPi;
2751 const unsigned int lvl = (unsigned int) POPi;
2752 GV * const gv = MUTABLE_GV(POPs);
2753 IO * const io = GvIOn(gv);
2760 fd = PerlIO_fileno(IoIFP(io));
2766 (void)SvPOK_only(sv);
2770 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2773 /* XXX Configure test: does getsockopt set the length properly? */
2782 #if defined(__SYMBIAN32__)
2783 # define SETSOCKOPT_OPTION_VALUE_T void *
2785 # define SETSOCKOPT_OPTION_VALUE_T const char *
2787 /* XXX TODO: We need to have a proper type (a Configure probe,
2788 * etc.) for what the C headers think of the third argument of
2789 * setsockopt(), the option_value read-only buffer: is it
2790 * a "char *", or a "void *", const or not. Some compilers
2791 * don't take kindly to e.g. assuming that "char *" implicitly
2792 * promotes to a "void *", or to explicitly promoting/demoting
2793 * consts to non/vice versa. The "const void *" is the SUS
2794 * definition, but that does not fly everywhere for the above
2796 SETSOCKOPT_OPTION_VALUE_T buf;
2800 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2804 aint = (int)SvIV(sv);
2805 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2808 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2818 SETERRNO(EBADF,SS_IVCHAN);
2825 /* also used for: pp_getsockname() */
2830 const int optype = PL_op->op_type;
2831 GV * const gv = MUTABLE_GV(POPs);
2832 IO * const io = GvIOn(gv);
2840 sv = sv_2mortal(newSV(257));
2841 (void)SvPOK_only(sv);
2845 fd = PerlIO_fileno(IoIFP(io));
2849 case OP_GETSOCKNAME:
2850 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2853 case OP_GETPEERNAME:
2854 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2856 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2858 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";
2859 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2860 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2861 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2862 sizeof(u_short) + sizeof(struct in_addr))) {
2869 #ifdef BOGUS_GETNAME_RETURN
2870 /* Interactive Unix, getpeername() and getsockname()
2871 does not return valid namelen */
2872 if (len == BOGUS_GETNAME_RETURN)
2873 len = sizeof(struct sockaddr);
2882 SETERRNO(EBADF,SS_IVCHAN);
2891 /* also used for: pp_lstat() */
2902 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2903 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2904 if (PL_op->op_type == OP_LSTAT) {
2905 if (gv != PL_defgv) {
2906 do_fstat_warning_check:
2907 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2908 "lstat() on filehandle%s%" SVf,
2911 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2913 } else if (PL_laststype != OP_LSTAT)
2914 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2915 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2918 if (gv == PL_defgv) {
2919 if (PL_laststatval < 0)
2920 SETERRNO(EBADF,RMS_IFI);
2923 PL_laststype = OP_STAT;
2924 PL_statgv = gv ? gv : (GV *)io;
2925 SvPVCLEAR(PL_statname);
2931 int fd = PerlIO_fileno(IoIFP(io));
2934 PL_laststatval = -1;
2935 SETERRNO(EBADF,RMS_IFI);
2937 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
2939 } else if (IoDIRP(io)) {
2941 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2944 PL_laststatval = -1;
2945 SETERRNO(EBADF,RMS_IFI);
2949 PL_laststatval = -1;
2950 SETERRNO(EBADF,RMS_IFI);
2954 if (PL_laststatval < 0) {
2962 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2963 io = MUTABLE_IO(SvRV(sv));
2964 if (PL_op->op_type == OP_LSTAT)
2965 goto do_fstat_warning_check;
2966 goto do_fstat_have_io;
2968 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2969 temp = SvPV_nomg_const(sv, len);
2970 sv_setpv(PL_statname, temp);
2972 PL_laststype = PL_op->op_type;
2973 file = SvPV_nolen_const(PL_statname);
2974 if (!IS_SAFE_PATHNAME(temp, len, OP_NAME(PL_op))) {
2975 PL_laststatval = -1;
2977 else if (PL_op->op_type == OP_LSTAT)
2978 PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
2980 PL_laststatval = PerlLIO_stat(file, &PL_statcache);
2981 if (PL_laststatval < 0) {
2982 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
2983 /* PL_warn_nl is constant */
2984 GCC_DIAG_IGNORE(-Wformat-nonliteral);
2985 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2993 if (gimme != G_ARRAY) {
2994 if (gimme != G_VOID)
2995 XPUSHs(boolSV(max));
3001 mPUSHi(PL_statcache.st_dev);
3004 * We try to represent st_ino as a native IV or UV where
3005 * possible, but fall back to a decimal string where
3006 * necessary. The code to generate these decimal strings
3007 * is quite obtuse, because (a) we're portable to non-POSIX
3008 * platforms where st_ino might be signed; (b) we didn't
3009 * necessarily detect at Configure time whether st_ino is
3010 * signed; (c) we're portable to non-POSIX platforms where
3011 * ino_t isn't defined, so have no name for the type of
3012 * st_ino; and (d) sprintf() doesn't necessarily support
3013 * integers as large as st_ino.
3017 CLANG_DIAG_IGNORE(-Wtautological-compare);
3018 GCC_DIAG_IGNORE(-Wtype-limits);
3019 neg = PL_statcache.st_ino < 0;
3023 s.st_ino = (IV)PL_statcache.st_ino;
3024 if (LIKELY(s.st_ino == PL_statcache.st_ino)) {
3027 char buf[sizeof(s.st_ino)*3+1], *p;
3028 s.st_ino = PL_statcache.st_ino;
3029 for (p = buf + sizeof(buf); p != buf+1; ) {
3031 t.st_ino = s.st_ino / 10;
3032 *--p = '0' + (int)(t.st_ino*10 - s.st_ino);
3033 s.st_ino = t.st_ino;
3038 mPUSHp(p, buf+sizeof(buf) - p);
3041 s.st_ino = (UV)PL_statcache.st_ino;
3042 if (LIKELY(s.st_ino == PL_statcache.st_ino)) {
3045 char buf[sizeof(s.st_ino)*3], *p;
3046 s.st_ino = PL_statcache.st_ino;
3047 for (p = buf + sizeof(buf); p != buf; ) {
3049 t.st_ino = s.st_ino / 10;
3050 *--p = '0' + (int)(s.st_ino - t.st_ino*10);
3051 s.st_ino = t.st_ino;
3055 mPUSHp(p, buf+sizeof(buf) - p);
3059 mPUSHu(PL_statcache.st_mode);
3060 mPUSHu(PL_statcache.st_nlink);
3062 sv_setuid(PUSHmortal, PL_statcache.st_uid);
3063 sv_setgid(PUSHmortal, PL_statcache.st_gid);
3065 #ifdef USE_STAT_RDEV
3066 mPUSHi(PL_statcache.st_rdev);
3068 PUSHs(newSVpvs_flags("", SVs_TEMP));
3070 #if Off_t_size > IVSIZE
3071 mPUSHn(PL_statcache.st_size);
3073 mPUSHi(PL_statcache.st_size);
3076 mPUSHn(PL_statcache.st_atime);
3077 mPUSHn(PL_statcache.st_mtime);
3078 mPUSHn(PL_statcache.st_ctime);
3080 mPUSHi(PL_statcache.st_atime);
3081 mPUSHi(PL_statcache.st_mtime);
3082 mPUSHi(PL_statcache.st_ctime);
3084 #ifdef USE_STAT_BLOCKS
3085 mPUSHu(PL_statcache.st_blksize);
3086 mPUSHu(PL_statcache.st_blocks);
3088 PUSHs(newSVpvs_flags("", SVs_TEMP));
3089 PUSHs(newSVpvs_flags("", SVs_TEMP));
3095 /* All filetest ops avoid manipulating the perl stack pointer in their main
3096 bodies (since commit d2c4d2d1e22d3125), and return using either
3097 S_ft_return_false() or S_ft_return_true(). These two helper functions are
3098 the only two which manipulate the perl stack. To ensure that no stack
3099 manipulation macros are used, the filetest ops avoid defining a local copy
3100 of the stack pointer with dSP. */
3102 /* If the next filetest is stacked up with this one
3103 (PL_op->op_private & OPpFT_STACKING), we leave
3104 the original argument on the stack for success,
3105 and skip the stacked operators on failure.
3106 The next few macros/functions take care of this.
3110 S_ft_return_false(pTHX_ SV *ret) {
3114 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
3118 if (PL_op->op_private & OPpFT_STACKING) {
3119 while (OP_IS_FILETEST(next->op_type)
3120 && next->op_private & OPpFT_STACKED)
3121 next = next->op_next;
3126 PERL_STATIC_INLINE OP *
3127 S_ft_return_true(pTHX_ SV *ret) {
3129 if (PL_op->op_flags & OPf_REF)
3130 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
3131 else if (!(PL_op->op_private & OPpFT_STACKING))
3137 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
3138 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
3139 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
3141 #define tryAMAGICftest_MG(chr) STMT_START { \
3142 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
3143 && PL_op->op_flags & OPf_KIDS) { \
3144 OP *next = S_try_amagic_ftest(aTHX_ chr); \
3145 if (next) return next; \
3150 S_try_amagic_ftest(pTHX_ char chr) {
3151 SV *const arg = *PL_stack_sp;
3154 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
3158 const char tmpchr = chr;
3159 SV * const tmpsv = amagic_call(arg,
3160 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
3161 ftest_amg, AMGf_unary);
3166 return SvTRUE(tmpsv)
3167 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
3173 /* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec()
3179 /* Not const, because things tweak this below. Not bool, because there's
3180 no guarantee that OPpFT_ACCESS is <= CHAR_MAX */
3181 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3182 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3183 /* Giving some sort of initial value silences compilers. */
3185 int access_mode = R_OK;
3187 int access_mode = 0;
3190 /* access_mode is never used, but leaving use_access in makes the
3191 conditional compiling below much clearer. */
3194 Mode_t stat_mode = S_IRUSR;
3196 bool effective = FALSE;
3199 switch (PL_op->op_type) {
3200 case OP_FTRREAD: opchar = 'R'; break;
3201 case OP_FTRWRITE: opchar = 'W'; break;
3202 case OP_FTREXEC: opchar = 'X'; break;
3203 case OP_FTEREAD: opchar = 'r'; break;
3204 case OP_FTEWRITE: opchar = 'w'; break;
3205 case OP_FTEEXEC: opchar = 'x'; break;
3207 tryAMAGICftest_MG(opchar);
3209 switch (PL_op->op_type) {
3211 #if !(defined(HAS_ACCESS) && defined(R_OK))
3217 #if defined(HAS_ACCESS) && defined(W_OK)
3222 stat_mode = S_IWUSR;
3226 #if defined(HAS_ACCESS) && defined(X_OK)
3231 stat_mode = S_IXUSR;
3235 #ifdef PERL_EFF_ACCESS
3238 stat_mode = S_IWUSR;
3242 #ifndef PERL_EFF_ACCESS
3249 #ifdef PERL_EFF_ACCESS
3254 stat_mode = S_IXUSR;
3260 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3262 const char *name = SvPV(*PL_stack_sp, len);
3263 if (!IS_SAFE_PATHNAME(name, len, OP_NAME(PL_op))) {
3266 else if (effective) {
3267 # ifdef PERL_EFF_ACCESS
3268 result = PERL_EFF_ACCESS(name, access_mode);
3270 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3276 result = access(name, access_mode);
3278 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3289 result = my_stat_flags(0);
3292 if (cando(stat_mode, effective, &PL_statcache))
3298 /* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */
3303 const int op_type = PL_op->op_type;
3307 case OP_FTIS: opchar = 'e'; break;
3308 case OP_FTSIZE: opchar = 's'; break;
3309 case OP_FTMTIME: opchar = 'M'; break;
3310 case OP_FTCTIME: opchar = 'C'; break;
3311 case OP_FTATIME: opchar = 'A'; break;
3313 tryAMAGICftest_MG(opchar);
3315 result = my_stat_flags(0);
3318 if (op_type == OP_FTIS)
3321 /* You can't dTARGET inside OP_FTIS, because you'll get
3322 "panic: pad_sv po" - the op is not flagged to have a target. */
3326 #if Off_t_size > IVSIZE
3327 sv_setnv(TARG, (NV)PL_statcache.st_size);
3329 sv_setiv(TARG, (IV)PL_statcache.st_size);
3334 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3338 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3342 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3346 return SvTRUE_nomg_NN(TARG)
3347 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3352 /* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned()
3353 * pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock()
3354 * pp_ftsuid() pp_ftsvtx() pp_ftzero() */
3361 switch (PL_op->op_type) {
3362 case OP_FTROWNED: opchar = 'O'; break;
3363 case OP_FTEOWNED: opchar = 'o'; break;
3364 case OP_FTZERO: opchar = 'z'; break;
3365 case OP_FTSOCK: opchar = 'S'; break;
3366 case OP_FTCHR: opchar = 'c'; break;
3367 case OP_FTBLK: opchar = 'b'; break;
3368 case OP_FTFILE: opchar = 'f'; break;
3369 case OP_FTDIR: opchar = 'd'; break;
3370 case OP_FTPIPE: opchar = 'p'; break;
3371 case OP_FTSUID: opchar = 'u'; break;
3372 case OP_FTSGID: opchar = 'g'; break;
3373 case OP_FTSVTX: opchar = 'k'; break;
3375 tryAMAGICftest_MG(opchar);
3377 result = my_stat_flags(0);
3380 switch (PL_op->op_type) {
3382 if (PL_statcache.st_uid == PerlProc_getuid())
3386 if (PL_statcache.st_uid == PerlProc_geteuid())
3390 if (PL_statcache.st_size == 0)
3394 if (S_ISSOCK(PL_statcache.st_mode))
3398 if (S_ISCHR(PL_statcache.st_mode))
3402 if (S_ISBLK(PL_statcache.st_mode))
3406 if (S_ISREG(PL_statcache.st_mode))
3410 if (S_ISDIR(PL_statcache.st_mode))
3414 if (S_ISFIFO(PL_statcache.st_mode))
3419 if (PL_statcache.st_mode & S_ISUID)
3425 if (PL_statcache.st_mode & S_ISGID)
3431 if (PL_statcache.st_mode & S_ISVTX)
3443 tryAMAGICftest_MG('l');
3444 result = my_lstat_flags(0);
3448 if (S_ISLNK(PL_statcache.st_mode))
3461 tryAMAGICftest_MG('t');
3463 if (PL_op->op_flags & OPf_REF)
3466 SV *tmpsv = *PL_stack_sp;
3467 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3468 name = SvPV_nomg(tmpsv, namelen);
3469 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3473 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3474 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3475 else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX)
3480 SETERRNO(EBADF,RMS_IFI);
3483 if (PerlLIO_isatty(fd))
3489 /* also used for: pp_ftbinary() */
3502 const U8 * first_variant;
3504 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3506 if (PL_op->op_flags & OPf_REF)
3508 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3513 gv = MAYBE_DEREF_GV_nomg(sv);
3517 if (gv == PL_defgv) {
3519 io = SvTYPE(PL_statgv) == SVt_PVIO
3523 goto really_filename;
3528 SvPVCLEAR(PL_statname);
3529 io = GvIO(PL_statgv);
3531 PL_laststatval = -1;
3532 PL_laststype = OP_STAT;
3533 if (io && IoIFP(io)) {
3535 if (! PerlIO_has_base(IoIFP(io)))
3536 DIE(aTHX_ "-T and -B not implemented on filehandles");
3537 fd = PerlIO_fileno(IoIFP(io));
3539 SETERRNO(EBADF,RMS_IFI);
3542 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3543 if (PL_laststatval < 0)
3545 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3546 if (PL_op->op_type == OP_FTTEXT)
3551 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3552 i = PerlIO_getc(IoIFP(io));
3554 (void)PerlIO_ungetc(IoIFP(io),i);
3556 /* null file is anything */
3559 len = PerlIO_get_bufsiz(IoIFP(io));
3560 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3561 /* sfio can have large buffers - limit to 512 */
3566 SETERRNO(EBADF,RMS_IFI);
3568 SETERRNO(EBADF,RMS_IFI);
3579 temp = SvPV_nomg_const(sv, temp_len);
3580 sv_setpv(PL_statname, temp);
3581 if (!IS_SAFE_PATHNAME(temp, temp_len, OP_NAME(PL_op))) {
3582 PL_laststatval = -1;
3583 PL_laststype = OP_STAT;
3587 file = SvPVX_const(PL_statname);
3589 if (!(fp = PerlIO_open(file, "r"))) {
3591 PL_laststatval = -1;
3592 PL_laststype = OP_STAT;
3594 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
3595 /* PL_warn_nl is constant */
3596 GCC_DIAG_IGNORE(-Wformat-nonliteral);
3597 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3602 PL_laststype = OP_STAT;
3603 fd = PerlIO_fileno(fp);
3605 (void)PerlIO_close(fp);
3606 SETERRNO(EBADF,RMS_IFI);
3609 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3610 if (PL_laststatval < 0) {
3612 (void)PerlIO_close(fp);
3616 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3617 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3618 (void)PerlIO_close(fp);
3620 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3621 FT_RETURNNO; /* special case NFS directories */
3622 FT_RETURNYES; /* null file is anything */
3627 /* now scan s to look for textiness */
3629 #if defined(DOSISH) || defined(USEMYBINMODE)
3630 /* ignore trailing ^Z on short files */
3631 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3636 if (! is_utf8_invariant_string_loc((U8 *) s, len, &first_variant)) {
3638 /* Here contains a variant under UTF-8 . See if the entire string is
3640 if (is_utf8_fixed_width_buf_flags(first_variant,
3641 len - ((char *) first_variant - (char *) s),
3644 if (PL_op->op_type == OP_FTTEXT) {
3653 /* Here, is not UTF-8 or is entirely ASCII. Look through the buffer for
3654 * things that wouldn't be in ASCII text or rich ASCII text. Count these
3656 for (i = 0; i < len; i++, s++) {
3657 if (!*s) { /* null never allowed in text */
3661 #ifdef USE_LOCALE_CTYPE
3662 if (IN_LC_RUNTIME(LC_CTYPE)) {
3663 if ( isPRINT_LC(*s) || isSPACE_LC(*s)) {
3670 /* VT occurs so rarely in text, that we consider it odd */
3671 || (isSPACE_A(*s) && *s != VT_NATIVE)
3673 /* But there is a fair amount of backspaces and escapes in
3676 || *s == ESC_NATIVE)
3683 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3694 const char *tmps = NULL;
3698 SV * const sv = POPs;
3699 if (PL_op->op_flags & OPf_SPECIAL) {
3700 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3702 if (ckWARN(WARN_UNOPENED)) {
3703 Perl_warner(aTHX_ packWARN(WARN_UNOPENED),
3704 "chdir() on unopened filehandle %" SVf, sv);
3706 SETERRNO(EBADF,RMS_IFI);
3708 TAINT_PROPER("chdir");
3712 else if (!(gv = MAYBE_DEREF_GV(sv)))
3713 tmps = SvPV_nomg_const_nolen(sv);
3716 HV * const table = GvHVn(PL_envgv);
3720 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3721 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3723 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3727 tmps = SvPV_nolen_const(*svp);
3731 SETERRNO(EINVAL, LIB_INVARG);
3732 TAINT_PROPER("chdir");
3737 TAINT_PROPER("chdir");
3740 IO* const io = GvIO(gv);
3743 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3744 } else if (IoIFP(io)) {
3745 int fd = PerlIO_fileno(IoIFP(io));
3749 PUSHi(fchdir(fd) >= 0);
3759 DIE(aTHX_ PL_no_func, "fchdir");
3763 PUSHi( PerlDir_chdir(tmps) >= 0 );
3765 /* Clear the DEFAULT element of ENV so we'll get the new value
3767 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3774 SETERRNO(EBADF,RMS_IFI);
3781 /* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */
3785 dSP; dMARK; dTARGET;
3786 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3797 char * const tmps = POPpx;
3798 TAINT_PROPER("chroot");
3799 PUSHi( chroot(tmps) >= 0 );
3802 DIE(aTHX_ PL_no_func, "chroot");
3813 const char * const tmps2 = POPpconstx;
3814 const char * const tmps = SvPV_nolen_const(TOPs);
3815 TAINT_PROPER("rename");
3817 anum = PerlLIO_rename(tmps, tmps2);
3819 if (!(anum = PerlLIO_stat(tmps, &statbuf))) {
3820 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3823 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
3824 (void)UNLINK(tmps2);
3825 if (!(anum = link(tmps, tmps2)))
3826 anum = UNLINK(tmps);
3835 /* also used for: pp_symlink() */
3837 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3841 const int op_type = PL_op->op_type;
3845 if (op_type == OP_LINK)
3846 DIE(aTHX_ PL_no_func, "link");
3848 # ifndef HAS_SYMLINK
3849 if (op_type == OP_SYMLINK)
3850 DIE(aTHX_ PL_no_func, "symlink");
3854 const char * const tmps2 = POPpconstx;
3855 const char * const tmps = SvPV_nolen_const(TOPs);
3856 TAINT_PROPER(PL_op_desc[op_type]);
3858 # if defined(HAS_LINK) && defined(HAS_SYMLINK)
3859 /* Both present - need to choose which. */
3860 (op_type == OP_LINK) ?
3861 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3862 # elif defined(HAS_LINK)
3863 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3864 PerlLIO_link(tmps, tmps2);
3865 # elif defined(HAS_SYMLINK)
3866 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3867 symlink(tmps, tmps2);
3871 SETi( result >= 0 );
3876 /* also used for: pp_symlink() */
3881 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3891 char buf[MAXPATHLEN];
3896 /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
3897 * it is impossible to know whether the result was truncated. */
3898 len = readlink(tmps, buf, sizeof(buf) - 1);
3907 RETSETUNDEF; /* just pretend it's a normal file */
3911 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3913 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3915 char * const save_filename = filename;
3920 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3922 PERL_ARGS_ASSERT_DOONELINER;
3924 Newx(cmdline, size, char);
3925 my_strlcpy(cmdline, cmd, size);
3926 my_strlcat(cmdline, " ", size);
3927 for (s = cmdline + strlen(cmdline); *filename; ) {
3931 if (s - cmdline < size)
3932 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3933 myfp = PerlProc_popen(cmdline, "r");
3937 SV * const tmpsv = sv_newmortal();
3938 /* Need to save/restore 'PL_rs' ?? */
3939 s = sv_gets(tmpsv, myfp, 0);
3940 (void)PerlProc_pclose(myfp);
3944 #ifdef HAS_SYS_ERRLIST
3949 /* you don't see this */
3950 const char * const errmsg = Strerror(e) ;
3953 if (instr(s, errmsg)) {
3960 #define EACCES EPERM
3962 if (instr(s, "cannot make"))
3963 SETERRNO(EEXIST,RMS_FEX);
3964 else if (instr(s, "existing file"))
3965 SETERRNO(EEXIST,RMS_FEX);
3966 else if (instr(s, "ile exists"))
3967 SETERRNO(EEXIST,RMS_FEX);
3968 else if (instr(s, "non-exist"))
3969 SETERRNO(ENOENT,RMS_FNF);
3970 else if (instr(s, "does not exist"))
3971 SETERRNO(ENOENT,RMS_FNF);
3972 else if (instr(s, "not empty"))
3973 SETERRNO(EBUSY,SS_DEVOFFLINE);
3974 else if (instr(s, "cannot access"))
3975 SETERRNO(EACCES,RMS_PRV);
3977 SETERRNO(EPERM,RMS_PRV);
3980 else { /* some mkdirs return no failure indication */
3982 anum = (PerlLIO_stat(save_filename, &statbuf) >= 0);
3983 if (PL_op->op_type == OP_RMDIR)
3988 SETERRNO(EACCES,RMS_PRV); /* a guess */
3997 /* This macro removes trailing slashes from a directory name.
3998 * Different operating and file systems take differently to
3999 * trailing slashes. According to POSIX 1003.1 1996 Edition
4000 * any number of trailing slashes should be allowed.
4001 * Thusly we snip them away so that even non-conforming
4002 * systems are happy.
4003 * We should probably do this "filtering" for all
4004 * the functions that expect (potentially) directory names:
4005 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
4006 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
4008 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
4009 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
4012 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
4013 (tmps) = savepvn((tmps), (len)); \
4023 const unsigned int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPu : 0777;
4025 TRIMSLASHES(tmps,len,copy);
4027 TAINT_PROPER("mkdir");
4029 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
4033 SETi( dooneliner("mkdir", tmps) );
4034 oldumask = PerlLIO_umask(0);
4035 PerlLIO_umask(oldumask);
4036 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
4051 TRIMSLASHES(tmps,len,copy);
4052 TAINT_PROPER("rmdir");
4054 SETi( PerlDir_rmdir(tmps) >= 0 );
4056 SETi( dooneliner("rmdir", tmps) );
4063 /* Directory calls. */
4067 #if defined(Direntry_t) && defined(HAS_READDIR)
4069 const char * const dirname = POPpconstx;
4070 GV * const gv = MUTABLE_GV(POPs);
4071 IO * const io = GvIOn(gv);
4073 if ((IoIFP(io) || IoOFP(io)))
4074 Perl_croak(aTHX_ "Cannot open %" HEKf " as a dirhandle: it is already open as a filehandle",
4075 HEKfARG(GvENAME_HEK(gv)));
4077 PerlDir_close(IoDIRP(io));
4078 if (!(IoDIRP(io) = PerlDir_open(dirname)))
4084 SETERRNO(EBADF,RMS_DIR);
4087 DIE(aTHX_ PL_no_dir_func, "opendir");
4093 #if !defined(Direntry_t) || !defined(HAS_READDIR)
4094 DIE(aTHX_ PL_no_dir_func, "readdir");
4096 #if !defined(I_DIRENT) && !defined(VMS)
4097 Direntry_t *readdir (DIR *);
4102 const U8 gimme = GIMME_V;
4103 GV * const gv = MUTABLE_GV(POPs);
4104 const Direntry_t *dp;
4105 IO * const io = GvIOn(gv);
4108 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4109 "readdir() attempted on invalid dirhandle %" HEKf,
4110 HEKfARG(GvENAME_HEK(gv)));
4115 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
4119 sv = newSVpvn(dp->d_name, dp->d_namlen);
4121 sv = newSVpv(dp->d_name, 0);
4123 if (!(IoFLAGS(io) & IOf_UNTAINT))
4126 } while (gimme == G_ARRAY);
4128 if (!dp && gimme != G_ARRAY)
4135 SETERRNO(EBADF,RMS_ISI);
4136 if (gimme == G_ARRAY)
4145 #if defined(HAS_TELLDIR) || defined(telldir)
4147 /* XXX does _anyone_ need this? --AD 2/20/1998 */
4148 /* XXX netbsd still seemed to.
4149 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
4150 --JHI 1999-Feb-02 */
4151 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
4152 long telldir (DIR *);
4154 GV * const gv = MUTABLE_GV(POPs);
4155 IO * const io = GvIOn(gv);
4158 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4159 "telldir() attempted on invalid dirhandle %" HEKf,
4160 HEKfARG(GvENAME_HEK(gv)));
4164 PUSHi( PerlDir_tell(IoDIRP(io)) );
4168 SETERRNO(EBADF,RMS_ISI);
4171 DIE(aTHX_ PL_no_dir_func, "telldir");
4177 #if defined(HAS_SEEKDIR) || defined(seekdir)
4179 const long along = POPl;
4180 GV * const gv = MUTABLE_GV(POPs);
4181 IO * const io = GvIOn(gv);
4184 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4185 "seekdir() attempted on invalid dirhandle %" HEKf,
4186 HEKfARG(GvENAME_HEK(gv)));
4189 (void)PerlDir_seek(IoDIRP(io), along);
4194 SETERRNO(EBADF,RMS_ISI);
4197 DIE(aTHX_ PL_no_dir_func, "seekdir");
4203 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4205 GV * const gv = MUTABLE_GV(POPs);
4206 IO * const io = GvIOn(gv);
4209 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4210 "rewinddir() attempted on invalid dirhandle %" HEKf,
4211 HEKfARG(GvENAME_HEK(gv)));
4214 (void)PerlDir_rewind(IoDIRP(io));
4218 SETERRNO(EBADF,RMS_ISI);
4221 DIE(aTHX_ PL_no_dir_func, "rewinddir");
4227 #if defined(Direntry_t) && defined(HAS_READDIR)
4229 GV * const gv = MUTABLE_GV(POPs);
4230 IO * const io = GvIOn(gv);
4233 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4234 "closedir() attempted on invalid dirhandle %" HEKf,
4235 HEKfARG(GvENAME_HEK(gv)));
4238 #ifdef VOID_CLOSEDIR
4239 PerlDir_close(IoDIRP(io));
4241 if (PerlDir_close(IoDIRP(io)) < 0) {
4242 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4251 SETERRNO(EBADF,RMS_IFI);
4254 DIE(aTHX_ PL_no_dir_func, "closedir");
4258 /* Process control. */
4265 #ifdef HAS_SIGPROCMASK
4266 sigset_t oldmask, newmask;
4270 PERL_FLUSHALL_FOR_CHILD;
4271 #ifdef HAS_SIGPROCMASK
4272 sigfillset(&newmask);
4273 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4275 childpid = PerlProc_fork();
4276 if (childpid == 0) {
4280 for (sig = 1; sig < SIG_SIZE; sig++)
4281 PL_psig_pend[sig] = 0;
4283 #ifdef HAS_SIGPROCMASK
4286 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4293 #ifdef PERL_USES_PL_PIDSTATUS
4294 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4299 #elif (defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)) || defined(__amigaos4__)
4304 PERL_FLUSHALL_FOR_CHILD;
4305 childpid = PerlProc_fork();
4311 DIE(aTHX_ PL_no_func, "fork");
4317 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4322 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4323 childpid = wait4pid(-1, &argflags, 0);
4325 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4330 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4331 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4332 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4334 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4339 DIE(aTHX_ PL_no_func, "wait");
4345 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4347 const int optype = POPi;
4348 const Pid_t pid = TOPi;
4352 result = amigaos_waitpid(aTHX_ optype, pid, &argflags);
4353 STATUS_NATIVE_CHILD_SET((result >= 0) ? argflags : -1);
4354 result = result == 0 ? pid : -1;
4358 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4359 result = wait4pid(pid, &argflags, optype);
4361 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4366 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4367 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4368 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4370 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4372 # endif /* __amigaos4__ */
4376 DIE(aTHX_ PL_no_func, "waitpid");
4382 dSP; dMARK; dORIGMARK; dTARGET;
4383 #if defined(__LIBCATAMOUNT__)
4384 PL_statusvalue = -1;
4389 # ifdef __amigaos4__
4397 while (++MARK <= SP) {
4398 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4403 TAINT_PROPER("system");
4405 PERL_FLUSHALL_FOR_CHILD;
4406 #if (defined(HAS_FORK) || defined(__amigaos4__)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4409 struct UserData userdata;
4416 bool child_success = FALSE;
4417 #ifdef HAS_SIGPROCMASK
4418 sigset_t newset, oldset;
4421 if (PerlProc_pipe(pp) >= 0)
4424 amigaos_fork_set_userdata(aTHX_
4430 pthread_create(&proc,NULL,amigaos_system_child,(void *)&userdata);
4431 child_success = proc > 0;
4433 #ifdef HAS_SIGPROCMASK
4434 sigemptyset(&newset);
4435 sigaddset(&newset, SIGCHLD);
4436 sigprocmask(SIG_BLOCK, &newset, &oldset);
4438 while ((childpid = PerlProc_fork()) == -1) {
4439 if (errno != EAGAIN) {
4444 PerlLIO_close(pp[0]);
4445 PerlLIO_close(pp[1]);
4447 #ifdef HAS_SIGPROCMASK
4448 sigprocmask(SIG_SETMASK, &oldset, NULL);
4454 child_success = childpid > 0;
4456 if (child_success) {
4457 Sigsave_t ihand,qhand; /* place to save signals during system() */
4460 #ifndef __amigaos4__
4462 PerlLIO_close(pp[1]);
4465 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4466 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4469 result = pthread_join(proc, (void **)&status);
4472 result = wait4pid(childpid, &status, 0);
4473 } while (result == -1 && errno == EINTR);
4476 #ifdef HAS_SIGPROCMASK
4477 sigprocmask(SIG_SETMASK, &oldset, NULL);
4479 (void)rsignal_restore(SIGINT, &ihand);
4480 (void)rsignal_restore(SIGQUIT, &qhand);
4482 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4483 do_execfree(); /* free any memory child malloced on fork */
4489 while (n < sizeof(int)) {
4490 const SSize_t n1 = PerlLIO_read(pp[0],
4491 (void*)(((char*)&errkid)+n),
4497 PerlLIO_close(pp[0]);
4498 if (n) { /* Error */
4499 if (n != sizeof(int))
4500 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4501 errno = errkid; /* Propagate errno from kid */
4503 /* The pipe always has something in it
4504 * so n alone is not enough. */
4508 STATUS_NATIVE_CHILD_SET(-1);
4512 XPUSHi(STATUS_CURRENT);
4515 #ifndef __amigaos4__
4516 #ifdef HAS_SIGPROCMASK
4517 sigprocmask(SIG_SETMASK, &oldset, NULL);
4520 PerlLIO_close(pp[0]);
4521 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
4522 if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
4526 if (PL_op->op_flags & OPf_STACKED) {
4527 SV * const really = *++MARK;
4528 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4530 else if (SP - MARK != 1)
4531 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4533 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4535 #endif /* __amigaos4__ */
4538 #else /* ! FORK or VMS or OS/2 */
4541 if (PL_op->op_flags & OPf_STACKED) {
4542 SV * const really = *++MARK;
4543 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4544 value = (I32)do_aspawn(really, MARK, SP);
4546 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4549 else if (SP - MARK != 1) {
4550 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4551 value = (I32)do_aspawn(NULL, MARK, SP);
4553 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4557 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4559 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4561 STATUS_NATIVE_CHILD_SET(value);
4564 XPUSHi(result ? value : STATUS_CURRENT);
4565 #endif /* !FORK or VMS or OS/2 */
4572 dSP; dMARK; dORIGMARK; dTARGET;
4577 while (++MARK <= SP) {
4578 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4583 TAINT_PROPER("exec");
4586 PERL_FLUSHALL_FOR_CHILD;
4587 if (PL_op->op_flags & OPf_STACKED) {
4588 SV * const really = *++MARK;
4589 value = (I32)do_aexec(really, MARK, SP);
4591 else if (SP - MARK != 1)
4593 value = (I32)vms_do_aexec(NULL, MARK, SP);
4595 value = (I32)do_aexec(NULL, MARK, SP);
4599 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4601 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4613 XPUSHi( getppid() );
4616 DIE(aTHX_ PL_no_func, "getppid");
4626 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4629 pgrp = (I32)BSD_GETPGRP(pid);
4631 if (pid != 0 && pid != PerlProc_getpid())
4632 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4638 DIE(aTHX_ PL_no_func, "getpgrp");
4648 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4649 if (MAXARG > 0) pid = TOPs ? TOPi : 0;
4656 TAINT_PROPER("setpgrp");
4658 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4660 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4661 || (pid != 0 && pid != PerlProc_getpid()))
4663 DIE(aTHX_ "setpgrp can't take arguments");
4665 SETi( setpgrp() >= 0 );
4666 #endif /* USE_BSDPGRP */
4669 DIE(aTHX_ PL_no_func, "setpgrp");
4673 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4674 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4676 # define PRIORITY_WHICH_T(which) which
4681 #ifdef HAS_GETPRIORITY
4683 const int who = POPi;
4684 const int which = TOPi;
4685 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4688 DIE(aTHX_ PL_no_func, "getpriority");
4694 #ifdef HAS_SETPRIORITY
4696 const int niceval = POPi;
4697 const int who = POPi;
4698 const int which = TOPi;
4699 TAINT_PROPER("setpriority");
4700 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4703 DIE(aTHX_ PL_no_func, "setpriority");
4707 #undef PRIORITY_WHICH_T
4715 XPUSHn( time(NULL) );
4717 XPUSHi( time(NULL) );
4726 struct tms timesbuf;
4729 (void)PerlProc_times(×buf);
4731 mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
4732 if (GIMME_V == G_ARRAY) {
4733 mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
4734 mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
4735 mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
4738 #elif defined(PERL_MICRO)
4742 if (GIMME_V == G_ARRAY) {
4749 DIE(aTHX_ "times not implemented");
4750 #endif /* HAS_TIMES */
4753 /* The 32 bit int year limits the times we can represent to these
4754 boundaries with a few days wiggle room to account for time zone
4757 /* Sat Jan 3 00:00:00 -2147481748 */
4758 #define TIME_LOWER_BOUND -67768100567755200.0
4759 /* Sun Dec 29 12:00:00 2147483647 */
4760 #define TIME_UPPER_BOUND 67767976233316800.0
4763 /* also used for: pp_localtime() */
4771 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4772 static const char * const dayname[] =
4773 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4774 static const char * const monname[] =
4775 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4776 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4778 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4781 when = (Time64_T)now;
4784 NV input = Perl_floor(POPn);
4785 const bool pl_isnan = Perl_isnan(input);
4786 when = (Time64_T)input;
4787 if (UNLIKELY(pl_isnan || when != input)) {
4788 /* diag_listed_as: gmtime(%f) too large */
4789 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4790 "%s(%.0" NVff ") too large", opname, input);
4798 if ( TIME_LOWER_BOUND > when ) {
4799 /* diag_listed_as: gmtime(%f) too small */
4800 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4801 "%s(%.0" NVff ") too small", opname, when);
4804 else if( when > TIME_UPPER_BOUND ) {
4805 /* diag_listed_as: gmtime(%f) too small */
4806 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4807 "%s(%.0" NVff ") too large", opname, when);
4811 if (PL_op->op_type == OP_LOCALTIME)
4812 err = Perl_localtime64_r(&when, &tmbuf);
4814 err = Perl_gmtime64_r(&when, &tmbuf);
4818 /* diag_listed_as: gmtime(%f) failed */
4819 /* XXX %lld broken for quads */
4821 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4822 "%s(%.0" NVff ") failed", opname, when);
4825 if (GIMME_V != G_ARRAY) { /* scalar context */
4832 Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %" IVdf,
4833 dayname[tmbuf.tm_wday],
4834 monname[tmbuf.tm_mon],
4839 (IV)tmbuf.tm_year + 1900);
4842 else { /* list context */
4848 mPUSHi(tmbuf.tm_sec);
4849 mPUSHi(tmbuf.tm_min);
4850 mPUSHi(tmbuf.tm_hour);
4851 mPUSHi(tmbuf.tm_mday);
4852 mPUSHi(tmbuf.tm_mon);
4853 mPUSHn(tmbuf.tm_year);
4854 mPUSHi(tmbuf.tm_wday);
4855 mPUSHi(tmbuf.tm_yday);
4856 mPUSHi(tmbuf.tm_isdst);
4865 /* alarm() takes an unsigned int number of seconds, and return the
4866 * unsigned int number of seconds remaining in the previous alarm
4867 * (alarms don't stack). Therefore negative return values are not
4871 /* Note that while the C library function alarm() as such has
4872 * no errors defined (or in other words, properly behaving client
4873 * code shouldn't expect any), alarm() being obsoleted by
4874 * setitimer() and often being implemented in terms of
4875 * setitimer(), can fail. */
4876 /* diag_listed_as: %s() with negative argument */
4877 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4878 "alarm() with negative argument");
4879 SETERRNO(EINVAL, LIB_INVARG);
4883 unsigned int retval = alarm(anum);
4884 if ((int)retval < 0) /* Strictly speaking "cannot happen". */
4890 DIE(aTHX_ PL_no_func, "alarm");
4900 (void)time(&lasttime);
4901 if (MAXARG < 1 || (!TOPs && !POPs))
4904 const I32 duration = POPi;
4906 /* diag_listed_as: %s() with negative argument */
4907 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4908 "sleep() with negative argument");
4909 SETERRNO(EINVAL, LIB_INVARG);
4910 XPUSHs(&PL_sv_zero);
4913 PerlProc_sleep((unsigned int)duration);
4917 XPUSHi(when - lasttime);
4921 /* Shared memory. */
4922 /* Merged with some message passing. */
4924 /* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */
4928 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4929 dSP; dMARK; dTARGET;
4930 const int op_type = PL_op->op_type;
4935 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4938 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4941 value = (I32)(do_semop(MARK, SP) >= 0);
4944 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4952 return Perl_pp_semget(aTHX);
4958 /* also used for: pp_msgget() pp_shmget() */
4962 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4963 dSP; dMARK; dTARGET;
4964 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4971 DIE(aTHX_ "System V IPC is not implemented on this machine");
4975 /* also used for: pp_msgctl() pp_shmctl() */
4979 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4980 dSP; dMARK; dTARGET;
4981 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4989 PUSHp(zero_but_true, ZBTLEN);
4993 return Perl_pp_semget(aTHX);
4997 /* I can't const this further without getting warnings about the types of
4998 various arrays passed in from structures. */
5000 S_space_join_names_mortal(pTHX_ char *const *array)
5004 if (array && *array) {
5005 target = newSVpvs_flags("", SVs_TEMP);
5007 sv_catpv(target, *array);
5010 sv_catpvs(target, " ");
5013 target = sv_mortalcopy(&PL_sv_no);
5018 /* Get system info. */
5020 /* also used for: pp_ghbyaddr() pp_ghbyname() */
5024 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
5026 I32 which = PL_op->op_type;
5029 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
5030 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
5031 struct hostent *gethostbyname(Netdb_name_t);
5032 struct hostent *gethostent(void);
5034 struct hostent *hent = NULL;
5038 if (which == OP_GHBYNAME) {
5039 #ifdef HAS_GETHOSTBYNAME
5040 const char* const name = POPpbytex;
5041 hent = PerlSock_gethostbyname(name);
5043 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
5046 else if (which == OP_GHBYADDR) {
5047 #ifdef HAS_GETHOSTBYADDR
5048 const int addrtype = POPi;
5049 SV * const addrsv = POPs;
5051 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
5053 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
5055 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
5059 #ifdef HAS_GETHOSTENT
5060 hent = PerlSock_gethostent();
5062 DIE(aTHX_ PL_no_sock_func, "gethostent");
5065 #ifdef HOST_NOT_FOUND
5067 #ifdef USE_REENTRANT_API
5068 # ifdef USE_GETHOSTENT_ERRNO
5069 h_errno = PL_reentrant_buffer->_gethostent_errno;
5072 STATUS_UNIX_SET(h_errno);
5076 if (GIMME_V != G_ARRAY) {
5077 PUSHs(sv = sv_newmortal());
5079 if (which == OP_GHBYNAME) {
5081 sv_setpvn(sv, hent->h_addr, hent->h_length);
5084 sv_setpv(sv, (char*)hent->h_name);
5090 mPUSHs(newSVpv((char*)hent->h_name, 0));
5091 PUSHs(space_join_names_mortal(hent->h_aliases));
5092 mPUSHi(hent->h_addrtype);
5093 len = hent->h_length;
5096 for (elem = hent->h_addr_list; elem && *elem; elem++) {
5097 mXPUSHp(*elem, len);
5101 mPUSHp(hent->h_addr, len);
5103 PUSHs(sv_mortalcopy(&PL_sv_no));
5108 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5112 /* also used for: pp_gnbyaddr() pp_gnbyname() */
5116 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
5118 I32 which = PL_op->op_type;
5120 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
5121 struct netent *getnetbyaddr(Netdb_net_t, int);
5122 struct netent *getnetbyname(Netdb_name_t);
5123 struct netent *getnetent(void);
5125 struct netent *nent;
5127 if (which == OP_GNBYNAME){
5128 #ifdef HAS_GETNETBYNAME
5129 const char * const name = POPpbytex;
5130 nent = PerlSock_getnetbyname(name);
5132 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
5135 else if (which == OP_GNBYADDR) {
5136 #ifdef HAS_GETNETBYADDR
5137 const int addrtype = POPi;
5138 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
5139 nent = PerlSock_getnetbyaddr(addr, addrtype);
5141 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
5145 #ifdef HAS_GETNETENT
5146 nent = PerlSock_getnetent();
5148 DIE(aTHX_ PL_no_sock_func, "getnetent");
5151 #ifdef HOST_NOT_FOUND
5153 #ifdef USE_REENTRANT_API
5154 # ifdef USE_GETNETENT_ERRNO
5155 h_errno = PL_reentrant_buffer->_getnetent_errno;
5158 STATUS_UNIX_SET(h_errno);
5163 if (GIMME_V != G_ARRAY) {
5164 PUSHs(sv = sv_newmortal());
5166 if (which == OP_GNBYNAME)
5167 sv_setiv(sv, (IV)nent->n_net);
5169 sv_setpv(sv, nent->n_name);
5175 mPUSHs(newSVpv(nent->n_name, 0));
5176 PUSHs(space_join_names_mortal(nent->n_aliases));
5177 mPUSHi(nent->n_addrtype);
5178 mPUSHi(nent->n_net);
5183 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5188 /* also used for: pp_gpbyname() pp_gpbynumber() */
5192 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
5194 I32 which = PL_op->op_type;
5196 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
5197 struct protoent *getprotobyname(Netdb_name_t);
5198 struct protoent *getprotobynumber(int);
5199 struct protoent *getprotoent(void);
5201 struct protoent *pent;
5203 if (which == OP_GPBYNAME) {
5204 #ifdef HAS_GETPROTOBYNAME
5205 const char* const name = POPpbytex;
5206 pent = PerlSock_getprotobyname(name);
5208 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
5211 else if (which == OP_GPBYNUMBER) {
5212 #ifdef HAS_GETPROTOBYNUMBER
5213 const int number = POPi;
5214 pent = PerlSock_getprotobynumber(number);
5216 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
5220 #ifdef HAS_GETPROTOENT
5221 pent = PerlSock_getprotoent();
5223 DIE(aTHX_ PL_no_sock_func, "getprotoent");
5227 if (GIMME_V != G_ARRAY) {
5228 PUSHs(sv = sv_newmortal());
5230 if (which == OP_GPBYNAME)
5231 sv_setiv(sv, (IV)pent->p_proto);
5233 sv_setpv(sv, pent->p_name);
5239 mPUSHs(newSVpv(pent->p_name, 0));
5240 PUSHs(space_join_names_mortal(pent->p_aliases));
5241 mPUSHi(pent->p_proto);
5246 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5251 /* also used for: pp_gsbyname() pp_gsbyport() */
5255 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
5257 I32 which = PL_op->op_type;
5259 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
5260 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
5261 struct servent *getservbyport(int, Netdb_name_t);
5262 struct servent *getservent(void);
5264 struct servent *sent;
5266 if (which == OP_GSBYNAME) {
5267 #ifdef HAS_GETSERVBYNAME
5268 const char * const proto = POPpbytex;
5269 const char * const name = POPpbytex;
5270 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5272 DIE(aTHX_ PL_no_sock_func, "getservbyname");
5275 else if (which == OP_GSBYPORT) {
5276 #ifdef HAS_GETSERVBYPORT
5277 const char * const proto = POPpbytex;
5278 unsigned short port = (unsigned short)POPu;
5279 port = PerlSock_htons(port);
5280 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5282 DIE(aTHX_ PL_no_sock_func, "getservbyport");
5286 #ifdef HAS_GETSERVENT
5287 sent = PerlSock_getservent();
5289 DIE(aTHX_ PL_no_sock_func, "getservent");
5293 if (GIMME_V != G_ARRAY) {
5294 PUSHs(sv = sv_newmortal());
5296 if (which == OP_GSBYNAME) {
5297 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5300 sv_setpv(sv, sent->s_name);
5306 mPUSHs(newSVpv(sent->s_name, 0));
5307 PUSHs(space_join_names_mortal(sent->s_aliases));
5308 mPUSHi(PerlSock_ntohs(sent->s_port));
5309 mPUSHs(newSVpv(sent->s_proto, 0));
5314 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5319 /* also used for: pp_snetent() pp_sprotoent() pp_sservent() */
5324 const int stayopen = TOPi;
5325 switch(PL_op->op_type) {
5327 #ifdef HAS_SETHOSTENT
5328 PerlSock_sethostent(stayopen);
5330 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5333 #ifdef HAS_SETNETENT
5335 PerlSock_setnetent(stayopen);
5337 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5341 #ifdef HAS_SETPROTOENT
5342 PerlSock_setprotoent(stayopen);
5344 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5348 #ifdef HAS_SETSERVENT
5349 PerlSock_setservent(stayopen);
5351 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5359 /* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent()
5360 * pp_eservent() pp_sgrent() pp_spwent() */
5365 switch(PL_op->op_type) {
5367 #ifdef HAS_ENDHOSTENT
5368 PerlSock_endhostent();
5370 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5374 #ifdef HAS_ENDNETENT
5375 PerlSock_endnetent();
5377 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5381 #ifdef HAS_ENDPROTOENT
5382 PerlSock_endprotoent();
5384 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5388 #ifdef HAS_ENDSERVENT
5389 PerlSock_endservent();
5391 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5395 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5398 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5402 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5405 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5409 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5412 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5416 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5419 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5428 /* also used for: pp_gpwnam() pp_gpwuid() */
5434 I32 which = PL_op->op_type;
5436 struct passwd *pwent = NULL;
5438 * We currently support only the SysV getsp* shadow password interface.
5439 * The interface is declared in <shadow.h> and often one needs to link
5440 * with -lsecurity or some such.
5441 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5444 * AIX getpwnam() is clever enough to return the encrypted password
5445 * only if the caller (euid?) is root.
5447 * There are at least three other shadow password APIs. Many platforms
5448 * seem to contain more than one interface for accessing the shadow
5449 * password databases, possibly for compatibility reasons.
5450 * The getsp*() is by far he simplest one, the other two interfaces
5451 * are much more complicated, but also very similar to each other.
5456 * struct pr_passwd *getprpw*();
5457 * The password is in
5458 * char getprpw*(...).ufld.fd_encrypt[]
5459 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5464 * struct es_passwd *getespw*();
5465 * The password is in
5466 * char *(getespw*(...).ufld.fd_encrypt)
5467 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5470 * struct userpw *getuserpw();
5471 * The password is in
5472 * char *(getuserpw(...)).spw_upw_passwd
5473 * (but the de facto standard getpwnam() should work okay)
5475 * Mention I_PROT here so that Configure probes for it.
5477 * In HP-UX for getprpw*() the manual page claims that one should include
5478 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5479 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5480 * and pp_sys.c already includes <shadow.h> if there is such.
5482 * Note that <sys/security.h> is already probed for, but currently
5483 * it is only included in special cases.
5485 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5486 * be preferred interface, even though also the getprpw*() interface
5487 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5488 * One also needs to call set_auth_parameters() in main() before
5489 * doing anything else, whether one is using getespw*() or getprpw*().
5491 * Note that accessing the shadow databases can be magnitudes
5492 * slower than accessing the standard databases.
5497 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5498 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5499 * the pw_comment is left uninitialized. */
5500 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5506 const char* const name = POPpbytex;
5507 pwent = getpwnam(name);
5513 pwent = getpwuid(uid);
5517 # ifdef HAS_GETPWENT
5519 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5520 if (pwent) pwent = getpwnam(pwent->pw_name);
5523 DIE(aTHX_ PL_no_func, "getpwent");
5529 if (GIMME_V != G_ARRAY) {
5530 PUSHs(sv = sv_newmortal());
5532 if (which == OP_GPWNAM)
5533 sv_setuid(sv, pwent->pw_uid);
5535 sv_setpv(sv, pwent->pw_name);
5541 mPUSHs(newSVpv(pwent->pw_name, 0));
5545 /* If we have getspnam(), we try to dig up the shadow
5546 * password. If we are underprivileged, the shadow
5547 * interface will set the errno to EACCES or similar,
5548 * and return a null pointer. If this happens, we will
5549 * use the dummy password (usually "*" or "x") from the
5550 * standard password database.
5552 * In theory we could skip the shadow call completely
5553 * if euid != 0 but in practice we cannot know which
5554 * security measures are guarding the shadow databases
5555 * on a random platform.
5557 * Resist the urge to use additional shadow interfaces.
5558 * Divert the urge to writing an extension instead.
5561 /* Some AIX setups falsely(?) detect some getspnam(), which
5562 * has a different API than the Solaris/IRIX one. */
5563 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5566 const struct spwd * const spwent = getspnam(pwent->pw_name);
5567 /* Save and restore errno so that
5568 * underprivileged attempts seem
5569 * to have never made the unsuccessful
5570 * attempt to retrieve the shadow password. */
5572 if (spwent && spwent->sp_pwdp)
5573 sv_setpv(sv, spwent->sp_pwdp);
5577 if (!SvPOK(sv)) /* Use the standard password, then. */
5578 sv_setpv(sv, pwent->pw_passwd);
5581 /* passwd is tainted because user himself can diddle with it.
5582 * admittedly not much and in a very limited way, but nevertheless. */
5585 sv_setuid(PUSHmortal, pwent->pw_uid);
5586 sv_setgid(PUSHmortal, pwent->pw_gid);
5588 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5589 * because of the poor interface of the Perl getpw*(),
5590 * not because there's some standard/convention saying so.
5591 * A better interface would have been to return a hash,
5592 * but we are accursed by our history, alas. --jhi. */
5594 mPUSHi(pwent->pw_change);
5595 # elif defined(PWQUOTA)
5596 mPUSHi(pwent->pw_quota);
5597 # elif defined(PWAGE)
5598 mPUSHs(newSVpv(pwent->pw_age, 0));
5600 /* I think that you can never get this compiled, but just in case. */
5601 PUSHs(sv_mortalcopy(&PL_sv_no));
5604 /* pw_class and pw_comment are mutually exclusive--.
5605 * see the above note for pw_change, pw_quota, and pw_age. */
5607 mPUSHs(newSVpv(pwent->pw_class, 0));
5608 # elif defined(PWCOMMENT)
5609 mPUSHs(newSVpv(pwent->pw_comment, 0));
5611 /* I think that you can never get this compiled, but just in case. */
5612 PUSHs(sv_mortalcopy(&PL_sv_no));
5616 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5618 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5620 /* pw_gecos is tainted because user himself can diddle with it. */
5623 mPUSHs(newSVpv(pwent->pw_dir, 0));
5625 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5626 /* pw_shell is tainted because user himself can diddle with it. */
5630 mPUSHi(pwent->pw_expire);
5635 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5640 /* also used for: pp_ggrgid() pp_ggrnam() */
5646 const I32 which = PL_op->op_type;
5647 const struct group *grent;
5649 if (which == OP_GGRNAM) {
5650 const char* const name = POPpbytex;
5651 grent = (const struct group *)getgrnam(name);
5653 else if (which == OP_GGRGID) {
5655 const Gid_t gid = POPu;
5656 #elif Gid_t_sign == -1
5657 const Gid_t gid = POPi;
5659 # error "Unexpected Gid_t_sign"
5661 grent = (const struct group *)getgrgid(gid);
5665 grent = (struct group *)getgrent();
5667 DIE(aTHX_ PL_no_func, "getgrent");
5671 if (GIMME_V != G_ARRAY) {
5672 SV * const sv = sv_newmortal();
5676 if (which == OP_GGRNAM)
5677 sv_setgid(sv, grent->gr_gid);
5679 sv_setpv(sv, grent->gr_name);
5685 mPUSHs(newSVpv(grent->gr_name, 0));
5688 mPUSHs(newSVpv(grent->gr_passwd, 0));
5690 PUSHs(sv_mortalcopy(&PL_sv_no));
5693 sv_setgid(PUSHmortal, grent->gr_gid);
5695 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5696 /* In UNICOS/mk (_CRAYMPP) the multithreading
5697 * versions (getgrnam_r, getgrgid_r)
5698 * seem to return an illegal pointer
5699 * as the group members list, gr_mem.
5700 * getgrent() doesn't even have a _r version
5701 * but the gr_mem is poisonous anyway.
5702 * So yes, you cannot get the list of group
5703 * members if building multithreaded in UNICOS/mk. */
5704 PUSHs(space_join_names_mortal(grent->gr_mem));
5710 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5720 if (!(tmps = PerlProc_getlogin()))
5722 sv_setpv_mg(TARG, tmps);
5726 DIE(aTHX_ PL_no_func, "getlogin");
5730 /* Miscellaneous. */
5735 dSP; dMARK; dORIGMARK; dTARGET;
5736 I32 items = SP - MARK;
5737 unsigned long a[20];
5742 while (++MARK <= SP) {
5743 if (SvTAINTED(*MARK)) {
5749 TAINT_PROPER("syscall");
5752 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5753 * or where sizeof(long) != sizeof(char*). But such machines will
5754 * not likely have syscall implemented either, so who cares?
5756 while (++MARK <= SP) {
5757 if (SvNIOK(*MARK) || !i)
5758 a[i++] = SvIV(*MARK);
5759 else if (*MARK == &PL_sv_undef)
5762 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5768 DIE(aTHX_ "Too many args to syscall");
5770 DIE(aTHX_ "Too few args to syscall");
5772 retval = syscall(a[0]);
5775 retval = syscall(a[0],a[1]);
5778 retval = syscall(a[0],a[1],a[2]);
5781 retval = syscall(a[0],a[1],a[2],a[3]);
5784 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5787 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5790 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5793 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5800 DIE(aTHX_ PL_no_func, "syscall");
5804 #ifdef FCNTL_EMULATE_FLOCK
5806 /* XXX Emulate flock() with fcntl().
5807 What's really needed is a good file locking module.
5811 fcntl_emulate_flock(int fd, int operation)
5816 switch (operation & ~LOCK_NB) {
5818 flock.l_type = F_RDLCK;
5821 flock.l_type = F_WRLCK;
5824 flock.l_type = F_UNLCK;
5830 flock.l_whence = SEEK_SET;
5831 flock.l_start = flock.l_len = (Off_t)0;
5833 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5834 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5835 errno = EWOULDBLOCK;
5839 #endif /* FCNTL_EMULATE_FLOCK */
5841 #ifdef LOCKF_EMULATE_FLOCK
5843 /* XXX Emulate flock() with lockf(). This is just to increase
5844 portability of scripts. The calls are not completely
5845 interchangeable. What's really needed is a good file
5849 /* The lockf() constants might have been defined in <unistd.h>.
5850 Unfortunately, <unistd.h> causes troubles on some mixed
5851 (BSD/POSIX) systems, such as SunOS 4.1.3.
5853 Further, the lockf() constants aren't POSIX, so they might not be
5854 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5855 just stick in the SVID values and be done with it. Sigh.
5859 # define F_ULOCK 0 /* Unlock a previously locked region */
5862 # define F_LOCK 1 /* Lock a region for exclusive use */
5865 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5868 # define F_TEST 3 /* Test a region for other processes locks */
5872 lockf_emulate_flock(int fd, int operation)
5878 /* flock locks entire file so for lockf we need to do the same */
5879 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5880 if (pos > 0) /* is seekable and needs to be repositioned */
5881 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5882 pos = -1; /* seek failed, so don't seek back afterwards */
5885 switch (operation) {
5887 /* LOCK_SH - get a shared lock */
5889 /* LOCK_EX - get an exclusive lock */
5891 i = lockf (fd, F_LOCK, 0);
5894 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5895 case LOCK_SH|LOCK_NB:
5896 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5897 case LOCK_EX|LOCK_NB:
5898 i = lockf (fd, F_TLOCK, 0);
5900 if ((errno == EAGAIN) || (errno == EACCES))
5901 errno = EWOULDBLOCK;
5904 /* LOCK_UN - unlock (non-blocking is a no-op) */
5906 case LOCK_UN|LOCK_NB:
5907 i = lockf (fd, F_ULOCK, 0);
5910 /* Default - can't decipher operation */
5917 if (pos > 0) /* need to restore position of the handle */
5918 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5923 #endif /* LOCKF_EMULATE_FLOCK */
5926 * ex: set ts=8 sts=4 sw=4 et: