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>
57 # include <sys/select.h>
61 /* XXX Configure test needed.
62 h_errno might not be a simple 'int', especially for multi-threaded
63 applications, see "extern int errno in perl.h". Creating such
64 a test requires taking into account the differences between
65 compiling multithreaded and singlethreaded ($ccflags et al).
66 HOST_NOT_FOUND is typically defined in <netdb.h>.
68 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
76 struct passwd *getpwnam (char *);
77 struct passwd *getpwuid (Uid_t);
81 struct passwd *getpwent (void);
82 # elif defined (VMS) && defined (my_getpwent)
83 struct passwd *Perl_my_getpwent (pTHX);
92 struct group *getgrnam (char *);
93 struct group *getgrgid (Gid_t);
97 struct group *getgrent (void);
103 # if defined(_MSC_VER) || defined(__MINGW32__)
104 # include <sys/utime.h>
111 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
114 # define my_chsize PerlLIO_chsize
115 #elif defined(HAS_TRUNCATE)
116 # define my_chsize PerlLIO_chsize
118 I32 my_chsize(int fd, Off_t length);
123 #else /* no flock() */
125 /* fcntl.h might not have been included, even if it exists, because
126 the current Configure only sets I_FCNTL if it's needed to pick up
127 the *_OK constants. Make sure it has been included before testing
128 the fcntl() locking constants. */
129 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
133 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
134 # define FLOCK fcntl_emulate_flock
135 # define FCNTL_EMULATE_FLOCK
136 # elif defined(HAS_LOCKF)
137 # define FLOCK lockf_emulate_flock
138 # define LOCKF_EMULATE_FLOCK
142 static int FLOCK (int, int);
145 * These are the flock() constants. Since this sytems doesn't have
146 * flock(), the values of the constants are probably not available.
160 # endif /* emulating flock() */
162 #endif /* no flock() */
165 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
167 #if defined(I_SYS_ACCESS) && !defined(R_OK)
168 # include <sys/access.h>
174 /* Missing protos on LynxOS */
175 void sethostent(int);
176 void endhostent(void);
178 void endnetent(void);
179 void setprotoent(int);
180 void endprotoent(void);
181 void setservent(int);
182 void endservent(void);
186 # include "amigaos4/amigaio.h"
189 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
191 /* F_OK unused: if stat() cannot find it... */
193 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
194 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
195 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
198 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
199 # ifdef I_SYS_SECURITY
200 # include <sys/security.h>
204 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
207 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
211 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
212 /* AIX's accessx() doesn't declare its argument const, unlike every other platform */
213 # define PERL_EFF_ACCESS(p,f) (accessx((char*)(p), (f), ACC_SELF))
217 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
218 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
219 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
222 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
224 const Uid_t ruid = getuid();
225 const Uid_t euid = geteuid();
226 const Gid_t rgid = getgid();
227 const Gid_t egid = getegid();
230 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
231 Perl_croak(aTHX_ "switching effective uid is not implemented");
234 if (setreuid(euid, ruid))
235 # elif defined(HAS_SETRESUID)
236 if (setresuid(euid, ruid, (Uid_t)-1))
238 /* diag_listed_as: entering effective %s failed */
239 Perl_croak(aTHX_ "entering effective uid failed");
242 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
243 Perl_croak(aTHX_ "switching effective gid is not implemented");
246 if (setregid(egid, rgid))
247 # elif defined(HAS_SETRESGID)
248 if (setresgid(egid, rgid, (Gid_t)-1))
250 /* diag_listed_as: entering effective %s failed */
251 Perl_croak(aTHX_ "entering effective gid failed");
254 res = access(path, mode);
257 if (setreuid(ruid, euid))
258 #elif defined(HAS_SETRESUID)
259 if (setresuid(ruid, euid, (Uid_t)-1))
261 /* diag_listed_as: leaving effective %s failed */
262 Perl_croak(aTHX_ "leaving effective uid failed");
265 if (setregid(rgid, egid))
266 #elif defined(HAS_SETRESGID)
267 if (setresgid(rgid, egid, (Gid_t)-1))
269 /* diag_listed_as: leaving effective %s failed */
270 Perl_croak(aTHX_ "leaving effective gid failed");
274 # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
281 const char * const tmps = POPpconstx;
282 const U8 gimme = GIMME_V;
283 const char *mode = "r";
286 if (PL_op->op_private & OPpOPEN_IN_RAW)
288 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
290 fp = PerlProc_popen(tmps, mode);
292 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
294 PerlIO_apply_layers(aTHX_ fp,mode,type);
296 if (gimme == G_VOID) {
298 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
301 else if (gimme == G_SCALAR) {
302 ENTER_with_name("backtick");
304 PL_rs = &PL_sv_undef;
305 SvPVCLEAR(TARG); /* note that this preserves previous buffer */
306 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
308 LEAVE_with_name("backtick");
314 SV * const sv = newSV(79);
315 if (sv_gets(sv, fp, 0) == NULL) {
320 if (SvLEN(sv) - SvCUR(sv) > 20) {
321 SvPV_shrink_to_cur(sv);
326 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
327 TAINT; /* "I believe that this is not gratuitous!" */
330 STATUS_NATIVE_CHILD_SET(-1);
331 if (gimme == G_SCALAR)
342 GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs;
346 /* make a copy of the pattern if it is gmagical, to ensure that magic
347 * is called once and only once */
348 if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs));
350 tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL));
352 if (PL_op->op_flags & OPf_SPECIAL) {
353 /* call Perl-level glob function instead. Stack args are:
355 * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
364 /* Note that we only ever get here if File::Glob fails to load
365 * without at the same time croaking, for some reason, or if
366 * perl was built with PERL_EXTERNAL_GLOB */
368 ENTER_with_name("glob");
373 * The external globbing program may use things we can't control,
374 * so for security reasons we must assume the worst.
377 taint_proper(PL_no_security, "glob");
381 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
384 SAVESPTR(PL_rs); /* This is not permanent, either. */
385 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
388 *SvPVX(PL_rs) = '\n';
392 result = do_readline();
393 LEAVE_with_name("glob");
399 PL_last_in_gv = cGVOP_gv;
400 return do_readline();
410 do_join(TARG, &PL_sv_no, MARK, SP);
414 else if (SP == MARK) {
421 if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
424 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
425 /* well-formed exception supplied */
428 SV * const errsv = ERRSV;
431 if (SvGMAGICAL(errsv)) {
432 exsv = sv_newmortal();
433 sv_setsv_nomg(exsv, errsv);
437 else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) {
438 exsv = sv_newmortal();
439 sv_setsv_nomg(exsv, errsv);
440 sv_catpvs(exsv, "\t...caught");
443 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
446 if (SvROK(exsv) && !PL_warnhook)
447 Perl_warn(aTHX_ "%" SVf, SVfARG(exsv));
459 VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
461 if (SP - MARK != 1) {
463 do_join(TARG, &PL_sv_no, MARK, SP);
471 if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
472 /* well-formed exception supplied */
475 SV * const errsv = ERRSV;
479 if (sv_isobject(exsv)) {
480 HV * const stash = SvSTASH(SvRV(exsv));
481 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
483 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
484 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
491 call_sv(MUTABLE_SV(GvCV(gv)),
492 G_SCALAR|G_EVAL|G_KEEPERR);
493 exsv = sv_mortalcopy(*PL_stack_sp--);
497 else if (SvOK(errsv) && (SvPV_nomg(errsv,len), len)) {
498 exsv = sv_mortalcopy(errsv);
499 sv_catpvs(exsv, "\t...propagated");
502 exsv = newSVpvs_flags("Died", SVs_TEMP);
506 NOT_REACHED; /* NOTREACHED */
507 return NULL; /* avoid missing return from non-void function warning */
513 Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv,
514 const MAGIC *const mg, const U32 flags, U32 argc, ...)
520 PERL_ARGS_ASSERT_TIED_METHOD;
522 /* Ensure that our flag bits do not overlap. */
523 STATIC_ASSERT_STMT((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
524 STATIC_ASSERT_STMT((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
525 STATIC_ASSERT_STMT((TIED_METHOD_SAY & G_WANT) == 0);
527 PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
528 PUSHSTACKi(PERLSI_MAGIC);
529 /* extend for object + args. If argc might wrap/truncate when cast
530 * to SSize_t and incremented, set to -1, which will trigger a panic in
532 * The weird way this is written is because g++ is dumb enough to
533 * warn "comparison is always false" on something like:
535 * sizeof(a) >= sizeof(b) && a >= B_t_MAX -1
537 * (where the LH condition is false)
540 (argc > (sizeof(argc) >= sizeof(SSize_t) ? SSize_t_MAX - 1 : argc))
541 ? -1 : (SSize_t)argc + 1;
542 EXTEND(SP, extend_size);
544 PUSHs(SvTIED_obj(sv, mg));
545 if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
546 Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
550 const U32 mortalize_not_needed
551 = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
553 va_start(args, argc);
555 SV *const arg = va_arg(args, SV *);
556 if(mortalize_not_needed)
565 ENTER_with_name("call_tied_method");
566 if (flags & TIED_METHOD_SAY) {
567 /* local $\ = "\n" */
568 SAVEGENERICSV(PL_ors_sv);
569 PL_ors_sv = newSVpvs("\n");
571 ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED);
576 if (ret_args) { /* copy results back to original stack */
577 EXTEND(sp, ret_args);
578 Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
582 LEAVE_with_name("call_tied_method");
586 #define tied_method0(a,b,c,d) \
587 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
588 #define tied_method1(a,b,c,d,e) \
589 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
590 #define tied_method2(a,b,c,d,e,f) \
591 Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
604 GV * const gv = MUTABLE_GV(*++MARK);
606 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
607 DIE(aTHX_ PL_no_usym, "filehandle");
609 if ((io = GvIOp(gv))) {
611 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
614 Perl_croak(aTHX_ "Cannot open %" HEKf " as a filehandle: it is already open as a dirhandle",
615 HEKfARG(GvENAME_HEK(gv)));
617 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
619 /* Method's args are same as ours ... */
620 /* ... except handle is replaced by the object */
621 return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg,
622 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
634 tmps = SvPV_const(sv, len);
635 ok = do_open6(gv, tmps, len, NULL, MARK+1, (SP-MARK));
638 PUSHi( (I32)PL_forkprocess );
639 else if (PL_forkprocess == 0) /* we are a new child */
649 /* pp_coreargs pushes a NULL to indicate no args passed to
652 MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
658 IO * const io = GvIO(gv);
660 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
662 return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg);
666 PUSHs(boolSV(do_close(gv, TRUE)));
678 GV * const wgv = MUTABLE_GV(POPs);
679 GV * const rgv = MUTABLE_GV(POPs);
683 do_close(rgv, FALSE);
687 do_close(wgv, FALSE);
689 if (PerlProc_pipe_cloexec(fd) < 0)
692 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r" PIPE_OPEN_MODE);
693 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w" PIPE_OPEN_MODE);
694 IoOFP(rstio) = IoIFP(rstio);
695 IoIFP(wstio) = IoOFP(wstio);
696 IoTYPE(rstio) = IoTYPE_RDONLY;
697 IoTYPE(wstio) = IoTYPE_WRONLY;
699 if (!IoIFP(rstio) || !IoOFP(wstio)) {
701 PerlIO_close(IoIFP(rstio));
703 PerlLIO_close(fd[0]);
705 PerlIO_close(IoOFP(wstio));
707 PerlLIO_close(fd[1]);
715 DIE(aTHX_ PL_no_func, "pipe");
729 gv = MUTABLE_GV(POPs);
733 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
735 return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg);
738 if (io && IoDIRP(io)) {
739 #if defined(HAS_DIRFD) || defined(HAS_DIR_DD_FD)
740 PUSHi(my_dirfd(IoDIRP(io)));
742 #elif defined(ENOTSUP)
743 errno = ENOTSUP; /* Operation not supported */
745 #elif defined(EOPNOTSUPP)
746 errno = EOPNOTSUPP; /* Operation not supported on socket */
749 errno = EINVAL; /* Invalid argument */
754 if (!io || !(fp = IoIFP(io))) {
755 /* Can't do this because people seem to do things like
756 defined(fileno($foo)) to check whether $foo is a valid fh.
763 PUSHi(PerlIO_fileno(fp));
774 if (MAXARG < 1 || (!TOPs && !POPs)) {
775 anum = PerlLIO_umask(022);
776 /* setting it to 022 between the two calls to umask avoids
777 * to have a window where the umask is set to 0 -- meaning
778 * that another thread could create world-writeable files. */
780 (void)PerlLIO_umask(anum);
783 anum = PerlLIO_umask(POPi);
784 TAINT_PROPER("umask");
787 /* Only DIE if trying to restrict permissions on "user" (self).
788 * Otherwise it's harmless and more useful to just return undef
789 * since 'group' and 'other' concepts probably don't exist here. */
790 if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
791 DIE(aTHX_ "umask not implemented");
792 XPUSHs(&PL_sv_undef);
811 gv = MUTABLE_GV(POPs);
815 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
817 /* This takes advantage of the implementation of the varargs
818 function, which I don't think that the optimiser will be able to
819 figure out. Although, as it's a static function, in theory it
821 return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg,
822 G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
823 discp ? 1 : 0, discp);
827 if (!io || !(fp = IoIFP(io))) {
829 SETERRNO(EBADF,RMS_IFI);
836 const char *d = NULL;
839 d = SvPV_const(discp, len);
840 mode = mode_from_discipline(d, len);
841 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
842 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
843 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
864 const I32 markoff = MARK - PL_stack_base;
865 const char *methname;
866 int how = PERL_MAGIC_tied;
870 switch(SvTYPE(varsv)) {
874 methname = "TIEHASH";
875 if (HvLAZYDEL(varsv) && (entry = HvEITER_get((HV *)varsv))) {
876 HvLAZYDEL_off(varsv);
877 hv_free_ent((HV *)varsv, entry);
879 HvEITER_set(MUTABLE_HV(varsv), 0);
880 HvRITER_set(MUTABLE_HV(varsv), -1);
884 methname = "TIEARRAY";
885 if (!AvREAL(varsv)) {
887 Perl_croak(aTHX_ "Cannot tie unreifiable array");
888 av_clear((AV *)varsv);
895 if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
896 methname = "TIEHANDLE";
897 how = PERL_MAGIC_tiedscalar;
898 /* For tied filehandles, we apply tiedscalar magic to the IO
899 slot of the GP rather than the GV itself. AMS 20010812 */
901 GvIOp(varsv) = newIO();
902 varsv = MUTABLE_SV(GvIOp(varsv));
905 if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
906 vivify_defelem(varsv);
907 varsv = LvTARG(varsv);
911 methname = "TIESCALAR";
912 how = PERL_MAGIC_tiedscalar;
916 if (sv_isobject(*MARK)) { /* Calls GET magic. */
917 ENTER_with_name("call_TIE");
918 PUSHSTACKi(PERLSI_MAGIC);
920 EXTEND(SP,(I32)items);
924 call_method(methname, G_SCALAR);
927 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
928 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
929 * wrong error message, and worse case, supreme action at a distance.
930 * (Sorry obfuscation writers. You're not going to be given this one.)
932 stash = gv_stashsv(*MARK, 0);
935 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"",
936 methname, SVfARG(*MARK));
937 else if (isGV(*MARK)) {
938 /* If the glob doesn't name an existing package, using
939 * SVfARG(*MARK) would yield "*Foo::Bar" or *main::Foo. So
940 * generate the name for the error message explicitly. */
941 SV *stashname = sv_newmortal();
942 gv_fullname4(stashname, (GV *) *MARK, NULL, FALSE);
943 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"",
944 methname, SVfARG(stashname));
947 SV *stashname = !SvPOK(*MARK) ? &PL_sv_no
948 : SvCUR(*MARK) ? *MARK
949 : newSVpvs_flags("main", SVs_TEMP);
950 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\""
951 " (perhaps you forgot to load \"%" SVf "\"?)",
952 methname, SVfARG(stashname), SVfARG(stashname));
955 else if (!(gv = gv_fetchmethod(stash, methname))) {
956 /* The effective name can only be NULL for stashes that have
957 * been deleted from the symbol table, which this one can't
958 * be, since we just looked it up by name.
960 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" HEKf "\"",
961 methname, HvENAME_HEK_NN(stash));
963 ENTER_with_name("call_TIE");
964 PUSHSTACKi(PERLSI_MAGIC);
966 EXTEND(SP,(I32)items);
970 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
976 if (sv_isobject(sv)) {
977 sv_unmagic(varsv, how);
978 /* Croak if a self-tie on an aggregate is attempted. */
979 if (varsv == SvRV(sv) &&
980 (SvTYPE(varsv) == SVt_PVAV ||
981 SvTYPE(varsv) == SVt_PVHV))
983 "Self-ties of arrays and hashes are not supported");
984 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
986 LEAVE_with_name("call_TIE");
987 SP = PL_stack_base + markoff;
993 /* also used for: pp_dbmclose() */
1000 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1001 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1003 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1006 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1007 !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
1009 if ((mg = SvTIED_mg(sv, how))) {
1010 SV * const obj = SvRV(SvTIED_obj(sv, mg));
1011 if (obj && SvSTASH(obj)) {
1012 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
1014 if (gv && isGV(gv) && (cv = GvCV(gv))) {
1016 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
1017 mXPUSHi(SvREFCNT(obj) - 1);
1019 ENTER_with_name("call_UNTIE");
1020 call_sv(MUTABLE_SV(cv), G_VOID);
1021 LEAVE_with_name("call_UNTIE");
1024 else if (mg && SvREFCNT(obj) > 1) {
1025 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
1026 "untie attempted while %" UVuf " inner references still exist",
1027 (UV)SvREFCNT(obj) - 1 ) ;
1031 sv_unmagic(sv, how) ;
1033 if (SvTYPE(sv) == SVt_PVHV) {
1034 /* If the tied hash was partway through iteration, free the iterator and
1035 * any key that it is pointing to. */
1037 if (HvLAZYDEL(sv) && (entry = HvEITER_get((HV *)sv))) {
1039 hv_free_ent((HV *)sv, entry);
1040 HvEITER_set(MUTABLE_HV(sv), 0);
1052 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1053 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1055 if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1058 if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1059 !(sv = defelem_target(sv, NULL))) goto ret_undef;
1061 if ((mg = SvTIED_mg(sv, how))) {
1062 SETs(SvTIED_obj(sv, mg));
1063 return NORMAL; /* PUTBACK not needed, pp_tied never moves SP */
1077 HV * const hv = MUTABLE_HV(POPs);
1078 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1079 stash = gv_stashsv(sv, 0);
1080 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1082 require_pv("AnyDBM_File.pm");
1084 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1085 DIE(aTHX_ "No dbm on this machine");
1095 mPUSHu(O_RDWR|O_CREAT);
1099 if (!SvOK(right)) right = &PL_sv_no;
1103 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1106 if (!sv_isobject(TOPs)) {
1114 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1116 if (sv_isobject(TOPs))
1121 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1122 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1139 struct timeval timebuf;
1140 struct timeval *tbuf = &timebuf;
1144 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1149 # if BYTEORDER & 0xf0000
1150 # define ORDERBYTE (0x88888888 - BYTEORDER)
1152 # define ORDERBYTE (0x4444 - BYTEORDER)
1158 for (i = 1; i <= 3; i++) {
1159 SV * const sv = svs[i] = SP[i];
1163 if (SvREADONLY(sv)) {
1164 if (!(SvPOK(sv) && SvCUR(sv) == 0))
1165 Perl_croak_no_modify();
1167 else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
1170 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1171 "Non-string passed as bitmask");
1172 if (SvGAMAGIC(sv)) {
1173 svs[i] = sv_newmortal();
1174 sv_copypv_nomg(svs[i], sv);
1177 SvPV_force_nomg_nolen(sv); /* force string conversion */
1184 /* little endians can use vecs directly */
1185 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1192 masksize = NFDBITS / NBBY;
1194 masksize = sizeof(long); /* documented int, everyone seems to use long */
1196 Zero(&fd_sets[0], 4, char*);
1199 # if SELECT_MIN_BITS == 1
1200 growsize = sizeof(fd_set);
1202 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1203 # undef SELECT_MIN_BITS
1204 # define SELECT_MIN_BITS __FD_SETSIZE
1206 /* If SELECT_MIN_BITS is greater than one we most probably will want
1207 * to align the sizes with SELECT_MIN_BITS/8 because for example
1208 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1209 * UNIX, Solaris, Darwin) the smallest quantum select() operates
1210 * on (sets/tests/clears bits) is 32 bits. */
1211 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1217 value = SvNV_nomg(sv);
1220 timebuf.tv_sec = (long)value;
1221 value -= (NV)timebuf.tv_sec;
1222 timebuf.tv_usec = (long)(value * 1000000.0);
1227 for (i = 1; i <= 3; i++) {
1229 if (!SvOK(sv) || SvCUR(sv) == 0) {
1236 Sv_Grow(sv, growsize);
1240 while (++j <= growsize) {
1244 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1246 Newx(fd_sets[i], growsize, char);
1247 for (offset = 0; offset < growsize; offset += masksize) {
1248 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1249 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1252 fd_sets[i] = SvPVX(sv);
1256 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1257 /* Can't make just the (void*) conditional because that would be
1258 * cpp #if within cpp macro, and not all compilers like that. */
1259 nfound = PerlSock_select(
1261 (Select_fd_set_t) fd_sets[1],
1262 (Select_fd_set_t) fd_sets[2],
1263 (Select_fd_set_t) fd_sets[3],
1264 (void*) tbuf); /* Workaround for compiler bug. */
1266 nfound = PerlSock_select(
1268 (Select_fd_set_t) fd_sets[1],
1269 (Select_fd_set_t) fd_sets[2],
1270 (Select_fd_set_t) fd_sets[3],
1273 for (i = 1; i <= 3; i++) {
1276 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1278 for (offset = 0; offset < growsize; offset += masksize) {
1279 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1280 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1282 Safefree(fd_sets[i]);
1285 SvSetMagicSV(SP[i], sv);
1292 if (GIMME_V == G_LIST && tbuf) {
1293 value = (NV)(timebuf.tv_sec) +
1294 (NV)(timebuf.tv_usec) / 1000000.0;
1299 DIE(aTHX_ "select not implemented");
1305 =for apidoc_section $GV
1307 =for apidoc setdefout
1309 Sets C<PL_defoutgv>, the default file handle for output, to the passed in
1310 typeglob. As C<PL_defoutgv> "owns" a reference on its typeglob, the reference
1311 count of the passed in typeglob is increased by one, and the reference count
1312 of the typeglob that C<PL_defoutgv> points to is decreased by one.
1318 Perl_setdefout(pTHX_ GV *gv)
1320 GV *oldgv = PL_defoutgv;
1322 PERL_ARGS_ASSERT_SETDEFOUT;
1324 SvREFCNT_inc_simple_void_NN(gv);
1326 SvREFCNT_dec(oldgv);
1333 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1334 GV * egv = GvEGVx(PL_defoutgv);
1339 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1340 gvp = hv && HvENAME(hv)
1341 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1343 if (gvp && *gvp == egv) {
1344 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1348 mXPUSHs(newRV(MUTABLE_SV(egv)));
1352 if (!GvIO(newdefout))
1353 gv_IOadd(newdefout);
1354 setdefout(newdefout);
1363 /* pp_coreargs pushes a NULL to indicate no args passed to
1366 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1367 IO *const io = GvIO(gv);
1373 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1375 const U8 gimme = GIMME_V;
1376 Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1377 if (gimme == G_SCALAR) {
1379 SvSetMagicSV_nosteal(TARG, TOPs);
1384 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1385 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1387 SETERRNO(EBADF,RMS_IFI);
1391 sv_setpvs(TARG, " ");
1392 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1393 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1394 /* Find out how many bytes the char needs */
1395 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1398 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1399 SvCUR_set(TARG,1+len);
1403 else SvUTF8_off(TARG);
1409 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1412 const U8 gimme = GIMME_V;
1414 PERL_ARGS_ASSERT_DOFORM;
1417 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1419 cx = cx_pushblock(CXt_FORMAT, gimme, PL_stack_sp, PL_savestack_ix);
1420 cx_pushformat(cx, cv, retop, gv);
1421 if (CvDEPTH(cv) >= 2)
1422 pad_push(CvPADLIST(cv), CvDEPTH(cv));
1423 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1425 setdefout(gv); /* locally select filehandle so $% et al work */
1442 gv = MUTABLE_GV(POPs);
1459 SV * const tmpsv = sv_newmortal();
1460 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1461 DIE(aTHX_ "Undefined format \"%" SVf "\" called", SVfARG(tmpsv));
1463 IoFLAGS(io) &= ~IOf_DIDTOP;
1464 RETURNOP(doform(cv,gv,PL_op->op_next));
1470 GV * const gv = CX_CUR()->blk_format.gv;
1471 IO * const io = GvIOp(gv);
1476 bool is_return = cBOOL(PL_op->op_type == OP_RETURN);
1478 if (is_return || !io || !(ofp = IoOFP(io)))
1481 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1482 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1484 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1485 PL_formtarget != PL_toptarget)
1489 if (!IoTOP_GV(io)) {
1492 if (!IoTOP_NAME(io)) {
1494 if (!IoFMT_NAME(io))
1495 IoFMT_NAME(io) = savepv(GvNAME(gv));
1496 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%" HEKf "_TOP",
1497 HEKfARG(GvNAME_HEK(gv))));
1498 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1499 if ((topgv && GvFORM(topgv)) ||
1500 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1501 IoTOP_NAME(io) = savesvpv(topname);
1503 IoTOP_NAME(io) = savepvs("top");
1505 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1506 if (!topgv || !GvFORM(topgv)) {
1507 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1510 IoTOP_GV(io) = topgv;
1512 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1513 I32 lines = IoLINES_LEFT(io);
1514 const char *s = SvPVX_const(PL_formtarget);
1515 const char *e = SvEND(PL_formtarget);
1516 if (lines <= 0) /* Yow, header didn't even fit!!! */
1518 while (lines-- > 0) {
1519 s = (char *) memchr(s, '\n', e - s);
1525 const STRLEN save = SvCUR(PL_formtarget);
1526 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1527 do_print(PL_formtarget, ofp);
1528 SvCUR_set(PL_formtarget, save);
1529 sv_chop(PL_formtarget, s);
1530 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1533 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1534 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1535 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1537 PL_formtarget = PL_toptarget;
1538 IoFLAGS(io) |= IOf_DIDTOP;
1540 assert(fgv); /* IoTOP_GV(io) should have been set above */
1543 SV * const sv = sv_newmortal();
1544 gv_efullname4(sv, fgv, NULL, FALSE);
1545 DIE(aTHX_ "Undefined top format \"%" SVf "\" called", SVfARG(sv));
1547 return doform(cv, gv, PL_op);
1552 assert(CxTYPE(cx) == CXt_FORMAT);
1553 SP = PL_stack_base + cx->blk_oldsp; /* ignore retval of formline */
1557 retop = cx->blk_sub.retop;
1563 /* XXX the semantics of doing 'return' in a format aren't documented.
1564 * Currently we ignore any args to 'return' and just return
1565 * a single undef in both scalar and list contexts
1567 PUSHs(&PL_sv_undef);
1568 else if (!io || !(fp = IoOFP(io))) {
1569 if (io && IoIFP(io))
1570 report_wrongway_fh(gv, '<');
1576 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1577 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1579 if (!do_print(PL_formtarget, fp))
1582 FmLINES(PL_formtarget) = 0;
1583 SvCUR_set(PL_formtarget, 0);
1584 *SvEND(PL_formtarget) = '\0';
1585 if (IoFLAGS(io) & IOf_FLUSH)
1586 (void)PerlIO_flush(fp);
1590 PL_formtarget = PL_bodytarget;
1596 dSP; dMARK; dORIGMARK;
1600 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1601 IO *const io = GvIO(gv);
1603 /* Treat empty list as "" */
1604 if (MARK == SP) XPUSHs(&PL_sv_no);
1607 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1609 if (MARK == ORIGMARK) {
1612 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1615 return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1617 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1624 SETERRNO(EBADF,RMS_IFI);
1627 else if (!(fp = IoOFP(io))) {
1629 report_wrongway_fh(gv, '<');
1630 else if (ckWARN(WARN_CLOSED))
1632 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1636 SV *sv = sv_newmortal();
1637 do_sprintf(sv, SP - MARK, MARK + 1);
1638 if (!do_print(sv, fp))
1641 if (IoFLAGS(io) & IOf_FLUSH)
1642 if (PerlIO_flush(fp) == EOF)
1651 PUSHs(&PL_sv_undef);
1658 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1659 const int mode = POPi;
1660 SV * const sv = POPs;
1661 GV * const gv = MUTABLE_GV(POPs);
1664 /* Need TIEHANDLE method ? */
1665 const char * const tmps = SvPV_const(sv, len);
1666 if (do_open_raw(gv, tmps, len, mode, perm, NULL)) {
1667 IoLINES(GvIOp(gv)) = 0;
1671 PUSHs(&PL_sv_undef);
1677 /* also used for: pp_read() and pp_recv() (where supported) */
1681 dSP; dMARK; dORIGMARK; dTARGET;
1695 bool charstart = FALSE;
1696 STRLEN charskip = 0;
1698 GV * const gv = MUTABLE_GV(*++MARK);
1701 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1702 && gv && (io = GvIO(gv)) )
1704 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1706 return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1707 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1717 length = SvIVx(*++MARK);
1719 DIE(aTHX_ "Negative length");
1722 offset = SvIVx(*++MARK);
1726 if (!io || !IoIFP(io)) {
1728 SETERRNO(EBADF,RMS_IFI);
1732 /* Note that fd can here validly be -1, don't check it yet. */
1733 fd = PerlIO_fileno(IoIFP(io));
1735 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1736 if (PL_op->op_type == OP_SYSREAD || PL_op->op_type == OP_RECV) {
1738 "%s() isn't allowed on :utf8 handles",
1741 buffer = SvPVutf8_force(bufsv, blen);
1742 /* UTF-8 may not have been set if they are all low bytes */
1747 buffer = SvPV_force(bufsv, blen);
1748 buffer_utf8 = DO_UTF8(bufsv);
1750 if (DO_UTF8(bufsv)) {
1751 blen = sv_len_utf8_nomg(bufsv);
1760 if (PL_op->op_type == OP_RECV) {
1761 Sock_size_t bufsize;
1762 char namebuf[MAXPATHLEN];
1764 SETERRNO(EBADF,SS_IVCHAN);
1767 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1768 bufsize = sizeof (struct sockaddr_in);
1770 bufsize = sizeof namebuf;
1772 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1776 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1777 /* 'offset' means 'flags' here */
1778 count = PerlSock_recvfrom(fd, buffer, length, offset,
1779 (struct sockaddr *)namebuf, &bufsize);
1782 /* MSG_TRUNC can give oversized count; quietly lose it */
1785 SvCUR_set(bufsv, count);
1786 *SvEND(bufsv) = '\0';
1787 (void)SvPOK_only(bufsv);
1791 /* This should not be marked tainted if the fp is marked clean */
1792 if (!(IoFLAGS(io) & IOf_UNTAINT))
1793 SvTAINTED_on(bufsv);
1795 #if defined(__CYGWIN__)
1796 /* recvfrom() on cygwin doesn't set bufsize at all for
1797 connected sockets, leaving us with trash in the returned
1798 name, so use the same test as the Win32 code to check if it
1799 wasn't set, and set it [perl #118843] */
1800 if (bufsize == sizeof namebuf)
1803 sv_setpvn(TARG, namebuf, bufsize);
1809 if (-offset > (SSize_t)blen)
1810 DIE(aTHX_ "Offset outside string");
1813 if (DO_UTF8(bufsv)) {
1814 /* convert offset-as-chars to offset-as-bytes */
1815 if (offset >= (SSize_t)blen)
1816 offset += SvCUR(bufsv) - blen;
1818 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1822 /* Reestablish the fd in case it shifted from underneath us. */
1823 fd = PerlIO_fileno(IoIFP(io));
1825 orig_size = SvCUR(bufsv);
1826 /* Allocating length + offset + 1 isn't perfect in the case of reading
1827 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1829 (should be 2 * length + offset + 1, or possibly something longer if
1830 IN_ENCODING Is true) */
1831 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1832 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1833 Zero(buffer+orig_size, offset-orig_size, char);
1835 buffer = buffer + offset;
1837 read_target = bufsv;
1839 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1840 concatenate it to the current buffer. */
1842 /* Truncate the existing buffer to the start of where we will be
1844 SvCUR_set(bufsv, offset);
1846 read_target = sv_newmortal();
1847 SvUPGRADE(read_target, SVt_PV);
1848 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1851 if (PL_op->op_type == OP_SYSREAD) {
1852 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1853 if (IoTYPE(io) == IoTYPE_SOCKET) {
1855 SETERRNO(EBADF,SS_IVCHAN);
1859 count = PerlSock_recv(fd, buffer, length, 0);
1865 SETERRNO(EBADF,RMS_IFI);
1869 count = PerlLIO_read(fd, buffer, length);
1874 count = PerlIO_read(IoIFP(io), buffer, length);
1875 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1876 if (count == 0 && PerlIO_error(IoIFP(io)))
1880 if (IoTYPE(io) == IoTYPE_WRONLY)
1881 report_wrongway_fh(gv, '>');
1884 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1885 *SvEND(read_target) = '\0';
1886 (void)SvPOK_only(read_target);
1887 if (fp_utf8 && !IN_BYTES) {
1888 /* Look at utf8 we got back and count the characters */
1889 const char *bend = buffer + count;
1890 while (buffer < bend) {
1892 skip = UTF8SKIP(buffer);
1895 if (buffer - charskip + skip > bend) {
1896 /* partial character - try for rest of it */
1897 length = skip - (bend-buffer);
1898 offset = bend - SvPVX_const(bufsv);
1910 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1911 provided amount read (count) was what was requested (length)
1913 if (got < wanted && count == length) {
1914 length = wanted - got;
1915 offset = bend - SvPVX_const(bufsv);
1918 /* return value is character count */
1922 else if (buffer_utf8) {
1923 /* Let svcatsv upgrade the bytes we read in to utf8.
1924 The buffer is a mortal so will be freed soon. */
1925 sv_catsv_nomg(bufsv, read_target);
1928 /* This should not be marked tainted if the fp is marked clean */
1929 if (!(IoFLAGS(io) & IOf_UNTAINT))
1930 SvTAINTED_on(bufsv);
1941 /* also used for: pp_send() where defined */
1945 dSP; dMARK; dORIGMARK; dTARGET;
1950 const int op_type = PL_op->op_type;
1953 GV *const gv = MUTABLE_GV(*++MARK);
1954 IO *const io = GvIO(gv);
1957 if (op_type == OP_SYSWRITE && io) {
1958 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1960 if (MARK == SP - 1) {
1962 mXPUSHi(sv_len(sv));
1966 return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1967 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1977 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1979 if (io && IoIFP(io))
1980 report_wrongway_fh(gv, '<');
1983 SETERRNO(EBADF,RMS_IFI);
1986 fd = PerlIO_fileno(IoIFP(io));
1988 SETERRNO(EBADF,SS_IVCHAN);
1993 /* Do this first to trigger any overloading. */
1994 buffer = SvPV_const(bufsv, blen);
1995 doing_utf8 = DO_UTF8(bufsv);
1997 if (PerlIO_isutf8(IoIFP(io))) {
1999 "%s() isn't allowed on :utf8 handles",
2002 else if (doing_utf8) {
2003 STRLEN tmplen = blen;
2004 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
2007 buffer = (char *) tmpbuf;
2011 assert((char *)result == buffer);
2012 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
2017 if (op_type == OP_SEND) {
2018 const int flags = SvIVx(*++MARK);
2021 char * const sockbuf = SvPVx(*++MARK, mlen);
2022 retval = PerlSock_sendto(fd, buffer, blen,
2023 flags, (struct sockaddr *)sockbuf, mlen);
2026 retval = PerlSock_send(fd, buffer, blen, flags);
2032 Size_t length = 0; /* This length is in characters. */
2038 #if Size_t_size > IVSIZE
2039 length = (Size_t)SvNVx(*++MARK);
2041 length = (Size_t)SvIVx(*++MARK);
2043 if ((SSize_t)length < 0) {
2045 DIE(aTHX_ "Negative length");
2050 offset = SvIVx(*++MARK);
2052 if (-offset > (IV)blen) {
2054 DIE(aTHX_ "Offset outside string");
2057 } else if (offset > (IV)blen) {
2059 DIE(aTHX_ "Offset outside string");
2063 if (length > blen - offset)
2064 length = blen - offset;
2065 buffer = buffer+offset;
2067 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2068 if (IoTYPE(io) == IoTYPE_SOCKET) {
2069 retval = PerlSock_send(fd, buffer, length, 0);
2074 /* See the note at doio.c:do_print about filesize limits. --jhi */
2075 retval = PerlLIO_write(fd, buffer, length);
2084 #if Size_t_size > IVSIZE
2104 * in Perl 5.12 and later, the additional parameter is a bitmask:
2107 * 2 = eof() <- ARGV magic
2109 * I'll rely on the compiler's trace flow analysis to decide whether to
2110 * actually assign this out here, or punt it into the only block where it is
2111 * used. Doing it out here is DRY on the condition logic.
2116 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2122 if (PL_op->op_flags & OPf_SPECIAL) {
2123 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
2127 gv = PL_last_in_gv; /* eof */
2135 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2136 return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2139 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2140 if (io && !IoIFP(io)) {
2141 if ((IoFLAGS(io) & IOf_START) && av_count(GvAVn(gv)) == 0) {
2144 IoFLAGS(io) &= ~IOf_START;
2145 do_open6(gv, "-", 1, NULL, NULL, 0);
2153 *svp = newSVpvs("-");
2155 else if (!nextargv(gv, FALSE))
2160 PUSHs(boolSV(do_eof(gv)));
2170 if (MAXARG != 0 && (TOPs || POPs))
2171 PL_last_in_gv = MUTABLE_GV(POPs);
2178 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2180 return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2185 SETERRNO(EBADF,RMS_IFI);
2190 #if LSEEKSIZE > IVSIZE
2191 PUSHn( (NV)do_tell(gv) );
2193 PUSHi( (IV)do_tell(gv) );
2199 /* also used for: pp_seek() */
2204 const int whence = POPi;
2205 #if LSEEKSIZE > IVSIZE
2206 const Off_t offset = (Off_t)SvNVx(POPs);
2208 const Off_t offset = (Off_t)SvIVx(POPs);
2211 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2212 IO *const io = GvIO(gv);
2215 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2217 #if LSEEKSIZE > IVSIZE
2218 SV *const offset_sv = newSVnv((NV) offset);
2220 SV *const offset_sv = newSViv(offset);
2223 return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2228 if (PL_op->op_type == OP_SEEK)
2229 PUSHs(boolSV(do_seek(gv, offset, whence)));
2231 const Off_t sought = do_sysseek(gv, offset, whence);
2233 PUSHs(&PL_sv_undef);
2235 SV* const sv = sought ?
2236 #if LSEEKSIZE > IVSIZE
2241 : newSVpvn(zero_but_true, ZBTLEN);
2251 /* There seems to be no consensus on the length type of truncate()
2252 * and ftruncate(), both off_t and size_t have supporters. In
2253 * general one would think that when using large files, off_t is
2254 * at least as wide as size_t, so using an off_t should be okay. */
2255 /* XXX Configure probe for the length type of *truncate() needed XXX */
2258 #if Off_t_size > IVSIZE
2263 /* Checking for length < 0 is problematic as the type might or
2264 * might not be signed: if it is not, clever compilers will moan. */
2265 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2268 SV * const sv = POPs;
2273 if (PL_op->op_flags & OPf_SPECIAL
2274 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2275 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2282 TAINT_PROPER("truncate");
2283 if (!(fp = IoIFP(io))) {
2287 int fd = PerlIO_fileno(fp);
2289 SETERRNO(EBADF,RMS_IFI);
2293 SETERRNO(EINVAL, LIB_INVARG);
2298 if (ftruncate(fd, len) < 0)
2300 if (my_chsize(fd, len) < 0)
2308 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2309 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2310 goto do_ftruncate_io;
2313 const char * const name = SvPV_nomg_const_nolen(sv);
2314 TAINT_PROPER("truncate");
2316 if (truncate(name, len) < 0)
2323 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
2324 mode |= O_LARGEFILE; /* Transparently largefiley. */
2327 /* On open(), the Win32 CRT tries to seek around text
2328 * files using 32-bit offsets, which causes the open()
2329 * to fail on large files, so open in binary mode.
2333 tmpfd = PerlLIO_open_cloexec(name, mode);
2338 if (my_chsize(tmpfd, len) < 0)
2340 PerlLIO_close(tmpfd);
2349 SETERRNO(EBADF,RMS_IFI);
2355 /* also used for: pp_fcntl() */
2360 SV * const argsv = POPs;
2361 const unsigned int func = POPu;
2363 GV * const gv = MUTABLE_GV(POPs);
2364 IO * const io = GvIOn(gv);
2370 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2374 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2377 s = SvPV_force(argsv, len);
2378 need = IOCPARM_LEN(func);
2380 s = Sv_Grow(argsv, need + 1);
2381 SvCUR_set(argsv, need);
2384 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2387 retval = SvIV(argsv);
2388 s = INT2PTR(char*,retval); /* ouch */
2391 optype = PL_op->op_type;
2392 TAINT_PROPER(PL_op_desc[optype]);
2394 if (optype == OP_IOCTL)
2396 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2398 DIE(aTHX_ "ioctl is not implemented");
2402 DIE(aTHX_ "fcntl is not implemented");
2403 #elif defined(OS2) && defined(__EMX__)
2404 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2406 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2409 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2411 if (s[SvCUR(argsv)] != 17)
2412 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2414 s[SvCUR(argsv)] = 0; /* put our null back */
2415 SvSETMAGIC(argsv); /* Assume it has changed */
2424 PUSHp(zero_but_true, ZBTLEN);
2435 const int argtype = POPi;
2436 GV * const gv = MUTABLE_GV(POPs);
2437 IO *const io = GvIO(gv);
2438 PerlIO *const fp = io ? IoIFP(io) : NULL;
2440 /* XXX Looks to me like io is always NULL at this point */
2442 (void)PerlIO_flush(fp);
2443 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2448 SETERRNO(EBADF,RMS_IFI);
2453 DIE(aTHX_ PL_no_func, "flock");
2464 const int protocol = POPi;
2465 const int type = POPi;
2466 const int domain = POPi;
2467 GV * const gv = MUTABLE_GV(POPs);
2468 IO * const io = GvIOn(gv);
2472 do_close(gv, FALSE);
2474 TAINT_PROPER("socket");
2475 fd = PerlSock_socket_cloexec(domain, type, protocol);
2479 IoIFP(io) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2480 IoOFP(io) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE);
2481 IoTYPE(io) = IoTYPE_SOCKET;
2482 if (!IoIFP(io) || !IoOFP(io)) {
2483 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2484 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2485 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2495 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2498 const int protocol = POPi;
2499 const int type = POPi;
2500 const int domain = POPi;
2502 GV * const gv2 = MUTABLE_GV(POPs);
2503 IO * const io2 = GvIOn(gv2);
2504 GV * const gv1 = MUTABLE_GV(POPs);
2505 IO * const io1 = GvIOn(gv1);
2508 do_close(gv1, FALSE);
2510 do_close(gv2, FALSE);
2512 TAINT_PROPER("socketpair");
2513 if (PerlSock_socketpair_cloexec(domain, type, protocol, fd) < 0)
2515 IoIFP(io1) = PerlIO_fdopen(fd[0], "r" SOCKET_OPEN_MODE);
2516 IoOFP(io1) = PerlIO_fdopen(fd[0], "w" SOCKET_OPEN_MODE);
2517 IoTYPE(io1) = IoTYPE_SOCKET;
2518 IoIFP(io2) = PerlIO_fdopen(fd[1], "r" SOCKET_OPEN_MODE);
2519 IoOFP(io2) = PerlIO_fdopen(fd[1], "w" SOCKET_OPEN_MODE);
2520 IoTYPE(io2) = IoTYPE_SOCKET;
2521 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2522 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2523 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2524 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2525 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2526 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2527 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2533 DIE(aTHX_ PL_no_sock_func, "socketpair");
2539 /* also used for: pp_connect() */
2544 SV * const addrsv = POPs;
2545 /* OK, so on what platform does bind modify addr? */
2547 GV * const gv = MUTABLE_GV(POPs);
2548 IO * const io = GvIOn(gv);
2555 fd = PerlIO_fileno(IoIFP(io));
2559 addr = SvPV_const(addrsv, len);
2560 op_type = PL_op->op_type;
2561 TAINT_PROPER(PL_op_desc[op_type]);
2562 if ((op_type == OP_BIND
2563 ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
2564 : PerlSock_connect(fd, (struct sockaddr *)addr, len))
2572 SETERRNO(EBADF,SS_IVCHAN);
2579 const int backlog = POPi;
2580 GV * const gv = MUTABLE_GV(POPs);
2581 IO * const io = GvIOn(gv);
2586 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2593 SETERRNO(EBADF,SS_IVCHAN);
2601 char namebuf[MAXPATHLEN];
2602 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2603 Sock_size_t len = sizeof (struct sockaddr_in);
2605 Sock_size_t len = sizeof namebuf;
2607 GV * const ggv = MUTABLE_GV(POPs);
2608 GV * const ngv = MUTABLE_GV(POPs);
2611 IO * const gstio = GvIO(ggv);
2612 if (!gstio || !IoIFP(gstio))
2616 fd = PerlSock_accept_cloexec(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2619 /* Some platforms indicate zero length when an AF_UNIX client is
2620 * not bound. Simulate a non-zero-length sockaddr structure in
2622 namebuf[0] = 0; /* sun_len */
2623 namebuf[1] = AF_UNIX; /* sun_family */
2631 do_close(ngv, FALSE);
2632 IoIFP(nstio) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE);
2633 IoOFP(nstio) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE);
2634 IoTYPE(nstio) = IoTYPE_SOCKET;
2635 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2636 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2637 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2638 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2642 #ifdef __SCO_VERSION__
2643 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2646 PUSHp(namebuf, len);
2650 report_evil_fh(ggv);
2651 SETERRNO(EBADF,SS_IVCHAN);
2661 const int how = POPi;
2662 GV * const gv = MUTABLE_GV(POPs);
2663 IO * const io = GvIOn(gv);
2668 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2673 SETERRNO(EBADF,SS_IVCHAN);
2678 /* also used for: pp_gsockopt() */
2683 const int optype = PL_op->op_type;
2684 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2685 const unsigned int optname = (unsigned int) POPi;
2686 const unsigned int lvl = (unsigned int) POPi;
2687 GV * const gv = MUTABLE_GV(POPs);
2688 IO * const io = GvIOn(gv);
2695 fd = PerlIO_fileno(IoIFP(io));
2700 /* Note: there used to be an explicit SvGROW(sv,257) here, but
2701 * this is redundant given the sv initialization ternary above */
2702 (void)SvPOK_only(sv);
2706 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2709 /* XXX Configure test: does getsockopt set the length properly? */
2723 buf = SvPVbyte_nomg(sv, l);
2727 aint = (int)SvIV_nomg(sv);
2728 buf = (const char *) &aint;
2731 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2741 SETERRNO(EBADF,SS_IVCHAN);
2748 /* also used for: pp_getsockname() */
2753 const int optype = PL_op->op_type;
2754 GV * const gv = MUTABLE_GV(POPs);
2755 IO * const io = GvIOn(gv);
2763 #ifdef HAS_SOCKADDR_STORAGE
2764 len = sizeof(struct sockaddr_storage);
2768 sv = sv_2mortal(newSV(len+1));
2769 (void)SvPOK_only(sv);
2772 fd = PerlIO_fileno(IoIFP(io));
2776 case OP_GETSOCKNAME:
2777 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2780 case OP_GETPEERNAME:
2781 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2783 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2785 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";
2786 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2787 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2788 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2789 sizeof(u_short) + sizeof(struct in_addr))) {
2796 #ifdef BOGUS_GETNAME_RETURN
2797 /* Interactive Unix, getpeername() and getsockname()
2798 does not return valid namelen */
2799 if (len == BOGUS_GETNAME_RETURN)
2800 len = sizeof(struct sockaddr);
2809 SETERRNO(EBADF,SS_IVCHAN);
2818 /* also used for: pp_lstat() */
2829 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2830 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2831 if (PL_op->op_type == OP_LSTAT) {
2832 if (gv != PL_defgv) {
2833 do_fstat_warning_check:
2834 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2835 "lstat() on filehandle%s%" SVf,
2838 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2840 } else if (PL_laststype != OP_LSTAT)
2841 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2842 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2845 if (gv == PL_defgv) {
2846 if (PL_laststatval < 0)
2847 SETERRNO(EBADF,RMS_IFI);
2850 PL_laststype = OP_STAT;
2851 PL_statgv = gv ? gv : (GV *)io;
2852 SvPVCLEAR(PL_statname);
2858 int fd = PerlIO_fileno(IoIFP(io));
2861 PL_laststatval = -1;
2862 SETERRNO(EBADF,RMS_IFI);
2864 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
2866 } else if (IoDIRP(io)) {
2868 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2871 PL_laststatval = -1;
2872 SETERRNO(EBADF,RMS_IFI);
2876 PL_laststatval = -1;
2877 SETERRNO(EBADF,RMS_IFI);
2881 if (PL_laststatval < 0) {
2889 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2890 io = MUTABLE_IO(SvRV(sv));
2891 if (PL_op->op_type == OP_LSTAT)
2892 goto do_fstat_warning_check;
2893 goto do_fstat_have_io;
2895 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2896 temp = SvPV_nomg_const(sv, len);
2897 sv_setpv(PL_statname, temp);
2899 PL_laststype = PL_op->op_type;
2900 file = SvPV_nolen_const(PL_statname);
2901 if (!IS_SAFE_PATHNAME(temp, len, OP_NAME(PL_op))) {
2902 PL_laststatval = -1;
2904 else if (PL_op->op_type == OP_LSTAT)
2905 PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
2907 PL_laststatval = PerlLIO_stat(file, &PL_statcache);
2908 if (PL_laststatval < 0) {
2909 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
2910 /* PL_warn_nl is constant */
2911 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
2912 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2913 GCC_DIAG_RESTORE_STMT;
2920 if (gimme != G_LIST) {
2921 if (gimme != G_VOID)
2922 XPUSHs(boolSV(max));
2928 #if ST_DEV_SIZE < IVSIZE || (ST_DEV_SIZE == IVSIZE && ST_DEV_SIGN < 0)
2929 mPUSHi(PL_statcache.st_dev);
2930 #elif ST_DEV_SIZE == IVSIZE
2931 mPUSHu(PL_statcache.st_dev);
2933 # if ST_DEV_SIGN < 0
2934 if (LIKELY((IV)PL_statcache.st_dev == PL_statcache.st_dev)) {
2935 mPUSHi((IV)PL_statcache.st_dev);
2938 if (LIKELY((UV)PL_statcache.st_dev == PL_statcache.st_dev)) {
2939 mPUSHu((UV)PL_statcache.st_dev);
2943 char buf[sizeof(PL_statcache.st_dev)*3+1];
2944 /* sv_catpvf() casts 'j' size values down to IV, so it
2945 isn't suitable for use here.
2947 # if defined(I_INTTYPES) && defined(HAS_SNPRINTF)
2948 # if ST_DEV_SIGN < 0
2949 int size = snprintf(buf, sizeof(buf), "%" PRIdMAX, (intmax_t)PL_statcache.st_dev);
2951 int size = snprintf(buf, sizeof(buf), "%" PRIuMAX, (uintmax_t)PL_statcache.st_dev);
2953 STATIC_ASSERT_STMT(sizeof(intmax_t) >= sizeof(PL_statcache.st_dev));
2956 # error extraordinarily large st_dev but no inttypes.h or no snprintf
2962 * We try to represent st_ino as a native IV or UV where
2963 * possible, but fall back to a decimal string where
2964 * necessary. The code to generate these decimal strings
2965 * is quite obtuse, because (a) we're portable to non-POSIX
2966 * platforms where st_ino might be signed; (b) we didn't
2967 * necessarily detect at Configure time whether st_ino is
2968 * signed; (c) we're portable to non-POSIX platforms where
2969 * ino_t isn't defined, so have no name for the type of
2970 * st_ino; and (d) sprintf() doesn't necessarily support
2971 * integers as large as st_ino.
2975 CLANG_DIAG_IGNORE_STMT(-Wtautological-compare);
2976 GCC_DIAG_IGNORE_STMT(-Wtype-limits);
2977 neg = PL_statcache.st_ino < 0;
2978 GCC_DIAG_RESTORE_STMT;
2979 CLANG_DIAG_RESTORE_STMT;
2981 s.st_ino = (IV)PL_statcache.st_ino;
2982 if (LIKELY(s.st_ino == PL_statcache.st_ino)) {
2985 char buf[sizeof(s.st_ino)*3+1], *p;
2986 s.st_ino = PL_statcache.st_ino;
2987 for (p = buf + sizeof(buf); p != buf+1; ) {
2989 t.st_ino = s.st_ino / 10;
2990 *--p = '0' + (int)(t.st_ino*10 - s.st_ino);
2991 s.st_ino = t.st_ino;
2996 mPUSHp(p, buf+sizeof(buf) - p);
2999 s.st_ino = (UV)PL_statcache.st_ino;
3000 if (LIKELY(s.st_ino == PL_statcache.st_ino)) {
3003 char buf[sizeof(s.st_ino)*3], *p;
3004 s.st_ino = PL_statcache.st_ino;
3005 for (p = buf + sizeof(buf); p != buf; ) {
3007 t.st_ino = s.st_ino / 10;
3008 *--p = '0' + (int)(s.st_ino - t.st_ino*10);
3009 s.st_ino = t.st_ino;
3013 mPUSHp(p, buf+sizeof(buf) - p);
3017 mPUSHu(PL_statcache.st_mode);
3018 mPUSHu(PL_statcache.st_nlink);
3020 sv_setuid(PUSHmortal, PL_statcache.st_uid);
3021 sv_setgid(PUSHmortal, PL_statcache.st_gid);
3023 #ifdef USE_STAT_RDEV
3024 mPUSHi(PL_statcache.st_rdev);
3026 PUSHs(newSVpvs_flags("", SVs_TEMP));
3028 #if Off_t_size > IVSIZE
3029 mPUSHn(PL_statcache.st_size);
3031 mPUSHi(PL_statcache.st_size);
3034 mPUSHn(PL_statcache.st_atime);
3035 mPUSHn(PL_statcache.st_mtime);
3036 mPUSHn(PL_statcache.st_ctime);
3038 mPUSHi(PL_statcache.st_atime);
3039 mPUSHi(PL_statcache.st_mtime);
3040 mPUSHi(PL_statcache.st_ctime);
3042 #ifdef USE_STAT_BLOCKS
3043 mPUSHu(PL_statcache.st_blksize);
3044 mPUSHu(PL_statcache.st_blocks);
3046 PUSHs(newSVpvs_flags("", SVs_TEMP));
3047 PUSHs(newSVpvs_flags("", SVs_TEMP));
3053 /* All filetest ops avoid manipulating the perl stack pointer in their main
3054 bodies (since commit d2c4d2d1e22d3125), and return using either
3055 S_ft_return_false() or S_ft_return_true(). These two helper functions are
3056 the only two which manipulate the perl stack. To ensure that no stack
3057 manipulation macros are used, the filetest ops avoid defining a local copy
3058 of the stack pointer with dSP. */
3060 /* If the next filetest is stacked up with this one
3061 (PL_op->op_private & OPpFT_STACKING), we leave
3062 the original argument on the stack for success,
3063 and skip the stacked operators on failure.
3064 The next few macros/functions take care of this.
3068 S_ft_return_false(pTHX_ SV *ret) {
3072 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
3076 if (PL_op->op_private & OPpFT_STACKING) {
3077 while (next && OP_IS_FILETEST(next->op_type)
3078 && next->op_private & OPpFT_STACKED)
3079 next = next->op_next;
3084 PERL_STATIC_INLINE OP *
3085 S_ft_return_true(pTHX_ SV *ret) {
3087 if (PL_op->op_flags & OPf_REF)
3088 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
3089 else if (!(PL_op->op_private & OPpFT_STACKING))
3095 #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
3096 #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
3097 #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
3099 #define tryAMAGICftest_MG(chr) STMT_START { \
3100 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
3101 && PL_op->op_flags & OPf_KIDS) { \
3102 OP *next = S_try_amagic_ftest(aTHX_ chr); \
3103 if (next) return next; \
3108 S_try_amagic_ftest(pTHX_ char chr) {
3109 SV *const arg = *PL_stack_sp;
3112 if (!(PL_op->op_private & OPpFT_STACKED)) SvGETMAGIC(arg);
3116 const char tmpchr = chr;
3117 SV * const tmpsv = amagic_call(arg,
3118 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
3119 ftest_amg, AMGf_unary);
3124 return SvTRUE(tmpsv)
3125 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
3131 /* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec()
3137 /* Not const, because things tweak this below. Not bool, because there's
3138 no guarantee that OPpFT_ACCESS is <= CHAR_MAX */
3139 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3140 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3141 /* Giving some sort of initial value silences compilers. */
3143 int access_mode = R_OK;
3145 int access_mode = 0;
3148 /* access_mode is never used, but leaving use_access in makes the
3149 conditional compiling below much clearer. */
3152 Mode_t stat_mode = S_IRUSR;
3154 bool effective = FALSE;
3157 switch (PL_op->op_type) {
3158 case OP_FTRREAD: opchar = 'R'; break;
3159 case OP_FTRWRITE: opchar = 'W'; break;
3160 case OP_FTREXEC: opchar = 'X'; break;
3161 case OP_FTEREAD: opchar = 'r'; break;
3162 case OP_FTEWRITE: opchar = 'w'; break;
3163 case OP_FTEEXEC: opchar = 'x'; break;
3165 tryAMAGICftest_MG(opchar);
3167 switch (PL_op->op_type) {
3169 #if !(defined(HAS_ACCESS) && defined(R_OK))
3175 #if defined(HAS_ACCESS) && defined(W_OK)
3180 stat_mode = S_IWUSR;
3184 #if defined(HAS_ACCESS) && defined(X_OK)
3189 stat_mode = S_IXUSR;
3193 #ifdef PERL_EFF_ACCESS
3196 stat_mode = S_IWUSR;
3200 #ifndef PERL_EFF_ACCESS
3207 #ifdef PERL_EFF_ACCESS
3212 stat_mode = S_IXUSR;
3218 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3220 const char *name = SvPV(*PL_stack_sp, len);
3221 if (!IS_SAFE_PATHNAME(name, len, OP_NAME(PL_op))) {
3224 else if (effective) {
3225 # ifdef PERL_EFF_ACCESS
3226 result = PERL_EFF_ACCESS(name, access_mode);
3228 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3234 result = access(name, access_mode);
3236 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3247 result = my_stat_flags(0);
3250 if (cando(stat_mode, effective, &PL_statcache))
3256 /* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */
3261 const int op_type = PL_op->op_type;
3265 case OP_FTIS: opchar = 'e'; break;
3266 case OP_FTSIZE: opchar = 's'; break;
3267 case OP_FTMTIME: opchar = 'M'; break;
3268 case OP_FTCTIME: opchar = 'C'; break;
3269 case OP_FTATIME: opchar = 'A'; break;
3271 tryAMAGICftest_MG(opchar);
3273 result = my_stat_flags(0);
3276 if (op_type == OP_FTIS)
3279 /* You can't dTARGET inside OP_FTIS, because you'll get
3280 "panic: pad_sv po" - the op is not flagged to have a target. */
3284 #if Off_t_size > IVSIZE
3285 sv_setnv(TARG, (NV)PL_statcache.st_size);
3287 sv_setiv(TARG, (IV)PL_statcache.st_size);
3292 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3296 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3300 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3304 return SvTRUE_nomg_NN(TARG)
3305 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3310 /* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned()
3311 * pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock()
3312 * pp_ftsuid() pp_ftsvtx() pp_ftzero() */
3319 switch (PL_op->op_type) {
3320 case OP_FTROWNED: opchar = 'O'; break;
3321 case OP_FTEOWNED: opchar = 'o'; break;
3322 case OP_FTZERO: opchar = 'z'; break;
3323 case OP_FTSOCK: opchar = 'S'; break;
3324 case OP_FTCHR: opchar = 'c'; break;
3325 case OP_FTBLK: opchar = 'b'; break;
3326 case OP_FTFILE: opchar = 'f'; break;
3327 case OP_FTDIR: opchar = 'd'; break;
3328 case OP_FTPIPE: opchar = 'p'; break;
3329 case OP_FTSUID: opchar = 'u'; break;
3330 case OP_FTSGID: opchar = 'g'; break;
3331 case OP_FTSVTX: opchar = 'k'; break;
3333 tryAMAGICftest_MG(opchar);
3335 result = my_stat_flags(0);
3338 switch (PL_op->op_type) {
3340 if (PL_statcache.st_uid == PerlProc_getuid())
3344 if (PL_statcache.st_uid == PerlProc_geteuid())
3348 if (PL_statcache.st_size == 0)
3352 if (S_ISSOCK(PL_statcache.st_mode))
3356 if (S_ISCHR(PL_statcache.st_mode))
3360 if (S_ISBLK(PL_statcache.st_mode))
3364 if (S_ISREG(PL_statcache.st_mode))
3368 if (S_ISDIR(PL_statcache.st_mode))
3372 if (S_ISFIFO(PL_statcache.st_mode))
3377 if (PL_statcache.st_mode & S_ISUID)
3383 if (PL_statcache.st_mode & S_ISGID)
3389 if (PL_statcache.st_mode & S_ISVTX)
3401 tryAMAGICftest_MG('l');
3402 result = my_lstat_flags(0);
3406 if (S_ISLNK(PL_statcache.st_mode))
3419 tryAMAGICftest_MG('t');
3421 if (PL_op->op_flags & OPf_REF)
3424 SV *tmpsv = *PL_stack_sp;
3425 if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3426 name = SvPV_nomg(tmpsv, namelen);
3427 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3431 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3432 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3433 else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX)
3438 SETERRNO(EBADF,RMS_IFI);
3441 if (PerlLIO_isatty(fd))
3447 /* also used for: pp_ftbinary() */
3460 const U8 * first_variant;
3462 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3464 if (PL_op->op_flags & OPf_REF)
3466 else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3471 gv = MAYBE_DEREF_GV_nomg(sv);
3475 if (gv == PL_defgv) {
3477 io = SvTYPE(PL_statgv) == SVt_PVIO
3481 goto really_filename;
3486 SvPVCLEAR(PL_statname);
3487 io = GvIO(PL_statgv);
3489 PL_laststatval = -1;
3490 PL_laststype = OP_STAT;
3491 if (io && IoIFP(io)) {
3493 if (! PerlIO_has_base(IoIFP(io)))
3494 DIE(aTHX_ "-T and -B not implemented on filehandles");
3495 fd = PerlIO_fileno(IoIFP(io));
3497 SETERRNO(EBADF,RMS_IFI);
3500 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3501 if (PL_laststatval < 0)
3503 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3504 if (PL_op->op_type == OP_FTTEXT)
3509 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3510 i = PerlIO_getc(IoIFP(io));
3512 (void)PerlIO_ungetc(IoIFP(io),i);
3514 /* null file is anything */
3517 len = PerlIO_get_bufsiz(IoIFP(io));
3518 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3519 /* sfio can have large buffers - limit to 512 */
3524 SETERRNO(EBADF,RMS_IFI);
3526 SETERRNO(EBADF,RMS_IFI);
3537 temp = SvPV_nomg_const(sv, temp_len);
3538 sv_setpv(PL_statname, temp);
3539 if (!IS_SAFE_PATHNAME(temp, temp_len, OP_NAME(PL_op))) {
3540 PL_laststatval = -1;
3541 PL_laststype = OP_STAT;
3545 file = SvPVX_const(PL_statname);
3547 if (!(fp = PerlIO_open(file, "r"))) {
3549 PL_laststatval = -1;
3550 PL_laststype = OP_STAT;
3552 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
3553 /* PL_warn_nl is constant */
3554 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
3555 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3556 GCC_DIAG_RESTORE_STMT;
3560 PL_laststype = OP_STAT;
3561 fd = PerlIO_fileno(fp);
3563 (void)PerlIO_close(fp);
3564 SETERRNO(EBADF,RMS_IFI);
3567 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3568 if (PL_laststatval < 0) {
3570 (void)PerlIO_close(fp);
3574 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3575 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3576 (void)PerlIO_close(fp);
3578 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3579 FT_RETURNNO; /* special case NFS directories */
3580 FT_RETURNYES; /* null file is anything */
3585 /* now scan s to look for textiness */
3587 #if defined(DOSISH) || defined(USEMYBINMODE)
3588 /* ignore trailing ^Z on short files */
3589 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3594 if (! is_utf8_invariant_string_loc((U8 *) s, len, &first_variant)) {
3596 /* Here contains a variant under UTF-8 . See if the entire string is
3598 if (is_utf8_fixed_width_buf_flags(first_variant,
3599 len - ((char *) first_variant - (char *) s),
3602 if (PL_op->op_type == OP_FTTEXT) {
3611 /* Here, is not UTF-8 or is entirely ASCII. Look through the buffer for
3612 * things that wouldn't be in ASCII text or rich ASCII text. Count these
3614 for (i = 0; i < len; i++, s++) {
3615 if (!*s) { /* null never allowed in text */
3619 #ifdef USE_LOCALE_CTYPE
3620 if (IN_LC_RUNTIME(LC_CTYPE)) {
3621 if ( isPRINT_LC(*s) || isSPACE_LC(*s)) {
3628 /* VT occurs so rarely in text, that we consider it odd */
3629 || (isSPACE_A(*s) && *s != VT_NATIVE)
3631 /* But there is a fair amount of backspaces and escapes in
3634 || *s == ESC_NATIVE)
3641 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3652 const char *tmps = NULL;
3656 SV * const sv = POPs;
3657 if (PL_op->op_flags & OPf_SPECIAL) {
3658 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3660 if (ckWARN(WARN_UNOPENED)) {
3661 Perl_warner(aTHX_ packWARN(WARN_UNOPENED),
3662 "chdir() on unopened filehandle %" SVf, sv);
3664 SETERRNO(EBADF,RMS_IFI);
3666 TAINT_PROPER("chdir");
3670 else if (!(gv = MAYBE_DEREF_GV(sv)))
3671 tmps = SvPV_nomg_const_nolen(sv);
3674 HV * const table = GvHVn(PL_envgv);
3678 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3679 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3681 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3685 tmps = SvPV_nolen_const(*svp);
3689 SETERRNO(EINVAL, LIB_INVARG);
3690 TAINT_PROPER("chdir");
3695 TAINT_PROPER("chdir");
3698 IO* const io = GvIO(gv);
3701 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3702 } else if (IoIFP(io)) {
3703 int fd = PerlIO_fileno(IoIFP(io));
3707 PUSHi(fchdir(fd) >= 0);
3717 DIE(aTHX_ PL_no_func, "fchdir");
3721 PUSHi( PerlDir_chdir(tmps) >= 0 );
3723 /* Clear the DEFAULT element of ENV so we'll get the new value
3725 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3732 SETERRNO(EBADF,RMS_IFI);
3739 /* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */
3743 dSP; dMARK; dTARGET;
3744 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3755 char * const tmps = POPpx;
3756 TAINT_PROPER("chroot");
3757 PUSHi( chroot(tmps) >= 0 );
3760 DIE(aTHX_ PL_no_func, "chroot");
3771 const char * const tmps2 = POPpconstx;
3772 const char * const tmps = SvPV_nolen_const(TOPs);
3773 TAINT_PROPER("rename");
3775 anum = PerlLIO_rename(tmps, tmps2);
3777 if (!(anum = PerlLIO_stat(tmps, &statbuf))) {
3778 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3781 if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
3782 (void)UNLINK(tmps2);
3783 if (!(anum = link(tmps, tmps2)))
3784 anum = UNLINK(tmps);
3793 /* also used for: pp_symlink() */
3795 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3799 const int op_type = PL_op->op_type;
3803 if (op_type == OP_LINK)
3804 DIE(aTHX_ PL_no_func, "link");
3806 # ifndef HAS_SYMLINK
3807 if (op_type == OP_SYMLINK)
3808 DIE(aTHX_ PL_no_func, "symlink");
3812 const char * const tmps2 = POPpconstx;
3813 const char * const tmps = SvPV_nolen_const(TOPs);
3814 TAINT_PROPER(PL_op_desc[op_type]);
3816 # if defined(HAS_LINK) && defined(HAS_SYMLINK)
3817 /* Both present - need to choose which. */
3818 (op_type == OP_LINK) ?
3819 PerlLIO_link(tmps, tmps2) : PerlLIO_symlink(tmps, tmps2);
3820 # elif defined(HAS_LINK)
3821 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3822 PerlLIO_link(tmps, tmps2);
3823 # elif defined(HAS_SYMLINK)
3824 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3825 PerlLIO_symlink(tmps, tmps2);
3829 SETi( result >= 0 );
3834 /* also used for: pp_symlink() */
3839 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3849 char buf[MAXPATHLEN];
3854 /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
3855 * it is impossible to know whether the result was truncated. */
3856 len = PerlLIO_readlink(tmps, buf, sizeof(buf) - 1);
3864 RETSETUNDEF; /* just pretend it's a normal file */
3868 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3870 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3872 char * const save_filename = filename;
3877 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3879 PERL_ARGS_ASSERT_DOONELINER;
3881 Newx(cmdline, size, char);
3882 my_strlcpy(cmdline, cmd, size);
3883 my_strlcat(cmdline, " ", size);
3884 for (s = cmdline + strlen(cmdline); *filename; ) {
3888 if (s - cmdline < size)
3889 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3890 myfp = PerlProc_popen(cmdline, "r");
3894 SV * const tmpsv = sv_newmortal();
3895 /* Need to save/restore 'PL_rs' ?? */
3896 s = sv_gets(tmpsv, myfp, 0);
3897 (void)PerlProc_pclose(myfp);
3901 #ifdef HAS_SYS_ERRLIST
3906 /* you don't see this */
3907 const char * const errmsg = Strerror(e) ;
3910 if (instr(s, errmsg)) {
3917 #define EACCES EPERM
3919 if (instr(s, "cannot make"))
3920 SETERRNO(EEXIST,RMS_FEX);
3921 else if (instr(s, "existing file"))
3922 SETERRNO(EEXIST,RMS_FEX);
3923 else if (instr(s, "ile exists"))
3924 SETERRNO(EEXIST,RMS_FEX);
3925 else if (instr(s, "non-exist"))
3926 SETERRNO(ENOENT,RMS_FNF);
3927 else if (instr(s, "does not exist"))
3928 SETERRNO(ENOENT,RMS_FNF);
3929 else if (instr(s, "not empty"))
3930 SETERRNO(EBUSY,SS_DEVOFFLINE);
3931 else if (instr(s, "cannot access"))
3932 SETERRNO(EACCES,RMS_PRV);
3934 SETERRNO(EPERM,RMS_PRV);
3937 else { /* some mkdirs return no failure indication */
3939 anum = (PerlLIO_stat(save_filename, &statbuf) >= 0);
3940 if (PL_op->op_type == OP_RMDIR)
3945 SETERRNO(EACCES,RMS_PRV); /* a guess */
3954 /* This macro removes trailing slashes from a directory name.
3955 * Different operating and file systems take differently to
3956 * trailing slashes. According to POSIX 1003.1 1996 Edition
3957 * any number of trailing slashes should be allowed.
3958 * Thusly we snip them away so that even non-conforming
3959 * systems are happy.
3960 * We should probably do this "filtering" for all
3961 * the functions that expect (potentially) directory names:
3962 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3963 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3965 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3966 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3969 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3970 (tmps) = savepvn((tmps), (len)); \
3980 const unsigned int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPu : 0777;
3982 TRIMSLASHES(tmps,len,copy);
3984 TAINT_PROPER("mkdir");
3986 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3990 SETi( dooneliner("mkdir", tmps) );
3991 oldumask = PerlLIO_umask(0);
3992 PerlLIO_umask(oldumask);
3993 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
4008 TRIMSLASHES(tmps,len,copy);
4009 TAINT_PROPER("rmdir");
4011 SETi( PerlDir_rmdir(tmps) >= 0 );
4013 SETi( dooneliner("rmdir", tmps) );
4020 /* Directory calls. */
4024 #if defined(Direntry_t) && defined(HAS_READDIR)
4026 const char * const dirname = POPpconstx;
4027 GV * const gv = MUTABLE_GV(POPs);
4028 IO * const io = GvIOn(gv);
4030 if ((IoIFP(io) || IoOFP(io)))
4031 Perl_croak(aTHX_ "Cannot open %" HEKf " as a dirhandle: it is already open as a filehandle",
4032 HEKfARG(GvENAME_HEK(gv)));
4034 PerlDir_close(IoDIRP(io));
4035 if (!(IoDIRP(io) = PerlDir_open(dirname)))
4041 SETERRNO(EBADF,RMS_DIR);
4044 DIE(aTHX_ PL_no_dir_func, "opendir");
4050 #if !defined(Direntry_t) || !defined(HAS_READDIR)
4051 DIE(aTHX_ PL_no_dir_func, "readdir");
4053 #if !defined(I_DIRENT) && !defined(VMS)
4054 Direntry_t *readdir (DIR *);
4059 const U8 gimme = GIMME_V;
4060 GV * const gv = MUTABLE_GV(POPs);
4061 const Direntry_t *dp;
4062 IO * const io = GvIOn(gv);
4065 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4066 "readdir() attempted on invalid dirhandle %" HEKf,
4067 HEKfARG(GvENAME_HEK(gv)));
4072 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
4076 sv = newSVpvn(dp->d_name, dp->d_namlen);
4078 sv = newSVpv(dp->d_name, 0);
4080 if (!(IoFLAGS(io) & IOf_UNTAINT))
4083 } while (gimme == G_LIST);
4085 if (!dp && gimme != G_LIST)
4092 SETERRNO(EBADF,RMS_ISI);
4093 if (gimme == G_LIST)
4102 #if defined(HAS_TELLDIR) || defined(telldir)
4104 /* XXX does _anyone_ need this? --AD 2/20/1998 */
4105 /* XXX netbsd still seemed to.
4106 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
4107 --JHI 1999-Feb-02 */
4108 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
4109 long telldir (DIR *);
4111 GV * const gv = MUTABLE_GV(POPs);
4112 IO * const io = GvIOn(gv);
4115 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4116 "telldir() attempted on invalid dirhandle %" HEKf,
4117 HEKfARG(GvENAME_HEK(gv)));
4121 PUSHi( PerlDir_tell(IoDIRP(io)) );
4125 SETERRNO(EBADF,RMS_ISI);
4128 DIE(aTHX_ PL_no_dir_func, "telldir");
4134 #if defined(HAS_SEEKDIR) || defined(seekdir)
4136 const long along = POPl;
4137 GV * const gv = MUTABLE_GV(POPs);
4138 IO * const io = GvIOn(gv);
4141 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4142 "seekdir() attempted on invalid dirhandle %" HEKf,
4143 HEKfARG(GvENAME_HEK(gv)));
4146 (void)PerlDir_seek(IoDIRP(io), along);
4151 SETERRNO(EBADF,RMS_ISI);
4154 DIE(aTHX_ PL_no_dir_func, "seekdir");
4160 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4162 GV * const gv = MUTABLE_GV(POPs);
4163 IO * const io = GvIOn(gv);
4166 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4167 "rewinddir() attempted on invalid dirhandle %" HEKf,
4168 HEKfARG(GvENAME_HEK(gv)));
4171 (void)PerlDir_rewind(IoDIRP(io));
4175 SETERRNO(EBADF,RMS_ISI);
4178 DIE(aTHX_ PL_no_dir_func, "rewinddir");
4184 #if defined(Direntry_t) && defined(HAS_READDIR)
4186 GV * const gv = MUTABLE_GV(POPs);
4187 IO * const io = GvIOn(gv);
4190 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4191 "closedir() attempted on invalid dirhandle %" HEKf,
4192 HEKfARG(GvENAME_HEK(gv)));
4195 #ifdef VOID_CLOSEDIR
4196 PerlDir_close(IoDIRP(io));
4198 if (PerlDir_close(IoDIRP(io)) < 0) {
4199 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4208 SETERRNO(EBADF,RMS_IFI);
4211 DIE(aTHX_ PL_no_dir_func, "closedir");
4215 /* Process control. */
4222 #ifdef HAS_SIGPROCMASK
4223 sigset_t oldmask, newmask;
4227 PERL_FLUSHALL_FOR_CHILD;
4228 #ifdef HAS_SIGPROCMASK
4229 sigfillset(&newmask);
4230 sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4232 childpid = PerlProc_fork();
4233 if (childpid == 0) {
4237 for (sig = 1; sig < SIG_SIZE; sig++)
4238 PL_psig_pend[sig] = 0;
4240 #ifdef HAS_SIGPROCMASK
4243 sigprocmask(SIG_SETMASK, &oldmask, NULL);
4250 #ifdef PERL_USES_PL_PIDSTATUS
4251 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4256 #elif (defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)) || defined(__amigaos4__)
4261 PERL_FLUSHALL_FOR_CHILD;
4262 childpid = PerlProc_fork();
4268 DIE(aTHX_ PL_no_func, "fork");
4274 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4279 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4280 childpid = wait4pid(-1, &argflags, 0);
4282 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4287 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4288 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4289 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4291 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4296 DIE(aTHX_ PL_no_func, "wait");
4302 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4304 const int optype = POPi;
4305 const Pid_t pid = TOPi;
4309 result = amigaos_waitpid(aTHX_ optype, pid, &argflags);
4310 STATUS_NATIVE_CHILD_SET((result >= 0) ? argflags : -1);
4311 result = result == 0 ? pid : -1;
4315 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4316 result = wait4pid(pid, &argflags, optype);
4318 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4323 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4324 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4325 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4327 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4329 # endif /* __amigaos4__ */
4333 DIE(aTHX_ PL_no_func, "waitpid");
4339 dSP; dMARK; dORIGMARK; dTARGET;
4340 #if defined(__LIBCATAMOUNT__)
4341 PL_statusvalue = -1;
4346 # ifdef __amigaos4__
4352 while (++MARK <= SP) {
4353 SV *origsv = *MARK, *copysv;
4357 #if defined(WIN32) || defined(__VMS)
4359 * Because of a nasty platform-specific variation on the meaning
4360 * of arguments to this op, we must preserve numeric arguments
4361 * as numeric, not just retain the string value.
4363 if (SvNIOK(origsv) || SvNIOKp(origsv)) {
4364 copysv = newSV_type(SVt_PVNV);
4366 if (SvPOK(origsv) || SvPOKp(origsv)) {
4367 pv = SvPV_nomg(origsv, len);
4368 sv_setpvn_fresh(copysv, pv, len);
4371 if (SvIOK(origsv) || SvIOKp(origsv))
4372 SvIV_set(copysv, SvIVX(origsv));
4373 if (SvNOK(origsv) || SvNOKp(origsv))
4374 SvNV_set(copysv, SvNVX(origsv));
4375 SvFLAGS(copysv) |= SvFLAGS(origsv) &
4376 (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK|
4377 SVf_UTF8|SVf_IVisUV);
4381 pv = SvPV_nomg(origsv, len);
4382 copysv = newSVpvn_flags(pv, len,
4383 (SvFLAGS(origsv) & SVf_UTF8) | SVs_TEMP);
4391 TAINT_PROPER("system");
4393 PERL_FLUSHALL_FOR_CHILD;
4394 #if (defined(HAS_FORK) || defined(__amigaos4__)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4397 struct UserData userdata;
4404 bool child_success = FALSE;
4405 #ifdef HAS_SIGPROCMASK
4406 sigset_t newset, oldset;
4409 if (PerlProc_pipe_cloexec(pp) >= 0)
4412 amigaos_fork_set_userdata(aTHX_
4418 pthread_create(&proc,NULL,amigaos_system_child,(void *)&userdata);
4419 child_success = proc > 0;
4421 #ifdef HAS_SIGPROCMASK
4422 sigemptyset(&newset);
4423 sigaddset(&newset, SIGCHLD);
4424 sigprocmask(SIG_BLOCK, &newset, &oldset);
4426 while ((childpid = PerlProc_fork()) == -1) {
4427 if (errno != EAGAIN) {
4432 PerlLIO_close(pp[0]);
4433 PerlLIO_close(pp[1]);
4435 #ifdef HAS_SIGPROCMASK
4436 sigprocmask(SIG_SETMASK, &oldset, NULL);
4442 child_success = childpid > 0;
4444 if (child_success) {
4445 Sigsave_t ihand,qhand; /* place to save signals during system() */
4448 #ifndef __amigaos4__
4450 PerlLIO_close(pp[1]);
4453 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4454 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4457 result = pthread_join(proc, (void **)&status);
4460 result = wait4pid(childpid, &status, 0);
4461 } while (result == -1 && errno == EINTR);
4464 #ifdef HAS_SIGPROCMASK
4465 sigprocmask(SIG_SETMASK, &oldset, NULL);
4467 (void)rsignal_restore(SIGINT, &ihand);
4468 (void)rsignal_restore(SIGQUIT, &qhand);
4470 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4476 while (n < sizeof(int)) {
4477 const SSize_t n1 = PerlLIO_read(pp[0],
4478 (void*)(((char*)&errkid)+n),
4484 PerlLIO_close(pp[0]);
4485 if (n) { /* Error */
4486 if (n != sizeof(int))
4487 DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4488 errno = errkid; /* Propagate errno from kid */
4490 /* The pipe always has something in it
4491 * so n alone is not enough. */
4495 STATUS_NATIVE_CHILD_SET(-1);
4499 XPUSHi(STATUS_CURRENT);
4502 #ifndef __amigaos4__
4503 #ifdef HAS_SIGPROCMASK
4504 sigprocmask(SIG_SETMASK, &oldset, NULL);
4507 PerlLIO_close(pp[0]);
4508 if (PL_op->op_flags & OPf_STACKED) {
4509 SV * const really = *++MARK;
4510 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4512 else if (SP - MARK != 1)
4513 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4515 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4517 #endif /* __amigaos4__ */
4520 #else /* ! FORK or VMS or OS/2 */
4523 if (PL_op->op_flags & OPf_STACKED) {
4524 SV * const really = *++MARK;
4525 # if defined(WIN32) || defined(OS2) || defined(__VMS)
4526 value = (I32)do_aspawn(really, MARK, SP);
4528 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4531 else if (SP - MARK != 1) {
4532 # if defined(WIN32) || defined(OS2) || defined(__VMS)
4533 value = (I32)do_aspawn(NULL, MARK, SP);
4535 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4539 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4541 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4543 STATUS_NATIVE_CHILD_SET(value);
4545 XPUSHi(result ? value : STATUS_CURRENT);
4546 #endif /* !FORK or VMS or OS/2 */
4553 dSP; dMARK; dORIGMARK; dTARGET;
4558 while (++MARK <= SP) {
4559 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4564 TAINT_PROPER("exec");
4567 PERL_FLUSHALL_FOR_CHILD;
4568 if (PL_op->op_flags & OPf_STACKED) {
4569 SV * const really = *++MARK;
4570 value = (I32)do_aexec(really, MARK, SP);
4572 else if (SP - MARK != 1)
4574 value = (I32)vms_do_aexec(NULL, MARK, SP);
4576 value = (I32)do_aexec(NULL, MARK, SP);
4580 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4582 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4594 XPUSHi( getppid() );
4597 DIE(aTHX_ PL_no_func, "getppid");
4607 (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4610 pgrp = (I32)BSD_GETPGRP(pid);
4612 if (pid != 0 && pid != PerlProc_getpid())
4613 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4619 DIE(aTHX_ PL_no_func, "getpgrp");
4629 pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4630 if (MAXARG > 0) pid = TOPs ? TOPi : 0;
4637 TAINT_PROPER("setpgrp");
4639 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4641 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4642 || (pid != 0 && pid != PerlProc_getpid()))
4644 DIE(aTHX_ "setpgrp can't take arguments");
4646 SETi( setpgrp() >= 0 );
4647 #endif /* USE_BSDPGRP */
4650 DIE(aTHX_ PL_no_func, "setpgrp");
4655 * The glibc headers typedef __priority_which_t to an enum under C, but
4656 * under C++, it keeps it as int. -Wc++-compat doesn't know this, so we
4657 * need to explicitly cast it to shut up the warning.
4659 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4660 # define PRIORITY_WHICH_T(which) (__priority_which_t)which
4662 # define PRIORITY_WHICH_T(which) which
4667 #ifdef HAS_GETPRIORITY
4669 const int who = POPi;
4670 const int which = TOPi;
4671 SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4674 DIE(aTHX_ PL_no_func, "getpriority");
4680 #ifdef HAS_SETPRIORITY
4682 const int niceval = POPi;
4683 const int who = POPi;
4684 const int which = TOPi;
4685 TAINT_PROPER("setpriority");
4686 SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4689 DIE(aTHX_ PL_no_func, "setpriority");
4693 #undef PRIORITY_WHICH_T
4701 XPUSHn( (NV)time(NULL) );
4703 XPUSHu( (UV)time(NULL) );
4712 struct tms timesbuf;
4715 (void)PerlProc_times(×buf);
4717 mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
4718 if (GIMME_V == G_LIST) {
4719 mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
4720 mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
4721 mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
4724 #elif defined(PERL_MICRO)
4728 if (GIMME_V == G_LIST) {
4735 DIE(aTHX_ "times not implemented");
4736 #endif /* HAS_TIMES */
4739 /* The 32 bit int year limits the times we can represent to these
4740 boundaries with a few days wiggle room to account for time zone
4743 /* Sat Jan 3 00:00:00 -2147481748 */
4744 #define TIME_LOWER_BOUND -67768100567755200.0
4745 /* Sun Dec 29 12:00:00 2147483647 */
4746 #define TIME_UPPER_BOUND 67767976233316800.0
4749 /* also used for: pp_localtime() */
4757 const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4758 static const char * const dayname[] =
4759 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4760 static const char * const monname[] =
4761 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4762 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4764 if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4767 when = (Time64_T)now;
4770 NV input = Perl_floor(POPn);
4771 const bool pl_isnan = Perl_isnan(input);
4772 when = (Time64_T)input;
4773 if (UNLIKELY(pl_isnan || when != input)) {
4774 /* diag_listed_as: gmtime(%f) too large */
4775 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4776 "%s(%.0" NVff ") too large", opname, input);
4784 if ( TIME_LOWER_BOUND > when ) {
4785 /* diag_listed_as: gmtime(%f) too small */
4786 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4787 "%s(%.0" NVff ") too small", opname, when);
4790 else if( when > TIME_UPPER_BOUND ) {
4791 /* diag_listed_as: gmtime(%f) too small */
4792 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4793 "%s(%.0" NVff ") too large", opname, when);
4797 if (PL_op->op_type == OP_LOCALTIME)
4798 err = Perl_localtime64_r(&when, &tmbuf);
4800 err = Perl_gmtime64_r(&when, &tmbuf);
4804 /* diag_listed_as: gmtime(%f) failed */
4805 /* XXX %lld broken for quads */
4807 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4808 "%s(%.0" NVff ") failed", opname, when);
4811 if (GIMME_V != G_LIST) { /* scalar context */
4818 Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %" IVdf,
4819 dayname[tmbuf.tm_wday],
4820 monname[tmbuf.tm_mon],
4825 (IV)tmbuf.tm_year + 1900);
4828 else { /* list context */
4834 mPUSHi(tmbuf.tm_sec);
4835 mPUSHi(tmbuf.tm_min);
4836 mPUSHi(tmbuf.tm_hour);
4837 mPUSHi(tmbuf.tm_mday);
4838 mPUSHi(tmbuf.tm_mon);
4839 mPUSHn(tmbuf.tm_year);
4840 mPUSHi(tmbuf.tm_wday);
4841 mPUSHi(tmbuf.tm_yday);
4842 mPUSHi(tmbuf.tm_isdst);
4851 /* alarm() takes an unsigned int number of seconds, and return the
4852 * unsigned int number of seconds remaining in the previous alarm
4853 * (alarms don't stack). Therefore negative return values are not
4857 /* Note that while the C library function alarm() as such has
4858 * no errors defined (or in other words, properly behaving client
4859 * code shouldn't expect any), alarm() being obsoleted by
4860 * setitimer() and often being implemented in terms of
4861 * setitimer(), can fail. */
4862 /* diag_listed_as: %s() with negative argument */
4863 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4864 "alarm() with negative argument");
4865 SETERRNO(EINVAL, LIB_INVARG);
4869 unsigned int retval = alarm(anum);
4870 if ((int)retval < 0) /* Strictly speaking "cannot happen". */
4876 DIE(aTHX_ PL_no_func, "alarm");
4886 (void)time(&lasttime);
4887 if (MAXARG < 1 || (!TOPs && !POPs))
4890 const I32 duration = POPi;
4892 /* diag_listed_as: %s() with negative argument */
4893 Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4894 "sleep() with negative argument");
4895 SETERRNO(EINVAL, LIB_INVARG);
4896 XPUSHs(&PL_sv_zero);
4899 PerlProc_sleep((unsigned int)duration);
4903 XPUSHu((UV)(when - lasttime));
4907 /* Shared memory. */
4908 /* Merged with some message passing. */
4910 /* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */
4914 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4915 dSP; dMARK; dTARGET;
4916 const int op_type = PL_op->op_type;
4921 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4924 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4927 value = (I32)(do_semop(MARK, SP) >= 0);
4930 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4938 return Perl_pp_semget(aTHX);
4944 /* also used for: pp_msgget() pp_shmget() */
4948 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4949 dSP; dMARK; dTARGET;
4950 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4957 DIE(aTHX_ "System V IPC is not implemented on this machine");
4961 /* also used for: pp_msgctl() pp_shmctl() */
4965 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4966 dSP; dMARK; dTARGET;
4967 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4975 PUSHp(zero_but_true, ZBTLEN);
4979 return Perl_pp_semget(aTHX);
4983 /* I can't const this further without getting warnings about the types of
4984 various arrays passed in from structures. */
4986 S_space_join_names_mortal(pTHX_ char *const *array)
4990 if (array && *array) {
4991 target = newSVpvs_flags("", SVs_TEMP);
4993 sv_catpv(target, *array);
4996 sv_catpvs(target, " ");
4999 target = sv_mortalcopy(&PL_sv_no);
5004 /* Get system info. */
5006 /* also used for: pp_ghbyaddr() pp_ghbyname() */
5010 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
5012 I32 which = PL_op->op_type;
5015 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
5016 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
5017 struct hostent *gethostbyname(Netdb_name_t);
5018 struct hostent *gethostent(void);
5020 struct hostent *hent = NULL;
5024 if (which == OP_GHBYNAME) {
5025 #ifdef HAS_GETHOSTBYNAME
5026 const char* const name = POPpbytex;
5027 hent = PerlSock_gethostbyname(name);
5029 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
5032 else if (which == OP_GHBYADDR) {
5033 #ifdef HAS_GETHOSTBYADDR
5034 const int addrtype = POPi;
5035 SV * const addrsv = POPs;
5037 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
5039 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
5041 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
5045 #ifdef HAS_GETHOSTENT
5046 hent = PerlSock_gethostent();
5048 DIE(aTHX_ PL_no_sock_func, "gethostent");
5051 #ifdef HOST_NOT_FOUND
5053 #ifdef USE_REENTRANT_API
5054 # ifdef USE_GETHOSTENT_ERRNO
5055 h_errno = PL_reentrant_buffer->_gethostent_errno;
5058 STATUS_UNIX_SET(h_errno);
5062 if (GIMME_V != G_LIST) {
5063 PUSHs(sv = sv_newmortal());
5065 if (which == OP_GHBYNAME) {
5067 sv_upgrade(sv, SVt_PV);
5068 sv_setpvn_fresh(sv, hent->h_addr, hent->h_length);
5072 sv_setpv(sv, (char*)hent->h_name);
5078 mPUSHs(newSVpv((char*)hent->h_name, 0));
5079 PUSHs(space_join_names_mortal(hent->h_aliases));
5080 mPUSHi(hent->h_addrtype);
5081 len = hent->h_length;
5084 for (elem = hent->h_addr_list; elem && *elem; elem++) {
5085 mXPUSHp(*elem, len);
5089 mPUSHp(hent->h_addr, len);
5091 PUSHs(sv_mortalcopy(&PL_sv_no));
5096 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5100 /* also used for: pp_gnbyaddr() pp_gnbyname() */
5104 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
5106 I32 which = PL_op->op_type;
5108 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
5109 struct netent *getnetbyaddr(Netdb_net_t, int);
5110 struct netent *getnetbyname(Netdb_name_t);
5111 struct netent *getnetent(void);
5113 struct netent *nent;
5115 if (which == OP_GNBYNAME){
5116 #ifdef HAS_GETNETBYNAME
5117 const char * const name = POPpbytex;
5118 nent = PerlSock_getnetbyname(name);
5120 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
5123 else if (which == OP_GNBYADDR) {
5124 #ifdef HAS_GETNETBYADDR
5125 const int addrtype = POPi;
5126 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
5127 nent = PerlSock_getnetbyaddr(addr, addrtype);
5129 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
5133 #ifdef HAS_GETNETENT
5134 nent = PerlSock_getnetent();
5136 DIE(aTHX_ PL_no_sock_func, "getnetent");
5139 #ifdef HOST_NOT_FOUND
5141 #ifdef USE_REENTRANT_API
5142 # ifdef USE_GETNETENT_ERRNO
5143 h_errno = PL_reentrant_buffer->_getnetent_errno;
5146 STATUS_UNIX_SET(h_errno);
5151 if (GIMME_V != G_LIST) {
5152 PUSHs(sv = sv_newmortal());
5154 if (which == OP_GNBYNAME)
5155 sv_setiv(sv, (IV)nent->n_net);
5157 sv_setpv(sv, nent->n_name);
5163 mPUSHs(newSVpv(nent->n_name, 0));
5164 PUSHs(space_join_names_mortal(nent->n_aliases));
5165 mPUSHi(nent->n_addrtype);
5166 mPUSHi(nent->n_net);
5171 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5176 /* also used for: pp_gpbyname() pp_gpbynumber() */
5180 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
5182 I32 which = PL_op->op_type;
5184 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
5185 struct protoent *getprotobyname(Netdb_name_t);
5186 struct protoent *getprotobynumber(int);
5187 struct protoent *getprotoent(void);
5189 struct protoent *pent;
5191 if (which == OP_GPBYNAME) {
5192 #ifdef HAS_GETPROTOBYNAME
5193 const char* const name = POPpbytex;
5194 pent = PerlSock_getprotobyname(name);
5196 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
5199 else if (which == OP_GPBYNUMBER) {
5200 #ifdef HAS_GETPROTOBYNUMBER
5201 const int number = POPi;
5202 pent = PerlSock_getprotobynumber(number);
5204 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
5208 #ifdef HAS_GETPROTOENT
5209 pent = PerlSock_getprotoent();
5211 DIE(aTHX_ PL_no_sock_func, "getprotoent");
5215 if (GIMME_V != G_LIST) {
5216 PUSHs(sv = sv_newmortal());
5218 if (which == OP_GPBYNAME)
5219 sv_setiv(sv, (IV)pent->p_proto);
5221 sv_setpv(sv, pent->p_name);
5227 mPUSHs(newSVpv(pent->p_name, 0));
5228 PUSHs(space_join_names_mortal(pent->p_aliases));
5229 mPUSHi(pent->p_proto);
5234 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5239 /* also used for: pp_gsbyname() pp_gsbyport() */
5243 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
5245 I32 which = PL_op->op_type;
5247 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
5248 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
5249 struct servent *getservbyport(int, Netdb_name_t);
5250 struct servent *getservent(void);
5252 struct servent *sent;
5254 if (which == OP_GSBYNAME) {
5255 #ifdef HAS_GETSERVBYNAME
5256 const char * const proto = POPpbytex;
5257 const char * const name = POPpbytex;
5258 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5260 DIE(aTHX_ PL_no_sock_func, "getservbyname");
5263 else if (which == OP_GSBYPORT) {
5264 #ifdef HAS_GETSERVBYPORT
5265 const char * const proto = POPpbytex;
5266 unsigned short port = (unsigned short)POPu;
5267 port = PerlSock_htons(port);
5268 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5270 DIE(aTHX_ PL_no_sock_func, "getservbyport");
5274 #ifdef HAS_GETSERVENT
5275 sent = PerlSock_getservent();
5277 DIE(aTHX_ PL_no_sock_func, "getservent");
5281 if (GIMME_V != G_LIST) {
5282 PUSHs(sv = sv_newmortal());
5284 if (which == OP_GSBYNAME) {
5285 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5288 sv_setpv(sv, sent->s_name);
5294 mPUSHs(newSVpv(sent->s_name, 0));
5295 PUSHs(space_join_names_mortal(sent->s_aliases));
5296 mPUSHi(PerlSock_ntohs(sent->s_port));
5297 mPUSHs(newSVpv(sent->s_proto, 0));
5302 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5307 /* also used for: pp_snetent() pp_sprotoent() pp_sservent() */
5312 const int stayopen = TOPi;
5313 switch(PL_op->op_type) {
5315 #ifdef HAS_SETHOSTENT
5316 PerlSock_sethostent(stayopen);
5318 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5322 #ifdef HAS_SETNETENT
5323 PerlSock_setnetent(stayopen);
5325 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5329 #ifdef HAS_SETPROTOENT
5330 PerlSock_setprotoent(stayopen);
5332 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5336 #ifdef HAS_SETSERVENT
5337 PerlSock_setservent(stayopen);
5339 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5347 /* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent()
5348 * pp_eservent() pp_sgrent() pp_spwent() */
5353 switch(PL_op->op_type) {
5355 #ifdef HAS_ENDHOSTENT
5356 PerlSock_endhostent();
5358 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5362 #ifdef HAS_ENDNETENT
5363 PerlSock_endnetent();
5365 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5369 #ifdef HAS_ENDPROTOENT
5370 PerlSock_endprotoent();
5372 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5376 #ifdef HAS_ENDSERVENT
5377 PerlSock_endservent();
5379 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5383 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5386 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5390 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5393 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5397 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5400 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5404 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5407 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5416 /* also used for: pp_gpwnam() pp_gpwuid() */
5422 I32 which = PL_op->op_type;
5424 struct passwd *pwent = NULL;
5426 * We currently support only the SysV getsp* shadow password interface.
5427 * The interface is declared in <shadow.h> and often one needs to link
5428 * with -lsecurity or some such.
5429 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5432 * AIX getpwnam() is clever enough to return the encrypted password
5433 * only if the caller (euid?) is root.
5435 * There are at least three other shadow password APIs. Many platforms
5436 * seem to contain more than one interface for accessing the shadow
5437 * password databases, possibly for compatibility reasons.
5438 * The getsp*() is by far he simplest one, the other two interfaces
5439 * are much more complicated, but also very similar to each other.
5444 * struct pr_passwd *getprpw*();
5445 * The password is in
5446 * char getprpw*(...).ufld.fd_encrypt[]
5447 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5452 * struct es_passwd *getespw*();
5453 * The password is in
5454 * char *(getespw*(...).ufld.fd_encrypt)
5455 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5458 * struct userpw *getuserpw();
5459 * The password is in
5460 * char *(getuserpw(...)).spw_upw_passwd
5461 * (but the de facto standard getpwnam() should work okay)
5463 * Mention I_PROT here so that Configure probes for it.
5465 * In HP-UX for getprpw*() the manual page claims that one should include
5466 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5467 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5468 * and pp_sys.c already includes <shadow.h> if there is such.
5470 * Note that <sys/security.h> is already probed for, but currently
5471 * it is only included in special cases.
5473 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5474 * the preferred interface, even though also the getprpw*() interface
5475 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5476 * One also needs to call set_auth_parameters() in main() before
5477 * doing anything else, whether one is using getespw*() or getprpw*().
5479 * Note that accessing the shadow databases can be magnitudes
5480 * slower than accessing the standard databases.
5485 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5486 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5487 * the pw_comment is left uninitialized. */
5488 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5494 const char* const name = POPpbytex;
5495 pwent = getpwnam(name);
5501 pwent = getpwuid(uid);
5505 # ifdef HAS_GETPWENT
5507 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5508 if (pwent) pwent = getpwnam(pwent->pw_name);
5511 DIE(aTHX_ PL_no_func, "getpwent");
5517 if (GIMME_V != G_LIST) {
5518 PUSHs(sv = sv_newmortal());
5520 if (which == OP_GPWNAM)
5521 sv_setuid(sv, pwent->pw_uid);
5523 sv_setpv(sv, pwent->pw_name);
5529 mPUSHs(newSVpv(pwent->pw_name, 0));
5533 /* If we have getspnam(), we try to dig up the shadow
5534 * password. If we are underprivileged, the shadow
5535 * interface will set the errno to EACCES or similar,
5536 * and return a null pointer. If this happens, we will
5537 * use the dummy password (usually "*" or "x") from the
5538 * standard password database.
5540 * In theory we could skip the shadow call completely
5541 * if euid != 0 but in practice we cannot know which
5542 * security measures are guarding the shadow databases
5543 * on a random platform.
5545 * Resist the urge to use additional shadow interfaces.
5546 * Divert the urge to writing an extension instead.
5549 /* Some AIX setups falsely(?) detect some getspnam(), which
5550 * has a different API than the Solaris/IRIX one. */
5551 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5554 const struct spwd * const spwent = getspnam(pwent->pw_name);
5555 /* Save and restore errno so that
5556 * underprivileged attempts seem
5557 * to have never made the unsuccessful
5558 * attempt to retrieve the shadow password. */
5560 if (spwent && spwent->sp_pwdp)
5561 sv_setpv(sv, spwent->sp_pwdp);
5565 if (!SvPOK(sv)) /* Use the standard password, then. */
5566 sv_setpv(sv, pwent->pw_passwd);
5569 /* passwd is tainted because user himself can diddle with it.
5570 * admittedly not much and in a very limited way, but nevertheless. */
5573 sv_setuid(PUSHmortal, pwent->pw_uid);
5574 sv_setgid(PUSHmortal, pwent->pw_gid);
5576 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5577 * because of the poor interface of the Perl getpw*(),
5578 * not because there's some standard/convention saying so.
5579 * A better interface would have been to return a hash,
5580 * but we are accursed by our history, alas. --jhi. */
5582 mPUSHi(pwent->pw_change);
5583 # elif defined(PWQUOTA)
5584 mPUSHi(pwent->pw_quota);
5585 # elif defined(PWAGE)
5586 mPUSHs(newSVpv(pwent->pw_age, 0));
5588 /* I think that you can never get this compiled, but just in case. */
5589 PUSHs(sv_mortalcopy(&PL_sv_no));
5592 /* pw_class and pw_comment are mutually exclusive--.
5593 * see the above note for pw_change, pw_quota, and pw_age. */
5595 mPUSHs(newSVpv(pwent->pw_class, 0));
5596 # elif defined(PWCOMMENT)
5597 mPUSHs(newSVpv(pwent->pw_comment, 0));
5599 /* I think that you can never get this compiled, but just in case. */
5600 PUSHs(sv_mortalcopy(&PL_sv_no));
5604 PUSHs(sv = newSVpvn_flags(pwent->pw_gecos,
5605 pwent->pw_gecos == NULL ? 0 : strlen(pwent->pw_gecos),
5608 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5610 /* pw_gecos is tainted because user himself can diddle with it. */
5613 mPUSHs(newSVpv(pwent->pw_dir, 0));
5615 PUSHs(sv = newSVpvn_flags(pwent->pw_shell,
5616 pwent->pw_shell == NULL ? 0 : strlen(pwent->pw_shell),
5618 /* pw_shell is tainted because user himself can diddle with it. */
5622 mPUSHi(pwent->pw_expire);
5627 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5632 /* also used for: pp_ggrgid() pp_ggrnam() */
5638 const I32 which = PL_op->op_type;
5639 const struct group *grent;
5641 if (which == OP_GGRNAM) {
5642 const char* const name = POPpbytex;
5643 grent = (const struct group *)getgrnam(name);
5645 else if (which == OP_GGRGID) {
5647 const Gid_t gid = POPu;
5648 #elif Gid_t_sign == -1
5649 const Gid_t gid = POPi;
5651 # error "Unexpected Gid_t_sign"
5653 grent = (const struct group *)getgrgid(gid);
5657 grent = (struct group *)getgrent();
5659 DIE(aTHX_ PL_no_func, "getgrent");
5663 if (GIMME_V != G_LIST) {
5664 SV * const sv = sv_newmortal();
5668 if (which == OP_GGRNAM)
5669 sv_setgid(sv, grent->gr_gid);
5671 sv_setpv(sv, grent->gr_name);
5677 mPUSHs(newSVpv(grent->gr_name, 0));
5680 mPUSHs(newSVpv(grent->gr_passwd, 0));
5682 PUSHs(sv_mortalcopy(&PL_sv_no));
5685 sv_setgid(PUSHmortal, grent->gr_gid);
5687 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5688 /* In UNICOS/mk (_CRAYMPP) the multithreading
5689 * versions (getgrnam_r, getgrgid_r)
5690 * seem to return an illegal pointer
5691 * as the group members list, gr_mem.
5692 * getgrent() doesn't even have a _r version
5693 * but the gr_mem is poisonous anyway.
5694 * So yes, you cannot get the list of group
5695 * members if building multithreaded in UNICOS/mk. */
5696 PUSHs(space_join_names_mortal(grent->gr_mem));
5702 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5712 if (!(tmps = PerlProc_getlogin()))
5714 sv_setpv_mg(TARG, tmps);
5718 DIE(aTHX_ PL_no_func, "getlogin");
5722 /* Miscellaneous. */
5727 dSP; dMARK; dORIGMARK; dTARGET;
5728 I32 items = SP - MARK;
5729 unsigned long a[20];
5734 while (++MARK <= SP) {
5735 if (SvTAINTED(*MARK)) {
5741 TAINT_PROPER("syscall");
5744 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5745 * or where sizeof(long) != sizeof(char*). But such machines will
5746 * not likely have syscall implemented either, so who cares?
5748 while (++MARK <= SP) {
5749 if (SvNIOK(*MARK) || !i)
5750 a[i++] = SvIV(*MARK);
5751 else if (*MARK == &PL_sv_undef)
5754 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5760 DIE(aTHX_ "Too many args to syscall");
5762 DIE(aTHX_ "Too few args to syscall");
5764 retval = syscall(a[0]);
5767 retval = syscall(a[0],a[1]);
5770 retval = syscall(a[0],a[1],a[2]);
5773 retval = syscall(a[0],a[1],a[2],a[3]);
5776 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5779 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5782 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5785 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5792 DIE(aTHX_ PL_no_func, "syscall");
5796 #ifdef FCNTL_EMULATE_FLOCK
5798 /* XXX Emulate flock() with fcntl().
5799 What's really needed is a good file locking module.
5803 fcntl_emulate_flock(int fd, int operation)
5808 switch (operation & ~LOCK_NB) {
5810 flock.l_type = F_RDLCK;
5813 flock.l_type = F_WRLCK;
5816 flock.l_type = F_UNLCK;
5822 flock.l_whence = SEEK_SET;
5823 flock.l_start = flock.l_len = (Off_t)0;
5825 res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5826 if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5827 errno = EWOULDBLOCK;
5831 #endif /* FCNTL_EMULATE_FLOCK */
5833 #ifdef LOCKF_EMULATE_FLOCK
5835 /* XXX Emulate flock() with lockf(). This is just to increase
5836 portability of scripts. The calls are not completely
5837 interchangeable. What's really needed is a good file
5841 /* The lockf() constants might have been defined in <unistd.h>.
5842 Unfortunately, <unistd.h> causes troubles on some mixed
5843 (BSD/POSIX) systems, such as SunOS 4.1.3.
5845 Further, the lockf() constants aren't POSIX, so they might not be
5846 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5847 just stick in the SVID values and be done with it. Sigh.
5851 # define F_ULOCK 0 /* Unlock a previously locked region */
5854 # define F_LOCK 1 /* Lock a region for exclusive use */
5857 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5860 # define F_TEST 3 /* Test a region for other processes locks */
5864 lockf_emulate_flock(int fd, int operation)
5870 /* flock locks entire file so for lockf we need to do the same */
5871 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5872 if (pos > 0) /* is seekable and needs to be repositioned */
5873 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5874 pos = -1; /* seek failed, so don't seek back afterwards */
5877 switch (operation) {
5879 /* LOCK_SH - get a shared lock */
5881 /* LOCK_EX - get an exclusive lock */
5883 i = lockf (fd, F_LOCK, 0);
5886 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5887 case LOCK_SH|LOCK_NB:
5888 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5889 case LOCK_EX|LOCK_NB:
5890 i = lockf (fd, F_TLOCK, 0);
5892 if ((errno == EAGAIN) || (errno == EACCES))
5893 errno = EWOULDBLOCK;
5896 /* LOCK_UN - unlock (non-blocking is a no-op) */
5898 case LOCK_UN|LOCK_NB:
5899 i = lockf (fd, F_ULOCK, 0);
5902 /* Default - can't decipher operation */
5909 if (pos > 0) /* need to restore position of the handle */
5910 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5915 #endif /* LOCKF_EMULATE_FLOCK */
5918 * ex: set ts=8 sts=4 sw=4 et: