3 * Copyright (C) 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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.
18 /* This file contains system pp ("push/pop") functions that
19 * execute the opcodes that make up a perl program. A typical pp function
20 * expects to find its arguments on the stack, and usually pushes its
21 * results onto the stack, hence the 'pp' terminology. Each OP structure
22 * contains a pointer to the relevant pp_foo() function.
24 * By 'system', we mean ops which interact with the OS, such as pp_open().
28 #define PERL_IN_PP_SYS_C
32 /* Shadow password support for solaris - pdo@cs.umd.edu
33 * Not just Solaris: at least HP-UX, IRIX, Linux.
34 * The API is from SysV.
36 * There are at least two more shadow interfaces,
37 * see the comments in pp_gpwent().
41 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
42 * and another MAXINT from "perl.h" <- <sys/param.h>. */
49 # include <sys/wait.h>
53 # include <sys/resource.h>
62 # include <sys/select.h>
66 /* XXX Configure test needed.
67 h_errno might not be a simple 'int', especially for multi-threaded
68 applications, see "extern int errno in perl.h". Creating such
69 a test requires taking into account the differences between
70 compiling multithreaded and singlethreaded ($ccflags et al).
71 HOST_NOT_FOUND is typically defined in <netdb.h>.
73 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
82 struct passwd *getpwnam (char *);
83 struct passwd *getpwuid (Uid_t);
88 struct passwd *getpwent (void);
89 #elif defined (VMS) && defined (my_getpwent)
90 struct passwd *Perl_my_getpwent (pTHX);
99 struct group *getgrnam (char *);
100 struct group *getgrgid (Gid_t);
104 struct group *getgrent (void);
110 # if defined(_MSC_VER) || defined(__MINGW32__)
111 # include <sys/utime.h>
118 # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
121 # define my_chsize PerlLIO_chsize
124 # define my_chsize PerlLIO_chsize
126 I32 my_chsize(int fd, Off_t length);
132 #else /* no flock() */
134 /* fcntl.h might not have been included, even if it exists, because
135 the current Configure only sets I_FCNTL if it's needed to pick up
136 the *_OK constants. Make sure it has been included before testing
137 the fcntl() locking constants. */
138 # if defined(HAS_FCNTL) && !defined(I_FCNTL)
142 # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
143 # define FLOCK fcntl_emulate_flock
144 # define FCNTL_EMULATE_FLOCK
145 # else /* no flock() or fcntl(F_SETLK,...) */
147 # define FLOCK lockf_emulate_flock
148 # define LOCKF_EMULATE_FLOCK
150 # endif /* no flock() or fcntl(F_SETLK,...) */
153 static int FLOCK (int, int);
156 * These are the flock() constants. Since this sytems doesn't have
157 * flock(), the values of the constants are probably not available.
171 # endif /* emulating flock() */
173 #endif /* no flock() */
176 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
178 #if defined(I_SYS_ACCESS) && !defined(R_OK)
179 # include <sys/access.h>
182 #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
183 # define FD_CLOEXEC 1 /* NeXT needs this */
189 /* Missing protos on LynxOS */
190 void sethostent(int);
191 void endhostent(void);
193 void endnetent(void);
194 void setprotoent(int);
195 void endprotoent(void);
196 void setservent(int);
197 void endservent(void);
200 #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
202 /* AIX 5.2 and below use mktime for localtime, and defines the edge case
203 * for time 0x7fffffff to be valid only in UTC. AIX 5.3 provides localtime64
204 * available in the 32bit environment, which could warrant Configure
205 * checks in the future.
208 #define LOCALTIME_EDGECASE_BROKEN
211 /* F_OK unused: if stat() cannot find it... */
213 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
214 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
215 # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
218 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
219 # ifdef I_SYS_SECURITY
220 # include <sys/security.h>
224 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
227 # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
231 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
233 # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
237 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
238 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
239 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
242 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
244 const Uid_t ruid = getuid();
245 const Uid_t euid = geteuid();
246 const Gid_t rgid = getgid();
247 const Gid_t egid = getegid();
251 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
252 Perl_croak(aTHX_ "switching effective uid is not implemented");
255 if (setreuid(euid, ruid))
258 if (setresuid(euid, ruid, (Uid_t)-1))
261 Perl_croak(aTHX_ "entering effective uid failed");
264 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
265 Perl_croak(aTHX_ "switching effective gid is not implemented");
268 if (setregid(egid, rgid))
271 if (setresgid(egid, rgid, (Gid_t)-1))
274 Perl_croak(aTHX_ "entering effective gid failed");
277 res = access(path, mode);
280 if (setreuid(ruid, euid))
283 if (setresuid(ruid, euid, (Uid_t)-1))
286 Perl_croak(aTHX_ "leaving effective uid failed");
289 if (setregid(rgid, egid))
292 if (setresgid(rgid, egid, (Gid_t)-1))
295 Perl_croak(aTHX_ "leaving effective gid failed");
300 # define PERL_EFF_ACCESS(p,f) (emulate_eaccess((p), (f)))
303 #if !defined(PERL_EFF_ACCESS)
304 /* With it or without it: anyway you get a warning: either that
305 it is unused, or it is declared static and never defined.
308 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
310 PERL_UNUSED_ARG(path);
311 PERL_UNUSED_ARG(mode);
312 Perl_croak(aTHX_ "switching effective uid is not implemented");
322 const char * const tmps = POPpconstx;
323 const I32 gimme = GIMME_V;
324 const char *mode = "r";
327 if (PL_op->op_private & OPpOPEN_IN_RAW)
329 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
331 fp = PerlProc_popen(tmps, mode);
333 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
335 PerlIO_apply_layers(aTHX_ fp,mode,type);
337 if (gimme == G_VOID) {
339 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
342 else if (gimme == G_SCALAR) {
345 PL_rs = &PL_sv_undef;
346 sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */
347 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
355 SV * const sv = newSV(79);
356 if (sv_gets(sv, fp, 0) == NULL) {
360 XPUSHs(sv_2mortal(sv));
361 if (SvLEN(sv) - SvCUR(sv) > 20) {
362 SvPV_shrink_to_cur(sv);
367 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
368 TAINT; /* "I believe that this is not gratuitous!" */
371 STATUS_NATIVE_CHILD_SET(-1);
372 if (gimme == G_SCALAR)
383 tryAMAGICunTARGET(iter, -1);
385 /* Note that we only ever get here if File::Glob fails to load
386 * without at the same time croaking, for some reason, or if
387 * perl was built with PERL_EXTERNAL_GLOB */
394 * The external globbing program may use things we can't control,
395 * so for security reasons we must assume the worst.
398 taint_proper(PL_no_security, "glob");
402 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
403 PL_last_in_gv = (GV*)*PL_stack_sp--;
405 SAVESPTR(PL_rs); /* This is not permanent, either. */
406 PL_rs = sv_2mortal(newSVpvs("\000"));
409 *SvPVX(PL_rs) = '\n';
413 result = do_readline();
421 PL_last_in_gv = cGVOP_gv;
422 return do_readline();
433 do_join(TARG, &PL_sv_no, MARK, SP);
437 else if (SP == MARK) {
444 tmps = SvPV_const(tmpsv, len);
445 if ((!tmps || !len) && PL_errgv) {
446 SV * const error = ERRSV;
447 SvUPGRADE(error, SVt_PV);
448 if (SvPOK(error) && SvCUR(error))
449 sv_catpvs(error, "\t...caught");
451 tmps = SvPV_const(tmpsv, len);
454 tmpsv = sv_2mortal(newSVpvs("Warning: something's wrong"));
456 Perl_warn(aTHX_ "%"SVf, (void*)tmpsv);
468 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
470 if (SP - MARK != 1) {
472 do_join(TARG, &PL_sv_no, MARK, SP);
474 tmps = SvPV_const(tmpsv, len);
480 tmps = SvROK(tmpsv) ? NULL : SvPV_const(tmpsv, len);
483 SV * const error = ERRSV;
484 SvUPGRADE(error, SVt_PV);
485 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
487 SvSetSV(error,tmpsv);
488 else if (sv_isobject(error)) {
489 HV * const stash = SvSTASH(SvRV(error));
490 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
492 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
493 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
500 call_sv((SV*)GvCV(gv),
501 G_SCALAR|G_EVAL|G_KEEPERR);
502 sv_setsv(error,*PL_stack_sp--);
508 if (SvPOK(error) && SvCUR(error))
509 sv_catpvs(error, "\t...propagated");
512 tmps = SvPV_const(tmpsv, len);
518 tmpsv = sv_2mortal(newSVpvs("Died"));
520 DIE(aTHX_ "%"SVf, (void*)tmpsv);
536 GV * const gv = (GV *)*++MARK;
539 DIE(aTHX_ PL_no_usym, "filehandle");
540 if ((io = GvIOp(gv))) {
542 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
544 mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
546 /* Method's args are same as ours ... */
547 /* ... except handle is replaced by the object */
548 *MARK-- = SvTIED_obj((SV*)io, mg);
552 call_method("OPEN", G_SCALAR);
566 tmps = SvPV_const(sv, len);
567 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
570 PUSHi( (I32)PL_forkprocess );
571 else if (PL_forkprocess == 0) /* we are a new child */
581 GV * const gv = (MAXARG == 0) ? PL_defoutgv : (GV*)POPs;
584 IO * const io = GvIO(gv);
586 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
589 XPUSHs(SvTIED_obj((SV*)io, mg));
592 call_method("CLOSE", G_SCALAR);
600 PUSHs(boolSV(do_close(gv, TRUE)));
613 GV * const wgv = (GV*)POPs;
614 GV * const rgv = (GV*)POPs;
619 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
620 DIE(aTHX_ PL_no_usym, "filehandle");
625 do_close(rgv, FALSE);
627 do_close(wgv, FALSE);
629 if (PerlProc_pipe(fd) < 0)
632 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
633 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
634 IoOFP(rstio) = IoIFP(rstio);
635 IoIFP(wstio) = IoOFP(wstio);
636 IoTYPE(rstio) = IoTYPE_RDONLY;
637 IoTYPE(wstio) = IoTYPE_WRONLY;
639 if (!IoIFP(rstio) || !IoOFP(wstio)) {
641 PerlIO_close(IoIFP(rstio));
643 PerlLIO_close(fd[0]);
645 PerlIO_close(IoOFP(wstio));
647 PerlLIO_close(fd[1]);
650 #if defined(HAS_FCNTL) && defined(F_SETFD)
651 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
652 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
659 DIE(aTHX_ PL_no_func, "pipe");
675 if (gv && (io = GvIO(gv))
676 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
679 XPUSHs(SvTIED_obj((SV*)io, mg));
682 call_method("FILENO", G_SCALAR);
688 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
689 /* Can't do this because people seem to do things like
690 defined(fileno($foo)) to check whether $foo is a valid fh.
691 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
692 report_evil_fh(gv, io, PL_op->op_type);
697 PUSHi(PerlIO_fileno(fp));
710 anum = PerlLIO_umask(0);
711 (void)PerlLIO_umask(anum);
714 anum = PerlLIO_umask(POPi);
715 TAINT_PROPER("umask");
718 /* Only DIE if trying to restrict permissions on "user" (self).
719 * Otherwise it's harmless and more useful to just return undef
720 * since 'group' and 'other' concepts probably don't exist here. */
721 if (MAXARG >= 1 && (POPi & 0700))
722 DIE(aTHX_ "umask not implemented");
723 XPUSHs(&PL_sv_undef);
744 if (gv && (io = GvIO(gv))) {
745 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
748 XPUSHs(SvTIED_obj((SV*)io, mg));
753 call_method("BINMODE", G_SCALAR);
761 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
762 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
763 report_evil_fh(gv, io, PL_op->op_type);
764 SETERRNO(EBADF,RMS_IFI);
769 if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
770 (discp) ? SvPV_nolen_const(discp) : NULL)) {
771 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
772 if (!PerlIO_binmode(aTHX_ IoOFP(io),IoTYPE(io),
773 mode_from_discipline(discp),
774 (discp) ? SvPV_nolen_const(discp) : NULL)) {
794 const I32 markoff = MARK - PL_stack_base;
795 const char *methname;
796 int how = PERL_MAGIC_tied;
800 switch(SvTYPE(varsv)) {
802 methname = "TIEHASH";
803 HvEITER_set((HV *)varsv, 0);
806 methname = "TIEARRAY";
809 #ifdef GV_UNIQUE_CHECK
810 if (GvUNIQUE((GV*)varsv)) {
811 Perl_croak(aTHX_ "Attempt to tie unique GV");
814 methname = "TIEHANDLE";
815 how = PERL_MAGIC_tiedscalar;
816 /* For tied filehandles, we apply tiedscalar magic to the IO
817 slot of the GP rather than the GV itself. AMS 20010812 */
819 GvIOp(varsv) = newIO();
820 varsv = (SV *)GvIOp(varsv);
823 methname = "TIESCALAR";
824 how = PERL_MAGIC_tiedscalar;
828 if (sv_isobject(*MARK)) {
830 PUSHSTACKi(PERLSI_MAGIC);
832 EXTEND(SP,(I32)items);
836 call_method(methname, G_SCALAR);
839 /* Not clear why we don't call call_method here too.
840 * perhaps to get different error message ?
842 stash = gv_stashsv(*MARK, FALSE);
843 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
844 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
845 methname, (void*)*MARK);
848 PUSHSTACKi(PERLSI_MAGIC);
850 EXTEND(SP,(I32)items);
854 call_sv((SV*)GvCV(gv), G_SCALAR);
860 if (sv_isobject(sv)) {
861 sv_unmagic(varsv, how);
862 /* Croak if a self-tie on an aggregate is attempted. */
863 if (varsv == SvRV(sv) &&
864 (SvTYPE(varsv) == SVt_PVAV ||
865 SvTYPE(varsv) == SVt_PVHV))
867 "Self-ties of arrays and hashes are not supported");
868 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
871 SP = PL_stack_base + markoff;
881 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
882 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
884 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
887 if ((mg = SvTIED_mg(sv, how))) {
888 SV * const obj = SvRV(SvTIED_obj(sv, mg));
890 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
892 if (gv && isGV(gv) && (cv = GvCV(gv))) {
894 XPUSHs(SvTIED_obj((SV*)gv, mg));
895 XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
898 call_sv((SV *)cv, G_VOID);
902 else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
903 Perl_warner(aTHX_ packWARN(WARN_UNTIE),
904 "untie attempted while %"UVuf" inner references still exist",
905 (UV)SvREFCNT(obj) - 1 ) ;
909 sv_unmagic(sv, how) ;
919 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
920 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
922 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
925 if ((mg = SvTIED_mg(sv, how))) {
926 SV *osv = SvTIED_obj(sv, mg);
927 if (osv == mg->mg_obj)
928 osv = sv_mortalcopy(osv);
942 HV * const hv = (HV*)POPs;
943 SV * const sv = sv_2mortal(newSVpvs("AnyDBM_File"));
944 stash = gv_stashsv(sv, FALSE);
945 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
947 require_pv("AnyDBM_File.pm");
949 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
950 DIE(aTHX_ "No dbm on this machine");
960 PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
962 PUSHs(sv_2mortal(newSVuv(O_RDWR)));
965 call_sv((SV*)GvCV(gv), G_SCALAR);
968 if (!sv_isobject(TOPs)) {
973 PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
976 call_sv((SV*)GvCV(gv), G_SCALAR);
980 if (sv_isobject(TOPs)) {
981 sv_unmagic((SV *) hv, PERL_MAGIC_tied);
982 sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, NULL, 0);
999 struct timeval timebuf;
1000 struct timeval *tbuf = &timebuf;
1003 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1008 # if BYTEORDER & 0xf0000
1009 # define ORDERBYTE (0x88888888 - BYTEORDER)
1011 # define ORDERBYTE (0x4444 - BYTEORDER)
1017 for (i = 1; i <= 3; i++) {
1018 SV * const sv = SP[i];
1021 if (SvREADONLY(sv)) {
1023 sv_force_normal_flags(sv, 0);
1024 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1025 DIE(aTHX_ PL_no_modify);
1028 if (ckWARN(WARN_MISC))
1029 Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1030 SvPV_force_nolen(sv); /* force string conversion */
1037 /* little endians can use vecs directly */
1038 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1045 masksize = NFDBITS / NBBY;
1047 masksize = sizeof(long); /* documented int, everyone seems to use long */
1049 Zero(&fd_sets[0], 4, char*);
1052 # if SELECT_MIN_BITS == 1
1053 growsize = sizeof(fd_set);
1055 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1056 # undef SELECT_MIN_BITS
1057 # define SELECT_MIN_BITS __FD_SETSIZE
1059 /* If SELECT_MIN_BITS is greater than one we most probably will want
1060 * to align the sizes with SELECT_MIN_BITS/8 because for example
1061 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1062 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1063 * on (sets/tests/clears bits) is 32 bits. */
1064 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1072 timebuf.tv_sec = (long)value;
1073 value -= (NV)timebuf.tv_sec;
1074 timebuf.tv_usec = (long)(value * 1000000.0);
1079 for (i = 1; i <= 3; i++) {
1081 if (!SvOK(sv) || SvCUR(sv) == 0) {
1088 Sv_Grow(sv, growsize);
1092 while (++j <= growsize) {
1096 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1098 Newx(fd_sets[i], growsize, char);
1099 for (offset = 0; offset < growsize; offset += masksize) {
1100 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1101 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1104 fd_sets[i] = SvPVX(sv);
1108 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1109 /* Can't make just the (void*) conditional because that would be
1110 * cpp #if within cpp macro, and not all compilers like that. */
1111 nfound = PerlSock_select(
1113 (Select_fd_set_t) fd_sets[1],
1114 (Select_fd_set_t) fd_sets[2],
1115 (Select_fd_set_t) fd_sets[3],
1116 (void*) tbuf); /* Workaround for compiler bug. */
1118 nfound = PerlSock_select(
1120 (Select_fd_set_t) fd_sets[1],
1121 (Select_fd_set_t) fd_sets[2],
1122 (Select_fd_set_t) fd_sets[3],
1125 for (i = 1; i <= 3; i++) {
1128 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1130 for (offset = 0; offset < growsize; offset += masksize) {
1131 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1132 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1134 Safefree(fd_sets[i]);
1141 if (GIMME == G_ARRAY && tbuf) {
1142 value = (NV)(timebuf.tv_sec) +
1143 (NV)(timebuf.tv_usec) / 1000000.0;
1144 PUSHs(sv_2mortal(newSVnv(value)));
1148 DIE(aTHX_ "select not implemented");
1153 Perl_setdefout(pTHX_ GV *gv)
1156 SvREFCNT_inc_simple_void(gv);
1158 SvREFCNT_dec(PL_defoutgv);
1166 GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : NULL;
1167 GV * egv = GvEGV(PL_defoutgv);
1173 XPUSHs(&PL_sv_undef);
1175 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1176 if (gvp && *gvp == egv) {
1177 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1181 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1186 if (!GvIO(newdefout))
1187 gv_IOadd(newdefout);
1188 setdefout(newdefout);
1198 GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs;
1200 if (gv && (io = GvIO(gv))) {
1201 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1203 const I32 gimme = GIMME_V;
1205 XPUSHs(SvTIED_obj((SV*)io, mg));
1208 call_method("GETC", gimme);
1211 if (gimme == G_SCALAR)
1212 SvSetMagicSV_nosteal(TARG, TOPs);
1216 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1217 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1218 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1219 report_evil_fh(gv, io, PL_op->op_type);
1220 SETERRNO(EBADF,RMS_IFI);
1224 sv_setpvn(TARG, " ", 1);
1225 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1226 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1227 /* Find out how many bytes the char needs */
1228 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1231 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1232 SvCUR_set(TARG,1+len);
1241 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1244 register PERL_CONTEXT *cx;
1245 const I32 gimme = GIMME_V;
1250 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1252 cx->blk_sub.retop = retop;
1254 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1256 setdefout(gv); /* locally select filehandle so $% et al work */
1288 goto not_a_format_reference;
1293 tmpsv = sv_newmortal();
1294 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1295 name = SvPV_nolen_const(tmpsv);
1297 DIE(aTHX_ "Undefined format \"%s\" called", name);
1299 not_a_format_reference:
1300 DIE(aTHX_ "Not a format reference");
1303 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1305 IoFLAGS(io) &= ~IOf_DIDTOP;
1306 return doform(cv,gv,PL_op->op_next);
1312 GV * const gv = cxstack[cxstack_ix].blk_sub.gv;
1313 register IO * const io = GvIOp(gv);
1318 register PERL_CONTEXT *cx;
1320 if (!io || !(ofp = IoOFP(io)))
1323 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1324 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1326 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1327 PL_formtarget != PL_toptarget)
1331 if (!IoTOP_GV(io)) {
1334 if (!IoTOP_NAME(io)) {
1336 if (!IoFMT_NAME(io))
1337 IoFMT_NAME(io) = savepv(GvNAME(gv));
1338 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1339 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1340 if ((topgv && GvFORM(topgv)) ||
1341 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1342 IoTOP_NAME(io) = savesvpv(topname);
1344 IoTOP_NAME(io) = savepvs("top");
1346 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1347 if (!topgv || !GvFORM(topgv)) {
1348 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1351 IoTOP_GV(io) = topgv;
1353 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1354 I32 lines = IoLINES_LEFT(io);
1355 const char *s = SvPVX_const(PL_formtarget);
1356 if (lines <= 0) /* Yow, header didn't even fit!!! */
1358 while (lines-- > 0) {
1359 s = strchr(s, '\n');
1365 const STRLEN save = SvCUR(PL_formtarget);
1366 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1367 do_print(PL_formtarget, ofp);
1368 SvCUR_set(PL_formtarget, save);
1369 sv_chop(PL_formtarget, s);
1370 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1373 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1374 do_print(PL_formfeed, ofp);
1375 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1377 PL_formtarget = PL_toptarget;
1378 IoFLAGS(io) |= IOf_DIDTOP;
1381 DIE(aTHX_ "bad top format reference");
1384 SV * const sv = sv_newmortal();
1386 gv_efullname4(sv, fgv, NULL, FALSE);
1387 name = SvPV_nolen_const(sv);
1389 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1391 DIE(aTHX_ "Undefined top format called");
1393 if (cv && CvCLONE(cv))
1394 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1395 return doform(cv, gv, PL_op);
1399 POPBLOCK(cx,PL_curpm);
1405 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1407 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1408 else if (ckWARN(WARN_CLOSED))
1409 report_evil_fh(gv, io, PL_op->op_type);
1414 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1415 if (ckWARN(WARN_IO))
1416 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1418 if (!do_print(PL_formtarget, fp))
1421 FmLINES(PL_formtarget) = 0;
1422 SvCUR_set(PL_formtarget, 0);
1423 *SvEND(PL_formtarget) = '\0';
1424 if (IoFLAGS(io) & IOf_FLUSH)
1425 (void)PerlIO_flush(fp);
1430 PL_formtarget = PL_bodytarget;
1432 PERL_UNUSED_VAR(newsp);
1433 PERL_UNUSED_VAR(gimme);
1434 return cx->blk_sub.retop;
1439 dVAR; dSP; dMARK; dORIGMARK;
1444 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
1446 if (gv && (io = GvIO(gv))) {
1447 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1449 if (MARK == ORIGMARK) {
1452 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1456 *MARK = SvTIED_obj((SV*)io, mg);
1459 call_method("PRINTF", G_SCALAR);
1462 MARK = ORIGMARK + 1;
1470 if (!(io = GvIO(gv))) {
1471 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1472 report_evil_fh(gv, io, PL_op->op_type);
1473 SETERRNO(EBADF,RMS_IFI);
1476 else if (!(fp = IoOFP(io))) {
1477 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1479 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1480 else if (ckWARN(WARN_CLOSED))
1481 report_evil_fh(gv, io, PL_op->op_type);
1483 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1487 do_sprintf(sv, SP - MARK, MARK + 1);
1488 if (!do_print(sv, fp))
1491 if (IoFLAGS(io) & IOf_FLUSH)
1492 if (PerlIO_flush(fp) == EOF)
1503 PUSHs(&PL_sv_undef);
1511 const int perm = (MAXARG > 3) ? POPi : 0666;
1512 const int mode = POPi;
1513 SV * const sv = POPs;
1514 GV * const gv = (GV *)POPs;
1517 /* Need TIEHANDLE method ? */
1518 const char * const tmps = SvPV_const(sv, len);
1519 /* FIXME? do_open should do const */
1520 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1521 IoLINES(GvIOp(gv)) = 0;
1525 PUSHs(&PL_sv_undef);
1532 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1538 Sock_size_t bufsize;
1546 bool charstart = FALSE;
1547 STRLEN charskip = 0;
1550 GV * const gv = (GV*)*++MARK;
1551 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1552 && gv && (io = GvIO(gv)) )
1554 const MAGIC * mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1558 *MARK = SvTIED_obj((SV*)io, mg);
1560 call_method("READ", G_SCALAR);
1574 sv_setpvn(bufsv, "", 0);
1575 length = SvIVx(*++MARK);
1578 offset = SvIVx(*++MARK);
1582 if (!io || !IoIFP(io)) {
1583 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1584 report_evil_fh(gv, io, PL_op->op_type);
1585 SETERRNO(EBADF,RMS_IFI);
1588 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1589 buffer = SvPVutf8_force(bufsv, blen);
1590 /* UTF-8 may not have been set if they are all low bytes */
1595 buffer = SvPV_force(bufsv, blen);
1596 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1599 DIE(aTHX_ "Negative length");
1607 if (PL_op->op_type == OP_RECV) {
1608 char namebuf[MAXPATHLEN];
1609 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1610 bufsize = sizeof (struct sockaddr_in);
1612 bufsize = sizeof namebuf;
1614 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1618 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1619 /* 'offset' means 'flags' here */
1620 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1621 (struct sockaddr *)namebuf, &bufsize);
1625 /* Bogus return without padding */
1626 bufsize = sizeof (struct sockaddr_in);
1628 SvCUR_set(bufsv, count);
1629 *SvEND(bufsv) = '\0';
1630 (void)SvPOK_only(bufsv);
1634 /* This should not be marked tainted if the fp is marked clean */
1635 if (!(IoFLAGS(io) & IOf_UNTAINT))
1636 SvTAINTED_on(bufsv);
1638 sv_setpvn(TARG, namebuf, bufsize);
1643 if (PL_op->op_type == OP_RECV)
1644 DIE(aTHX_ PL_no_sock_func, "recv");
1646 if (DO_UTF8(bufsv)) {
1647 /* offset adjust in characters not bytes */
1648 blen = sv_len_utf8(bufsv);
1651 if (-offset > (int)blen)
1652 DIE(aTHX_ "Offset outside string");
1655 if (DO_UTF8(bufsv)) {
1656 /* convert offset-as-chars to offset-as-bytes */
1657 if (offset >= (int)blen)
1658 offset += SvCUR(bufsv) - blen;
1660 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1663 bufsize = SvCUR(bufsv);
1664 /* Allocating length + offset + 1 isn't perfect in the case of reading
1665 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1667 (should be 2 * length + offset + 1, or possibly something longer if
1668 PL_encoding is true) */
1669 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1670 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1671 Zero(buffer+bufsize, offset-bufsize, char);
1673 buffer = buffer + offset;
1675 read_target = bufsv;
1677 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1678 concatenate it to the current buffer. */
1680 /* Truncate the existing buffer to the start of where we will be
1682 SvCUR_set(bufsv, offset);
1684 read_target = sv_newmortal();
1685 SvUPGRADE(read_target, SVt_PV);
1686 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1689 if (PL_op->op_type == OP_SYSREAD) {
1690 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1691 if (IoTYPE(io) == IoTYPE_SOCKET) {
1692 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1698 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1703 #ifdef HAS_SOCKET__bad_code_maybe
1704 if (IoTYPE(io) == IoTYPE_SOCKET) {
1705 char namebuf[MAXPATHLEN];
1706 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1707 bufsize = sizeof (struct sockaddr_in);
1709 bufsize = sizeof namebuf;
1711 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1712 (struct sockaddr *)namebuf, &bufsize);
1717 count = PerlIO_read(IoIFP(io), buffer, length);
1718 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1719 if (count == 0 && PerlIO_error(IoIFP(io)))
1723 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1724 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1727 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1728 *SvEND(read_target) = '\0';
1729 (void)SvPOK_only(read_target);
1730 if (fp_utf8 && !IN_BYTES) {
1731 /* Look at utf8 we got back and count the characters */
1732 const char *bend = buffer + count;
1733 while (buffer < bend) {
1735 skip = UTF8SKIP(buffer);
1738 if (buffer - charskip + skip > bend) {
1739 /* partial character - try for rest of it */
1740 length = skip - (bend-buffer);
1741 offset = bend - SvPVX_const(bufsv);
1753 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1754 provided amount read (count) was what was requested (length)
1756 if (got < wanted && count == length) {
1757 length = wanted - got;
1758 offset = bend - SvPVX_const(bufsv);
1761 /* return value is character count */
1765 else if (buffer_utf8) {
1766 /* Let svcatsv upgrade the bytes we read in to utf8.
1767 The buffer is a mortal so will be freed soon. */
1768 sv_catsv_nomg(bufsv, read_target);
1771 /* This should not be marked tainted if the fp is marked clean */
1772 if (!(IoFLAGS(io) & IOf_UNTAINT))
1773 SvTAINTED_on(bufsv);
1785 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1791 STRLEN orig_blen_bytes;
1792 const int op_type = PL_op->op_type;
1796 GV *const gv = (GV*)*++MARK;
1797 if (PL_op->op_type == OP_SYSWRITE
1798 && gv && (io = GvIO(gv))) {
1799 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1803 if (MARK == SP - 1) {
1805 sv = sv_2mortal(newSViv(sv_len(*SP)));
1811 *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg);
1813 call_method("WRITE", G_SCALAR);
1829 if (!io || !IoIFP(io)) {
1831 if (ckWARN(WARN_CLOSED))
1832 report_evil_fh(gv, io, PL_op->op_type);
1833 SETERRNO(EBADF,RMS_IFI);
1837 /* Do this first to trigger any overloading. */
1838 buffer = SvPV_const(bufsv, blen);
1839 orig_blen_bytes = blen;
1840 doing_utf8 = DO_UTF8(bufsv);
1842 if (PerlIO_isutf8(IoIFP(io))) {
1843 if (!SvUTF8(bufsv)) {
1844 /* We don't modify the original scalar. */
1845 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1846 buffer = (char *) tmpbuf;
1850 else if (doing_utf8) {
1851 STRLEN tmplen = blen;
1852 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1855 buffer = (char *) tmpbuf;
1859 assert((char *)result == buffer);
1860 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1864 if (op_type == OP_SYSWRITE) {
1865 Size_t length = 0; /* This length is in characters. */
1871 /* The SV is bytes, and we've had to upgrade it. */
1872 blen_chars = orig_blen_bytes;
1874 /* The SV really is UTF-8. */
1875 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1876 /* Don't call sv_len_utf8 again because it will call magic
1877 or overloading a second time, and we might get back a
1878 different result. */
1879 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1881 /* It's safe, and it may well be cached. */
1882 blen_chars = sv_len_utf8(bufsv);
1890 length = blen_chars;
1892 #if Size_t_size > IVSIZE
1893 length = (Size_t)SvNVx(*++MARK);
1895 length = (Size_t)SvIVx(*++MARK);
1897 if ((SSize_t)length < 0) {
1899 DIE(aTHX_ "Negative length");
1904 offset = SvIVx(*++MARK);
1906 if (-offset > (IV)blen_chars) {
1908 DIE(aTHX_ "Offset outside string");
1910 offset += blen_chars;
1911 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1913 DIE(aTHX_ "Offset outside string");
1917 if (length > blen_chars - offset)
1918 length = blen_chars - offset;
1920 /* Here we convert length from characters to bytes. */
1921 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1922 /* Either we had to convert the SV, or the SV is magical, or
1923 the SV has overloading, in which case we can't or mustn't
1924 or mustn't call it again. */
1926 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1927 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1929 /* It's a real UTF-8 SV, and it's not going to change under
1930 us. Take advantage of any cache. */
1932 I32 len_I32 = length;
1934 /* Convert the start and end character positions to bytes.
1935 Remember that the second argument to sv_pos_u2b is relative
1937 sv_pos_u2b(bufsv, &start, &len_I32);
1944 buffer = buffer+offset;
1946 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1947 if (IoTYPE(io) == IoTYPE_SOCKET) {
1948 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1954 /* See the note at doio.c:do_print about filesize limits. --jhi */
1955 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1961 const int flags = SvIVx(*++MARK);
1964 char * const sockbuf = SvPVx(*++MARK, mlen);
1965 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1966 flags, (struct sockaddr *)sockbuf, mlen);
1970 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1975 DIE(aTHX_ PL_no_sock_func, "send");
1982 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
1985 #if Size_t_size > IVSIZE
2004 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
2006 gv = PL_last_in_gv = GvEGV(PL_argvgv);
2008 if (io && !IoIFP(io)) {
2009 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2011 IoFLAGS(io) &= ~IOf_START;
2012 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2013 sv_setpvn(GvSV(gv), "-", 1);
2014 SvSETMAGIC(GvSV(gv));
2016 else if (!nextargv(gv))
2021 gv = PL_last_in_gv; /* eof */
2024 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
2027 IO * const io = GvIO(gv);
2029 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
2031 XPUSHs(SvTIED_obj((SV*)io, mg));
2034 call_method("EOF", G_SCALAR);
2041 PUSHs(boolSV(!gv || do_eof(gv)));
2052 PL_last_in_gv = (GV*)POPs;
2055 if (gv && (io = GvIO(gv))) {
2056 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2059 XPUSHs(SvTIED_obj((SV*)io, mg));
2062 call_method("TELL", G_SCALAR);
2069 #if LSEEKSIZE > IVSIZE
2070 PUSHn( do_tell(gv) );
2072 PUSHi( do_tell(gv) );
2080 const int whence = POPi;
2081 #if LSEEKSIZE > IVSIZE
2082 const Off_t offset = (Off_t)SvNVx(POPs);
2084 const Off_t offset = (Off_t)SvIVx(POPs);
2087 GV * const gv = PL_last_in_gv = (GV*)POPs;
2090 if (gv && (io = GvIO(gv))) {
2091 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2094 XPUSHs(SvTIED_obj((SV*)io, mg));
2095 #if LSEEKSIZE > IVSIZE
2096 XPUSHs(sv_2mortal(newSVnv((NV) offset)));
2098 XPUSHs(sv_2mortal(newSViv(offset)));
2100 XPUSHs(sv_2mortal(newSViv(whence)));
2103 call_method("SEEK", G_SCALAR);
2110 if (PL_op->op_type == OP_SEEK)
2111 PUSHs(boolSV(do_seek(gv, offset, whence)));
2113 const Off_t sought = do_sysseek(gv, offset, whence);
2115 PUSHs(&PL_sv_undef);
2117 SV* const sv = sought ?
2118 #if LSEEKSIZE > IVSIZE
2123 : newSVpvn(zero_but_true, ZBTLEN);
2124 PUSHs(sv_2mortal(sv));
2134 /* There seems to be no consensus on the length type of truncate()
2135 * and ftruncate(), both off_t and size_t have supporters. In
2136 * general one would think that when using large files, off_t is
2137 * at least as wide as size_t, so using an off_t should be okay. */
2138 /* XXX Configure probe for the length type of *truncate() needed XXX */
2141 #if Off_t_size > IVSIZE
2146 /* Checking for length < 0 is problematic as the type might or
2147 * might not be signed: if it is not, clever compilers will moan. */
2148 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2155 if (PL_op->op_flags & OPf_SPECIAL) {
2156 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2165 TAINT_PROPER("truncate");
2166 if (!(fp = IoIFP(io))) {
2172 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2174 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2181 SV * const sv = POPs;
2184 if (SvTYPE(sv) == SVt_PVGV) {
2185 tmpgv = (GV*)sv; /* *main::FRED for example */
2186 goto do_ftruncate_gv;
2188 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2189 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
2190 goto do_ftruncate_gv;
2192 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2193 io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
2194 goto do_ftruncate_io;
2197 name = SvPV_nolen_const(sv);
2198 TAINT_PROPER("truncate");
2200 if (truncate(name, len) < 0)
2204 const int tmpfd = PerlLIO_open(name, O_RDWR);
2209 if (my_chsize(tmpfd, len) < 0)
2211 PerlLIO_close(tmpfd);
2220 SETERRNO(EBADF,RMS_IFI);
2228 SV * const argsv = POPs;
2229 const unsigned int func = POPu;
2230 const int optype = PL_op->op_type;
2231 GV * const gv = (GV*)POPs;
2232 IO * const io = gv ? GvIOn(gv) : NULL;
2236 if (!io || !argsv || !IoIFP(io)) {
2237 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2238 report_evil_fh(gv, io, PL_op->op_type);
2239 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2243 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2246 s = SvPV_force(argsv, len);
2247 need = IOCPARM_LEN(func);
2249 s = Sv_Grow(argsv, need + 1);
2250 SvCUR_set(argsv, need);
2253 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2256 retval = SvIV(argsv);
2257 s = INT2PTR(char*,retval); /* ouch */
2260 TAINT_PROPER(PL_op_desc[optype]);
2262 if (optype == OP_IOCTL)
2264 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2266 DIE(aTHX_ "ioctl is not implemented");
2270 DIE(aTHX_ "fcntl is not implemented");
2272 #if defined(OS2) && defined(__EMX__)
2273 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2275 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2279 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2281 if (s[SvCUR(argsv)] != 17)
2282 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2284 s[SvCUR(argsv)] = 0; /* put our null back */
2285 SvSETMAGIC(argsv); /* Assume it has changed */
2294 PUSHp(zero_but_true, ZBTLEN);
2307 const int argtype = POPi;
2308 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
2310 if (gv && (io = GvIO(gv)))
2316 /* XXX Looks to me like io is always NULL at this point */
2318 (void)PerlIO_flush(fp);
2319 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2322 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2323 report_evil_fh(gv, io, PL_op->op_type);
2325 SETERRNO(EBADF,RMS_IFI);
2330 DIE(aTHX_ PL_no_func, "flock()");
2340 const int protocol = POPi;
2341 const int type = POPi;
2342 const int domain = POPi;
2343 GV * const gv = (GV*)POPs;
2344 register IO * const io = gv ? GvIOn(gv) : NULL;
2348 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2349 report_evil_fh(gv, io, PL_op->op_type);
2350 if (io && IoIFP(io))
2351 do_close(gv, FALSE);
2352 SETERRNO(EBADF,LIB_INVARG);
2357 do_close(gv, FALSE);
2359 TAINT_PROPER("socket");
2360 fd = PerlSock_socket(domain, type, protocol);
2363 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2364 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2365 IoTYPE(io) = IoTYPE_SOCKET;
2366 if (!IoIFP(io) || !IoOFP(io)) {
2367 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2368 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2369 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2372 #if defined(HAS_FCNTL) && defined(F_SETFD)
2373 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2377 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2382 DIE(aTHX_ PL_no_sock_func, "socket");
2388 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2390 const int protocol = POPi;
2391 const int type = POPi;
2392 const int domain = POPi;
2393 GV * const gv2 = (GV*)POPs;
2394 GV * const gv1 = (GV*)POPs;
2395 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2396 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2399 if (!gv1 || !gv2 || !io1 || !io2) {
2400 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2402 report_evil_fh(gv1, io1, PL_op->op_type);
2404 report_evil_fh(gv1, io2, PL_op->op_type);
2406 if (io1 && IoIFP(io1))
2407 do_close(gv1, FALSE);
2408 if (io2 && IoIFP(io2))
2409 do_close(gv2, FALSE);
2414 do_close(gv1, FALSE);
2416 do_close(gv2, FALSE);
2418 TAINT_PROPER("socketpair");
2419 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2421 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2422 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2423 IoTYPE(io1) = IoTYPE_SOCKET;
2424 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2425 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2426 IoTYPE(io2) = IoTYPE_SOCKET;
2427 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2428 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2429 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2430 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2431 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2432 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2433 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2436 #if defined(HAS_FCNTL) && defined(F_SETFD)
2437 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2438 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2443 DIE(aTHX_ PL_no_sock_func, "socketpair");
2451 SV * const addrsv = POPs;
2452 /* OK, so on what platform does bind modify addr? */
2454 GV * const gv = (GV*)POPs;
2455 register IO * const io = GvIOn(gv);
2458 if (!io || !IoIFP(io))
2461 addr = SvPV_const(addrsv, len);
2462 TAINT_PROPER("bind");
2463 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2469 if (ckWARN(WARN_CLOSED))
2470 report_evil_fh(gv, io, PL_op->op_type);
2471 SETERRNO(EBADF,SS_IVCHAN);
2474 DIE(aTHX_ PL_no_sock_func, "bind");
2482 SV * const addrsv = POPs;
2483 GV * const gv = (GV*)POPs;
2484 register IO * const io = GvIOn(gv);
2488 if (!io || !IoIFP(io))
2491 addr = SvPV_const(addrsv, len);
2492 TAINT_PROPER("connect");
2493 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2499 if (ckWARN(WARN_CLOSED))
2500 report_evil_fh(gv, io, PL_op->op_type);
2501 SETERRNO(EBADF,SS_IVCHAN);
2504 DIE(aTHX_ PL_no_sock_func, "connect");
2512 const int backlog = POPi;
2513 GV * const gv = (GV*)POPs;
2514 register IO * const io = gv ? GvIOn(gv) : NULL;
2516 if (!gv || !io || !IoIFP(io))
2519 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2525 if (ckWARN(WARN_CLOSED))
2526 report_evil_fh(gv, io, PL_op->op_type);
2527 SETERRNO(EBADF,SS_IVCHAN);
2530 DIE(aTHX_ PL_no_sock_func, "listen");
2540 char namebuf[MAXPATHLEN];
2541 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2542 Sock_size_t len = sizeof (struct sockaddr_in);
2544 Sock_size_t len = sizeof namebuf;
2546 GV * const ggv = (GV*)POPs;
2547 GV * const ngv = (GV*)POPs;
2556 if (!gstio || !IoIFP(gstio))
2560 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2563 /* Some platforms indicate zero length when an AF_UNIX client is
2564 * not bound. Simulate a non-zero-length sockaddr structure in
2566 namebuf[0] = 0; /* sun_len */
2567 namebuf[1] = AF_UNIX; /* sun_family */
2575 do_close(ngv, FALSE);
2576 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2577 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2578 IoTYPE(nstio) = IoTYPE_SOCKET;
2579 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2580 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2581 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2582 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2585 #if defined(HAS_FCNTL) && defined(F_SETFD)
2586 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2590 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2591 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2593 #ifdef __SCO_VERSION__
2594 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2597 PUSHp(namebuf, len);
2601 if (ckWARN(WARN_CLOSED))
2602 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2603 SETERRNO(EBADF,SS_IVCHAN);
2609 DIE(aTHX_ PL_no_sock_func, "accept");
2617 const int how = POPi;
2618 GV * const gv = (GV*)POPs;
2619 register IO * const io = GvIOn(gv);
2621 if (!io || !IoIFP(io))
2624 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2628 if (ckWARN(WARN_CLOSED))
2629 report_evil_fh(gv, io, PL_op->op_type);
2630 SETERRNO(EBADF,SS_IVCHAN);
2633 DIE(aTHX_ PL_no_sock_func, "shutdown");
2641 const int optype = PL_op->op_type;
2642 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2643 const unsigned int optname = (unsigned int) POPi;
2644 const unsigned int lvl = (unsigned int) POPi;
2645 GV * const gv = (GV*)POPs;
2646 register IO * const io = GvIOn(gv);
2650 if (!io || !IoIFP(io))
2653 fd = PerlIO_fileno(IoIFP(io));
2657 (void)SvPOK_only(sv);
2661 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2668 #if defined(__SYMBIAN32__)
2669 # define SETSOCKOPT_OPTION_VALUE_T void *
2671 # define SETSOCKOPT_OPTION_VALUE_T const char *
2673 /* XXX TODO: We need to have a proper type (a Configure probe,
2674 * etc.) for what the C headers think of the third argument of
2675 * setsockopt(), the option_value read-only buffer: is it
2676 * a "char *", or a "void *", const or not. Some compilers
2677 * don't take kindly to e.g. assuming that "char *" implicitly
2678 * promotes to a "void *", or to explicitly promoting/demoting
2679 * consts to non/vice versa. The "const void *" is the SUS
2680 * definition, but that does not fly everywhere for the above
2682 SETSOCKOPT_OPTION_VALUE_T buf;
2686 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2690 aint = (int)SvIV(sv);
2691 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2694 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2703 if (ckWARN(WARN_CLOSED))
2704 report_evil_fh(gv, io, optype);
2705 SETERRNO(EBADF,SS_IVCHAN);
2710 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2718 const int optype = PL_op->op_type;
2719 GV * const gv = (GV*)POPs;
2720 register IO * const io = GvIOn(gv);
2725 if (!io || !IoIFP(io))
2728 sv = sv_2mortal(newSV(257));
2729 (void)SvPOK_only(sv);
2733 fd = PerlIO_fileno(IoIFP(io));
2735 case OP_GETSOCKNAME:
2736 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2739 case OP_GETPEERNAME:
2740 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2742 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2744 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";
2745 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2746 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2747 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2748 sizeof(u_short) + sizeof(struct in_addr))) {
2755 #ifdef BOGUS_GETNAME_RETURN
2756 /* Interactive Unix, getpeername() and getsockname()
2757 does not return valid namelen */
2758 if (len == BOGUS_GETNAME_RETURN)
2759 len = sizeof(struct sockaddr);
2767 if (ckWARN(WARN_CLOSED))
2768 report_evil_fh(gv, io, optype);
2769 SETERRNO(EBADF,SS_IVCHAN);
2774 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2789 if (PL_op->op_flags & OPf_REF) {
2791 if (PL_op->op_type == OP_LSTAT) {
2792 if (gv != PL_defgv) {
2793 do_fstat_warning_check:
2794 if (ckWARN(WARN_IO))
2795 Perl_warner(aTHX_ packWARN(WARN_IO),
2796 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2797 } else if (PL_laststype != OP_LSTAT)
2798 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2802 if (gv != PL_defgv) {
2803 PL_laststype = OP_STAT;
2805 sv_setpvn(PL_statname, "", 0);
2812 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2813 } else if (IoDIRP(io)) {
2816 PerlLIO_fstat(dirfd(IoDIRP(io)), &PL_statcache);
2818 DIE(aTHX_ PL_no_func, "dirfd");
2821 PL_laststatval = -1;
2827 if (PL_laststatval < 0) {
2828 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2829 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2834 SV* const sv = POPs;
2835 if (SvTYPE(sv) == SVt_PVGV) {
2838 } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2840 if (PL_op->op_type == OP_LSTAT)
2841 goto do_fstat_warning_check;
2843 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2845 if (PL_op->op_type == OP_LSTAT)
2846 goto do_fstat_warning_check;
2847 goto do_fstat_have_io;
2850 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2852 PL_laststype = PL_op->op_type;
2853 if (PL_op->op_type == OP_LSTAT)
2854 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2856 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2857 if (PL_laststatval < 0) {
2858 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2859 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2865 if (gimme != G_ARRAY) {
2866 if (gimme != G_VOID)
2867 XPUSHs(boolSV(max));
2873 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2874 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2875 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2876 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2877 #if Uid_t_size > IVSIZE
2878 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2880 # if Uid_t_sign <= 0
2881 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2883 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2886 #if Gid_t_size > IVSIZE
2887 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2889 # if Gid_t_sign <= 0
2890 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2892 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2895 #ifdef USE_STAT_RDEV
2896 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2898 PUSHs(sv_2mortal(newSVpvs("")));
2900 #if Off_t_size > IVSIZE
2901 PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
2903 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2906 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2907 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2908 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2910 PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2911 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2912 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
2914 #ifdef USE_STAT_BLOCKS
2915 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2916 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2918 PUSHs(sv_2mortal(newSVpvs("")));
2919 PUSHs(sv_2mortal(newSVpvs("")));
2925 /* This macro is used by the stacked filetest operators :
2926 * if the previous filetest failed, short-circuit and pass its value.
2927 * Else, discard it from the stack and continue. --rgs
2929 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2930 if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
2931 else { (void)POPs; PUTBACK; } \
2938 /* Not const, because things tweak this below. Not bool, because there's
2939 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2940 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2941 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2942 /* Giving some sort of initial value silences compilers. */
2944 int access_mode = R_OK;
2946 int access_mode = 0;
2949 /* access_mode is never used, but leaving use_access in makes the
2950 conditional compiling below much clearer. */
2953 int stat_mode = S_IRUSR;
2955 bool effective = FALSE;
2958 STACKED_FTEST_CHECK;
2960 switch (PL_op->op_type) {
2962 #if !(defined(HAS_ACCESS) && defined(R_OK))
2968 #if defined(HAS_ACCESS) && defined(W_OK)
2973 stat_mode = S_IWUSR;
2977 #if defined(HAS_ACCESS) && defined(X_OK)
2982 stat_mode = S_IXUSR;
2986 #ifdef PERL_EFF_ACCESS
2989 stat_mode = S_IWUSR;
2993 #ifndef PERL_EFF_ACCESS
3001 #ifdef PERL_EFF_ACCESS
3006 stat_mode = S_IXUSR;
3012 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3013 const char *const name = POPpx;
3015 # ifdef PERL_EFF_ACCESS
3016 result = PERL_EFF_ACCESS(name, access_mode);
3018 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3024 result = access(name, access_mode);
3026 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3041 if (cando(stat_mode, effective, &PL_statcache))
3050 const int op_type = PL_op->op_type;
3052 STACKED_FTEST_CHECK;
3057 if (op_type == OP_FTIS)
3060 /* You can't dTARGET inside OP_FTIS, because you'll get
3061 "panic: pad_sv po" - the op is not flagged to have a target. */
3065 #if Off_t_size > IVSIZE
3066 PUSHn(PL_statcache.st_size);
3068 PUSHi(PL_statcache.st_size);
3072 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3075 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3078 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3091 /* I believe that all these three are likely to be defined on most every
3092 system these days. */
3094 if(PL_op->op_type == OP_FTSUID)
3098 if(PL_op->op_type == OP_FTSGID)
3102 if(PL_op->op_type == OP_FTSVTX)
3106 STACKED_FTEST_CHECK;
3111 switch (PL_op->op_type) {
3113 if (PL_statcache.st_uid == PL_uid)
3117 if (PL_statcache.st_uid == PL_euid)
3121 if (PL_statcache.st_size == 0)
3125 if (S_ISSOCK(PL_statcache.st_mode))
3129 if (S_ISCHR(PL_statcache.st_mode))
3133 if (S_ISBLK(PL_statcache.st_mode))
3137 if (S_ISREG(PL_statcache.st_mode))
3141 if (S_ISDIR(PL_statcache.st_mode))
3145 if (S_ISFIFO(PL_statcache.st_mode))
3150 if (PL_statcache.st_mode & S_ISUID)
3156 if (PL_statcache.st_mode & S_ISGID)
3162 if (PL_statcache.st_mode & S_ISVTX)
3173 I32 result = my_lstat();
3177 if (S_ISLNK(PL_statcache.st_mode))
3190 STACKED_FTEST_CHECK;
3192 if (PL_op->op_flags & OPf_REF)
3194 else if (isGV(TOPs))
3196 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3197 gv = (GV*)SvRV(POPs);
3199 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3201 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3202 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3203 else if (tmpsv && SvOK(tmpsv)) {
3204 const char *tmps = SvPV_nolen_const(tmpsv);
3212 if (PerlLIO_isatty(fd))
3217 #if defined(atarist) /* this will work with atariST. Configure will
3218 make guesses for other systems. */
3219 # define FILE_base(f) ((f)->_base)
3220 # define FILE_ptr(f) ((f)->_ptr)
3221 # define FILE_cnt(f) ((f)->_cnt)
3222 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3233 register STDCHAR *s;
3239 STACKED_FTEST_CHECK;
3241 if (PL_op->op_flags & OPf_REF)
3243 else if (isGV(TOPs))
3245 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3246 gv = (GV*)SvRV(POPs);
3252 if (gv == PL_defgv) {
3254 io = GvIO(PL_statgv);
3257 goto really_filename;
3262 PL_laststatval = -1;
3263 sv_setpvn(PL_statname, "", 0);
3264 io = GvIO(PL_statgv);
3266 if (io && IoIFP(io)) {
3267 if (! PerlIO_has_base(IoIFP(io)))
3268 DIE(aTHX_ "-T and -B not implemented on filehandles");
3269 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3270 if (PL_laststatval < 0)
3272 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3273 if (PL_op->op_type == OP_FTTEXT)
3278 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3279 i = PerlIO_getc(IoIFP(io));
3281 (void)PerlIO_ungetc(IoIFP(io),i);
3283 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3285 len = PerlIO_get_bufsiz(IoIFP(io));
3286 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3287 /* sfio can have large buffers - limit to 512 */
3292 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3294 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3296 SETERRNO(EBADF,RMS_IFI);
3304 PL_laststype = OP_STAT;
3305 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3306 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3307 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3309 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3312 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3313 if (PL_laststatval < 0) {
3314 (void)PerlIO_close(fp);
3317 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3318 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3319 (void)PerlIO_close(fp);
3321 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3322 RETPUSHNO; /* special case NFS directories */
3323 RETPUSHYES; /* null file is anything */
3328 /* now scan s to look for textiness */
3329 /* XXX ASCII dependent code */
3331 #if defined(DOSISH) || defined(USEMYBINMODE)
3332 /* ignore trailing ^Z on short files */
3333 if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3337 for (i = 0; i < len; i++, s++) {
3338 if (!*s) { /* null never allowed in text */
3343 else if (!(isPRINT(*s) || isSPACE(*s)))
3346 else if (*s & 128) {
3348 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3351 /* utf8 characters don't count as odd */
3352 if (UTF8_IS_START(*s)) {
3353 int ulen = UTF8SKIP(s);
3354 if (ulen < len - i) {
3356 for (j = 1; j < ulen; j++) {
3357 if (!UTF8_IS_CONTINUATION(s[j]))
3360 --ulen; /* loop does extra increment */
3370 *s != '\n' && *s != '\r' && *s != '\b' &&
3371 *s != '\t' && *s != '\f' && *s != 27)
3376 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3387 const char *tmps = NULL;
3391 SV * const sv = POPs;
3392 if (PL_op->op_flags & OPf_SPECIAL) {
3393 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3395 else if (SvTYPE(sv) == SVt_PVGV) {
3398 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
3402 tmps = SvPVx_nolen_const(sv);
3406 if( !gv && (!tmps || !*tmps) ) {
3407 HV * const table = GvHVn(PL_envgv);
3410 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3411 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3413 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3418 deprecate("chdir('') or chdir(undef) as chdir()");
3419 tmps = SvPV_nolen_const(*svp);
3423 TAINT_PROPER("chdir");
3428 TAINT_PROPER("chdir");
3431 IO* const io = GvIO(gv);
3434 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3436 else if (IoDIRP(io)) {
3438 PUSHi(fchdir(dirfd(IoDIRP(io))) >= 0);
3440 DIE(aTHX_ PL_no_func, "dirfd");
3444 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3445 report_evil_fh(gv, io, PL_op->op_type);
3446 SETERRNO(EBADF, RMS_IFI);
3451 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3452 report_evil_fh(gv, io, PL_op->op_type);
3453 SETERRNO(EBADF,RMS_IFI);
3457 DIE(aTHX_ PL_no_func, "fchdir");
3461 PUSHi( PerlDir_chdir(tmps) >= 0 );
3463 /* Clear the DEFAULT element of ENV so we'll get the new value
3465 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3472 dVAR; dSP; dMARK; dTARGET;
3473 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3484 char * const tmps = POPpx;
3485 TAINT_PROPER("chroot");
3486 PUSHi( chroot(tmps) >= 0 );
3489 DIE(aTHX_ PL_no_func, "chroot");
3497 const char * const tmps2 = POPpconstx;
3498 const char * const tmps = SvPV_nolen_const(TOPs);
3499 TAINT_PROPER("rename");
3501 anum = PerlLIO_rename(tmps, tmps2);
3503 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3504 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3507 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3508 (void)UNLINK(tmps2);
3509 if (!(anum = link(tmps, tmps2)))
3510 anum = UNLINK(tmps);
3518 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3522 const int op_type = PL_op->op_type;
3526 if (op_type == OP_LINK)
3527 DIE(aTHX_ PL_no_func, "link");
3529 # ifndef HAS_SYMLINK
3530 if (op_type == OP_SYMLINK)
3531 DIE(aTHX_ PL_no_func, "symlink");
3535 const char * const tmps2 = POPpconstx;
3536 const char * const tmps = SvPV_nolen_const(TOPs);
3537 TAINT_PROPER(PL_op_desc[op_type]);
3539 # if defined(HAS_LINK)
3540 # if defined(HAS_SYMLINK)
3541 /* Both present - need to choose which. */
3542 (op_type == OP_LINK) ?
3543 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3545 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3546 PerlLIO_link(tmps, tmps2);
3549 # if defined(HAS_SYMLINK)
3550 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3551 symlink(tmps, tmps2);
3556 SETi( result >= 0 );
3563 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3574 char buf[MAXPATHLEN];
3577 #ifndef INCOMPLETE_TAINTS
3581 len = readlink(tmps, buf, sizeof(buf) - 1);
3589 RETSETUNDEF; /* just pretend it's a normal file */
3593 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3595 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3597 char * const save_filename = filename;
3602 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3604 Newx(cmdline, size, char);
3605 my_strlcpy(cmdline, cmd, size);
3606 my_strlcat(cmdline, " ", size);
3607 for (s = cmdline + strlen(cmdline); *filename; ) {
3611 if (s - cmdline < size)
3612 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3613 myfp = PerlProc_popen(cmdline, "r");
3617 SV * const tmpsv = sv_newmortal();
3618 /* Need to save/restore 'PL_rs' ?? */
3619 s = sv_gets(tmpsv, myfp, 0);
3620 (void)PerlProc_pclose(myfp);
3624 #ifdef HAS_SYS_ERRLIST
3629 /* you don't see this */
3630 const char * const errmsg =
3631 #ifdef HAS_SYS_ERRLIST
3639 if (instr(s, errmsg)) {
3646 #define EACCES EPERM
3648 if (instr(s, "cannot make"))
3649 SETERRNO(EEXIST,RMS_FEX);
3650 else if (instr(s, "existing file"))
3651 SETERRNO(EEXIST,RMS_FEX);
3652 else if (instr(s, "ile exists"))
3653 SETERRNO(EEXIST,RMS_FEX);
3654 else if (instr(s, "non-exist"))
3655 SETERRNO(ENOENT,RMS_FNF);
3656 else if (instr(s, "does not exist"))
3657 SETERRNO(ENOENT,RMS_FNF);
3658 else if (instr(s, "not empty"))
3659 SETERRNO(EBUSY,SS_DEVOFFLINE);
3660 else if (instr(s, "cannot access"))
3661 SETERRNO(EACCES,RMS_PRV);
3663 SETERRNO(EPERM,RMS_PRV);
3666 else { /* some mkdirs return no failure indication */
3667 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3668 if (PL_op->op_type == OP_RMDIR)
3673 SETERRNO(EACCES,RMS_PRV); /* a guess */
3682 /* This macro removes trailing slashes from a directory name.
3683 * Different operating and file systems take differently to
3684 * trailing slashes. According to POSIX 1003.1 1996 Edition
3685 * any number of trailing slashes should be allowed.
3686 * Thusly we snip them away so that even non-conforming
3687 * systems are happy.
3688 * We should probably do this "filtering" for all
3689 * the functions that expect (potentially) directory names:
3690 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3691 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3693 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3694 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3697 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3698 (tmps) = savepvn((tmps), (len)); \
3708 const int mode = (MAXARG > 1) ? POPi : 0777;
3710 TRIMSLASHES(tmps,len,copy);
3712 TAINT_PROPER("mkdir");
3714 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3718 SETi( dooneliner("mkdir", tmps) );
3719 oldumask = PerlLIO_umask(0);
3720 PerlLIO_umask(oldumask);
3721 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3736 TRIMSLASHES(tmps,len,copy);
3737 TAINT_PROPER("rmdir");
3739 SETi( PerlDir_rmdir(tmps) >= 0 );
3741 SETi( dooneliner("rmdir", tmps) );
3748 /* Directory calls. */
3752 #if defined(Direntry_t) && defined(HAS_READDIR)
3754 const char * const dirname = POPpconstx;
3755 GV * const gv = (GV*)POPs;
3756 register IO * const io = GvIOn(gv);
3762 PerlDir_close(IoDIRP(io));
3763 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3769 SETERRNO(EBADF,RMS_DIR);
3772 DIE(aTHX_ PL_no_dir_func, "opendir");
3778 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3779 DIE(aTHX_ PL_no_dir_func, "readdir");
3781 #if !defined(I_DIRENT) && !defined(VMS)
3782 Direntry_t *readdir (DIR *);
3788 const I32 gimme = GIMME;
3789 GV * const gv = (GV *)POPs;
3790 register const Direntry_t *dp;
3791 register IO * const io = GvIOn(gv);
3793 if (!io || !IoDIRP(io)) {
3794 if(ckWARN(WARN_IO)) {
3795 Perl_warner(aTHX_ packWARN(WARN_IO),
3796 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3802 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3806 sv = newSVpvn(dp->d_name, dp->d_namlen);
3808 sv = newSVpv(dp->d_name, 0);
3810 #ifndef INCOMPLETE_TAINTS
3811 if (!(IoFLAGS(io) & IOf_UNTAINT))
3814 XPUSHs(sv_2mortal(sv));
3815 } while (gimme == G_ARRAY);
3817 if (!dp && gimme != G_ARRAY)
3824 SETERRNO(EBADF,RMS_ISI);
3825 if (GIMME == G_ARRAY)
3834 #if defined(HAS_TELLDIR) || defined(telldir)
3836 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3837 /* XXX netbsd still seemed to.
3838 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3839 --JHI 1999-Feb-02 */
3840 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3841 long telldir (DIR *);
3843 GV * const gv = (GV*)POPs;
3844 register IO * const io = GvIOn(gv);
3846 if (!io || !IoDIRP(io)) {
3847 if(ckWARN(WARN_IO)) {
3848 Perl_warner(aTHX_ packWARN(WARN_IO),
3849 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3854 PUSHi( PerlDir_tell(IoDIRP(io)) );
3858 SETERRNO(EBADF,RMS_ISI);
3861 DIE(aTHX_ PL_no_dir_func, "telldir");
3867 #if defined(HAS_SEEKDIR) || defined(seekdir)
3869 const long along = POPl;
3870 GV * const gv = (GV*)POPs;
3871 register IO * const io = GvIOn(gv);
3873 if (!io || !IoDIRP(io)) {
3874 if(ckWARN(WARN_IO)) {
3875 Perl_warner(aTHX_ packWARN(WARN_IO),
3876 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3880 (void)PerlDir_seek(IoDIRP(io), along);
3885 SETERRNO(EBADF,RMS_ISI);
3888 DIE(aTHX_ PL_no_dir_func, "seekdir");
3894 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3896 GV * const gv = (GV*)POPs;
3897 register IO * const io = GvIOn(gv);
3899 if (!io || !IoDIRP(io)) {
3900 if(ckWARN(WARN_IO)) {
3901 Perl_warner(aTHX_ packWARN(WARN_IO),
3902 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3906 (void)PerlDir_rewind(IoDIRP(io));
3910 SETERRNO(EBADF,RMS_ISI);
3913 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3919 #if defined(Direntry_t) && defined(HAS_READDIR)
3921 GV * const gv = (GV*)POPs;
3922 register IO * const io = GvIOn(gv);
3924 if (!io || !IoDIRP(io)) {
3925 if(ckWARN(WARN_IO)) {
3926 Perl_warner(aTHX_ packWARN(WARN_IO),
3927 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3931 #ifdef VOID_CLOSEDIR
3932 PerlDir_close(IoDIRP(io));
3934 if (PerlDir_close(IoDIRP(io)) < 0) {
3935 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3944 SETERRNO(EBADF,RMS_IFI);
3947 DIE(aTHX_ PL_no_dir_func, "closedir");
3951 /* Process control. */
3960 PERL_FLUSHALL_FOR_CHILD;
3961 childpid = PerlProc_fork();
3965 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3967 SvREADONLY_off(GvSV(tmpgv));
3968 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3969 SvREADONLY_on(GvSV(tmpgv));
3971 #ifdef THREADS_HAVE_PIDS
3972 PL_ppid = (IV)getppid();
3974 #ifdef PERL_USES_PL_PIDSTATUS
3975 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3981 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3986 PERL_FLUSHALL_FOR_CHILD;
3987 childpid = PerlProc_fork();
3993 DIE(aTHX_ PL_no_func, "fork");
4000 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4005 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4006 childpid = wait4pid(-1, &argflags, 0);
4008 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4013 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4014 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4015 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4017 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4022 DIE(aTHX_ PL_no_func, "wait");
4028 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
4030 const int optype = POPi;
4031 const Pid_t pid = TOPi;
4035 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4036 result = wait4pid(pid, &argflags, optype);
4038 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4043 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4044 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4045 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4047 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4052 DIE(aTHX_ PL_no_func, "waitpid");
4058 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4064 while (++MARK <= SP) {
4065 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4070 TAINT_PROPER("system");
4072 PERL_FLUSHALL_FOR_CHILD;
4073 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4079 if (PerlProc_pipe(pp) >= 0)
4081 while ((childpid = PerlProc_fork()) == -1) {
4082 if (errno != EAGAIN) {
4087 PerlLIO_close(pp[0]);
4088 PerlLIO_close(pp[1]);
4095 Sigsave_t ihand,qhand; /* place to save signals during system() */
4099 PerlLIO_close(pp[1]);
4101 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4102 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4105 result = wait4pid(childpid, &status, 0);
4106 } while (result == -1 && errno == EINTR);
4108 (void)rsignal_restore(SIGINT, &ihand);
4109 (void)rsignal_restore(SIGQUIT, &qhand);
4111 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4112 do_execfree(); /* free any memory child malloced on fork */
4119 while (n < sizeof(int)) {
4120 n1 = PerlLIO_read(pp[0],
4121 (void*)(((char*)&errkid)+n),
4127 PerlLIO_close(pp[0]);
4128 if (n) { /* Error */
4129 if (n != sizeof(int))
4130 DIE(aTHX_ "panic: kid popen errno read");
4131 errno = errkid; /* Propagate errno from kid */
4132 STATUS_NATIVE_CHILD_SET(-1);
4135 XPUSHi(STATUS_CURRENT);
4139 PerlLIO_close(pp[0]);
4140 #if defined(HAS_FCNTL) && defined(F_SETFD)
4141 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4144 if (PL_op->op_flags & OPf_STACKED) {
4145 SV * const really = *++MARK;
4146 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4148 else if (SP - MARK != 1)
4149 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4151 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4155 #else /* ! FORK or VMS or OS/2 */
4158 if (PL_op->op_flags & OPf_STACKED) {
4159 SV * const really = *++MARK;
4160 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4161 value = (I32)do_aspawn(really, MARK, SP);
4163 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4166 else if (SP - MARK != 1) {
4167 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4168 value = (I32)do_aspawn(NULL, MARK, SP);
4170 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4174 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4176 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4178 STATUS_NATIVE_CHILD_SET(value);
4181 XPUSHi(result ? value : STATUS_CURRENT);
4182 #endif /* !FORK or VMS */
4188 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4193 while (++MARK <= SP) {
4194 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4199 TAINT_PROPER("exec");
4201 PERL_FLUSHALL_FOR_CHILD;
4202 if (PL_op->op_flags & OPf_STACKED) {
4203 SV * const really = *++MARK;
4204 value = (I32)do_aexec(really, MARK, SP);
4206 else if (SP - MARK != 1)
4208 value = (I32)vms_do_aexec(NULL, MARK, SP);
4212 (void ) do_aspawn(NULL, MARK, SP);
4216 value = (I32)do_aexec(NULL, MARK, SP);
4221 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4224 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4227 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4241 # ifdef THREADS_HAVE_PIDS
4242 if (PL_ppid != 1 && getppid() == 1)
4243 /* maybe the parent process has died. Refresh ppid cache */
4247 XPUSHi( getppid() );
4251 DIE(aTHX_ PL_no_func, "getppid");
4260 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4263 pgrp = (I32)BSD_GETPGRP(pid);
4265 if (pid != 0 && pid != PerlProc_getpid())
4266 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4272 DIE(aTHX_ PL_no_func, "getpgrp()");
4291 TAINT_PROPER("setpgrp");
4293 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4295 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4296 || (pid != 0 && pid != PerlProc_getpid()))
4298 DIE(aTHX_ "setpgrp can't take arguments");
4300 SETi( setpgrp() >= 0 );
4301 #endif /* USE_BSDPGRP */
4304 DIE(aTHX_ PL_no_func, "setpgrp()");
4310 #ifdef HAS_GETPRIORITY
4312 const int who = POPi;
4313 const int which = TOPi;
4314 SETi( getpriority(which, who) );
4317 DIE(aTHX_ PL_no_func, "getpriority()");
4323 #ifdef HAS_SETPRIORITY
4325 const int niceval = POPi;
4326 const int who = POPi;
4327 const int which = TOPi;
4328 TAINT_PROPER("setpriority");
4329 SETi( setpriority(which, who, niceval) >= 0 );
4332 DIE(aTHX_ PL_no_func, "setpriority()");
4342 XPUSHn( time(NULL) );
4344 XPUSHi( time(NULL) );
4356 (void)PerlProc_times(&PL_timesbuf);
4358 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4359 /* struct tms, though same data */
4363 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
4364 if (GIMME == G_ARRAY) {
4365 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
4366 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
4367 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
4373 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4375 if (GIMME == G_ARRAY) {
4376 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4377 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4378 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4382 DIE(aTHX_ "times not implemented");
4384 #endif /* HAS_TIMES */
4387 #ifdef LOCALTIME_EDGECASE_BROKEN
4388 static struct tm *S_my_localtime (pTHX_ Time_t *tp)
4393 /* No workarounds in the valid range */
4394 if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4395 return (localtime (tp));
4397 /* This edge case is to workaround the undefined behaviour, where the
4398 * TIMEZONE makes the time go beyond the defined range.
4399 * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4400 * If there is a negative offset in TZ, like MET-1METDST, some broken
4401 * implementations of localtime () (like AIX 5.2) barf with bogus
4403 * 0x7fffffff gmtime 2038-01-19 03:14:07
4404 * 0x7fffffff localtime 1901-12-13 21:45:51
4405 * 0x7fffffff mylocaltime 2038-01-19 04:14:07
4406 * 0x3c19137f gmtime 2001-12-13 20:45:51
4407 * 0x3c19137f localtime 2001-12-13 21:45:51
4408 * 0x3c19137f mylocaltime 2001-12-13 21:45:51
4409 * Given that legal timezones are typically between GMT-12 and GMT+12
4410 * we turn back the clock 23 hours before calling the localtime
4411 * function, and add those to the return value. This will never cause
4412 * day wrapping problems, since the edge case is Tue Jan *19*
4414 T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4417 if (P->tm_hour >= 24) {
4419 P->tm_mday++; /* 18 -> 19 */
4420 P->tm_wday++; /* Mon -> Tue */
4421 P->tm_yday++; /* 18 -> 19 */
4424 } /* S_my_localtime */
4432 const struct tm *tmbuf;
4433 static const char * const dayname[] =
4434 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4435 static const char * const monname[] =
4436 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4437 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4443 when = (Time_t)SvNVx(POPs);
4445 when = (Time_t)SvIVx(POPs);
4448 if (PL_op->op_type == OP_LOCALTIME)
4449 #ifdef LOCALTIME_EDGECASE_BROKEN
4450 tmbuf = S_my_localtime(aTHX_ &when);
4452 tmbuf = localtime(&when);
4455 tmbuf = gmtime(&when);
4457 if (GIMME != G_ARRAY) {
4463 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4464 dayname[tmbuf->tm_wday],
4465 monname[tmbuf->tm_mon],
4470 tmbuf->tm_year + 1900);
4471 PUSHs(sv_2mortal(tsv));
4476 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4477 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4478 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4479 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4480 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4481 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4482 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4483 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4484 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4495 anum = alarm((unsigned int)anum);
4502 DIE(aTHX_ PL_no_func, "alarm");
4513 (void)time(&lasttime);
4518 PerlProc_sleep((unsigned int)duration);
4521 XPUSHi(when - lasttime);
4525 /* Shared memory. */
4526 /* Merged with some message passing. */
4530 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4531 dVAR; dSP; dMARK; dTARGET;
4532 const int op_type = PL_op->op_type;
4537 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4540 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4543 value = (I32)(do_semop(MARK, SP) >= 0);
4546 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4562 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4563 dVAR; dSP; dMARK; dTARGET;
4564 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4571 DIE(aTHX_ "System V IPC is not implemented on this machine");
4577 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4578 dVAR; dSP; dMARK; dTARGET;
4579 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4587 PUSHp(zero_but_true, ZBTLEN);
4595 /* I can't const this further without getting warnings about the types of
4596 various arrays passed in from structures. */
4598 S_space_join_names_mortal(pTHX_ char *const *array)
4602 if (array && *array) {
4603 target = sv_2mortal(newSVpvs(""));
4605 sv_catpv(target, *array);
4608 sv_catpvs(target, " ");
4611 target = sv_mortalcopy(&PL_sv_no);
4616 /* Get system info. */
4620 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4622 I32 which = PL_op->op_type;
4623 register char **elem;
4625 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4626 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4627 struct hostent *gethostbyname(Netdb_name_t);
4628 struct hostent *gethostent(void);
4630 struct hostent *hent;
4634 if (which == OP_GHBYNAME) {
4635 #ifdef HAS_GETHOSTBYNAME
4636 const char* const name = POPpbytex;
4637 hent = PerlSock_gethostbyname(name);
4639 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4642 else if (which == OP_GHBYADDR) {
4643 #ifdef HAS_GETHOSTBYADDR
4644 const int addrtype = POPi;
4645 SV * const addrsv = POPs;
4647 Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
4649 hent = PerlSock_gethostbyaddr((const char*)addr, (Netdb_hlen_t) addrlen, addrtype);
4651 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4655 #ifdef HAS_GETHOSTENT
4656 hent = PerlSock_gethostent();
4658 DIE(aTHX_ PL_no_sock_func, "gethostent");
4661 #ifdef HOST_NOT_FOUND
4663 #ifdef USE_REENTRANT_API
4664 # ifdef USE_GETHOSTENT_ERRNO
4665 h_errno = PL_reentrant_buffer->_gethostent_errno;
4668 STATUS_UNIX_SET(h_errno);
4672 if (GIMME != G_ARRAY) {
4673 PUSHs(sv = sv_newmortal());
4675 if (which == OP_GHBYNAME) {
4677 sv_setpvn(sv, hent->h_addr, hent->h_length);
4680 sv_setpv(sv, (char*)hent->h_name);
4686 PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
4687 PUSHs(space_join_names_mortal(hent->h_aliases));
4688 PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
4689 len = hent->h_length;
4690 PUSHs(sv_2mortal(newSViv((IV)len)));
4692 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4693 XPUSHs(sv_2mortal(newSVpvn(*elem, len)));
4697 PUSHs(newSVpvn(hent->h_addr, len));
4699 PUSHs(sv_mortalcopy(&PL_sv_no));
4704 DIE(aTHX_ PL_no_sock_func, "gethostent");
4710 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4712 I32 which = PL_op->op_type;
4714 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4715 struct netent *getnetbyaddr(Netdb_net_t, int);
4716 struct netent *getnetbyname(Netdb_name_t);
4717 struct netent *getnetent(void);
4719 struct netent *nent;
4721 if (which == OP_GNBYNAME){
4722 #ifdef HAS_GETNETBYNAME
4723 const char * const name = POPpbytex;
4724 nent = PerlSock_getnetbyname(name);
4726 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4729 else if (which == OP_GNBYADDR) {
4730 #ifdef HAS_GETNETBYADDR
4731 const int addrtype = POPi;
4732 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4733 nent = PerlSock_getnetbyaddr(addr, addrtype);
4735 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4739 #ifdef HAS_GETNETENT
4740 nent = PerlSock_getnetent();
4742 DIE(aTHX_ PL_no_sock_func, "getnetent");
4745 #ifdef HOST_NOT_FOUND
4747 #ifdef USE_REENTRANT_API
4748 # ifdef USE_GETNETENT_ERRNO
4749 h_errno = PL_reentrant_buffer->_getnetent_errno;
4752 STATUS_UNIX_SET(h_errno);
4757 if (GIMME != G_ARRAY) {
4758 PUSHs(sv = sv_newmortal());
4760 if (which == OP_GNBYNAME)
4761 sv_setiv(sv, (IV)nent->n_net);
4763 sv_setpv(sv, nent->n_name);
4769 PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
4770 PUSHs(space_join_names_mortal(nent->n_aliases));
4771 PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
4772 PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
4777 DIE(aTHX_ PL_no_sock_func, "getnetent");
4783 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4785 I32 which = PL_op->op_type;
4787 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4788 struct protoent *getprotobyname(Netdb_name_t);
4789 struct protoent *getprotobynumber(int);
4790 struct protoent *getprotoent(void);
4792 struct protoent *pent;
4794 if (which == OP_GPBYNAME) {
4795 #ifdef HAS_GETPROTOBYNAME
4796 const char* const name = POPpbytex;
4797 pent = PerlSock_getprotobyname(name);
4799 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4802 else if (which == OP_GPBYNUMBER) {
4803 #ifdef HAS_GETPROTOBYNUMBER
4804 const int number = POPi;
4805 pent = PerlSock_getprotobynumber(number);
4807 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4811 #ifdef HAS_GETPROTOENT
4812 pent = PerlSock_getprotoent();
4814 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4818 if (GIMME != G_ARRAY) {
4819 PUSHs(sv = sv_newmortal());
4821 if (which == OP_GPBYNAME)
4822 sv_setiv(sv, (IV)pent->p_proto);
4824 sv_setpv(sv, pent->p_name);
4830 PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
4831 PUSHs(space_join_names_mortal(pent->p_aliases));
4832 PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
4837 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4843 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4845 I32 which = PL_op->op_type;
4847 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4848 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4849 struct servent *getservbyport(int, Netdb_name_t);
4850 struct servent *getservent(void);
4852 struct servent *sent;
4854 if (which == OP_GSBYNAME) {
4855 #ifdef HAS_GETSERVBYNAME
4856 const char * const proto = POPpbytex;
4857 const char * const name = POPpbytex;
4858 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4860 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4863 else if (which == OP_GSBYPORT) {
4864 #ifdef HAS_GETSERVBYPORT
4865 const char * const proto = POPpbytex;
4866 unsigned short port = (unsigned short)POPu;
4868 port = PerlSock_htons(port);
4870 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4872 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4876 #ifdef HAS_GETSERVENT
4877 sent = PerlSock_getservent();
4879 DIE(aTHX_ PL_no_sock_func, "getservent");
4883 if (GIMME != G_ARRAY) {
4884 PUSHs(sv = sv_newmortal());
4886 if (which == OP_GSBYNAME) {
4888 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4890 sv_setiv(sv, (IV)(sent->s_port));
4894 sv_setpv(sv, sent->s_name);
4900 PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
4901 PUSHs(space_join_names_mortal(sent->s_aliases));
4903 PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
4905 PUSHs(sv_2mortal(newSViv((IV)(sent->s_port))));
4907 PUSHs(sv_2mortal(newSVpv(sent->s_proto, 0)));
4912 DIE(aTHX_ PL_no_sock_func, "getservent");
4918 #ifdef HAS_SETHOSTENT
4920 PerlSock_sethostent(TOPi);
4923 DIE(aTHX_ PL_no_sock_func, "sethostent");
4929 #ifdef HAS_SETNETENT
4931 PerlSock_setnetent(TOPi);
4934 DIE(aTHX_ PL_no_sock_func, "setnetent");
4940 #ifdef HAS_SETPROTOENT
4942 PerlSock_setprotoent(TOPi);
4945 DIE(aTHX_ PL_no_sock_func, "setprotoent");
4951 #ifdef HAS_SETSERVENT
4953 PerlSock_setservent(TOPi);
4956 DIE(aTHX_ PL_no_sock_func, "setservent");
4962 #ifdef HAS_ENDHOSTENT
4964 PerlSock_endhostent();
4968 DIE(aTHX_ PL_no_sock_func, "endhostent");
4974 #ifdef HAS_ENDNETENT
4976 PerlSock_endnetent();
4980 DIE(aTHX_ PL_no_sock_func, "endnetent");
4986 #ifdef HAS_ENDPROTOENT
4988 PerlSock_endprotoent();
4992 DIE(aTHX_ PL_no_sock_func, "endprotoent");
4998 #ifdef HAS_ENDSERVENT
5000 PerlSock_endservent();
5004 DIE(aTHX_ PL_no_sock_func, "endservent");
5012 I32 which = PL_op->op_type;
5014 struct passwd *pwent = NULL;
5016 * We currently support only the SysV getsp* shadow password interface.
5017 * The interface is declared in <shadow.h> and often one needs to link
5018 * with -lsecurity or some such.
5019 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5022 * AIX getpwnam() is clever enough to return the encrypted password
5023 * only if the caller (euid?) is root.
5025 * There are at least three other shadow password APIs. Many platforms
5026 * seem to contain more than one interface for accessing the shadow
5027 * password databases, possibly for compatibility reasons.
5028 * The getsp*() is by far he simplest one, the other two interfaces
5029 * are much more complicated, but also very similar to each other.
5034 * struct pr_passwd *getprpw*();
5035 * The password is in
5036 * char getprpw*(...).ufld.fd_encrypt[]
5037 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5042 * struct es_passwd *getespw*();
5043 * The password is in
5044 * char *(getespw*(...).ufld.fd_encrypt)
5045 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5048 * struct userpw *getuserpw();
5049 * The password is in
5050 * char *(getuserpw(...)).spw_upw_passwd
5051 * (but the de facto standard getpwnam() should work okay)
5053 * Mention I_PROT here so that Configure probes for it.
5055 * In HP-UX for getprpw*() the manual page claims that one should include
5056 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5057 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5058 * and pp_sys.c already includes <shadow.h> if there is such.
5060 * Note that <sys/security.h> is already probed for, but currently
5061 * it is only included in special cases.
5063 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5064 * be preferred interface, even though also the getprpw*() interface
5065 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5066 * One also needs to call set_auth_parameters() in main() before
5067 * doing anything else, whether one is using getespw*() or getprpw*().
5069 * Note that accessing the shadow databases can be magnitudes
5070 * slower than accessing the standard databases.
5075 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5076 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5077 * the pw_comment is left uninitialized. */
5078 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5084 const char* const name = POPpbytex;
5085 pwent = getpwnam(name);
5091 pwent = getpwuid(uid);
5095 # ifdef HAS_GETPWENT
5097 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5098 if (pwent) pwent = getpwnam(pwent->pw_name);
5101 DIE(aTHX_ PL_no_func, "getpwent");
5107 if (GIMME != G_ARRAY) {
5108 PUSHs(sv = sv_newmortal());
5110 if (which == OP_GPWNAM)
5111 # if Uid_t_sign <= 0
5112 sv_setiv(sv, (IV)pwent->pw_uid);
5114 sv_setuv(sv, (UV)pwent->pw_uid);
5117 sv_setpv(sv, pwent->pw_name);
5123 PUSHs(sv_2mortal(newSVpv(pwent->pw_name, 0)));
5125 PUSHs(sv = sv_2mortal(newSViv(0)));
5126 /* If we have getspnam(), we try to dig up the shadow
5127 * password. If we are underprivileged, the shadow
5128 * interface will set the errno to EACCES or similar,
5129 * and return a null pointer. If this happens, we will
5130 * use the dummy password (usually "*" or "x") from the
5131 * standard password database.
5133 * In theory we could skip the shadow call completely
5134 * if euid != 0 but in practice we cannot know which
5135 * security measures are guarding the shadow databases
5136 * on a random platform.
5138 * Resist the urge to use additional shadow interfaces.
5139 * Divert the urge to writing an extension instead.
5142 /* Some AIX setups falsely(?) detect some getspnam(), which
5143 * has a different API than the Solaris/IRIX one. */
5144 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5146 const int saverrno = errno;
5147 const struct spwd * const spwent = getspnam(pwent->pw_name);
5148 /* Save and restore errno so that
5149 * underprivileged attempts seem
5150 * to have never made the unsccessful
5151 * attempt to retrieve the shadow password. */
5153 if (spwent && spwent->sp_pwdp)
5154 sv_setpv(sv, spwent->sp_pwdp);
5158 if (!SvPOK(sv)) /* Use the standard password, then. */
5159 sv_setpv(sv, pwent->pw_passwd);
5162 # ifndef INCOMPLETE_TAINTS
5163 /* passwd is tainted because user himself can diddle with it.
5164 * admittedly not much and in a very limited way, but nevertheless. */
5168 # if Uid_t_sign <= 0
5169 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_uid)));
5171 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_uid)));
5174 # if Uid_t_sign <= 0
5175 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_gid)));
5177 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_gid)));
5179 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5180 * because of the poor interface of the Perl getpw*(),
5181 * not because there's some standard/convention saying so.
5182 * A better interface would have been to return a hash,
5183 * but we are accursed by our history, alas. --jhi. */
5185 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_change)));
5188 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_quota)));
5191 PUSHs(sv_2mortal(newSVpv(pwent->pw_age, 0)));
5193 /* I think that you can never get this compiled, but just in case. */
5194 PUSHs(sv_mortalcopy(&PL_sv_no));
5199 /* pw_class and pw_comment are mutually exclusive--.
5200 * see the above note for pw_change, pw_quota, and pw_age. */
5202 PUSHs(sv_2mortal(newSVpv(pwent->pw_class, 0)));
5205 PUSHs(sv_2mortal(newSVpv(pwent->pw_comment, 0)));
5207 /* I think that you can never get this compiled, but just in case. */
5208 PUSHs(sv_mortalcopy(&PL_sv_no));
5213 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5215 PUSHs(sv_mortalcopy(&PL_sv_no));
5217 # ifndef INCOMPLETE_TAINTS
5218 /* pw_gecos is tainted because user himself can diddle with it. */
5222 PUSHs(sv_2mortal(newSVpv(pwent->pw_dir, 0)));
5224 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5225 # ifndef INCOMPLETE_TAINTS
5226 /* pw_shell is tainted because user himself can diddle with it. */
5231 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_expire)));
5236 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5242 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5247 DIE(aTHX_ PL_no_func, "setpwent");
5253 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5258 DIE(aTHX_ PL_no_func, "endpwent");
5266 const I32 which = PL_op->op_type;
5267 const struct group *grent;
5269 if (which == OP_GGRNAM) {
5270 const char* const name = POPpbytex;
5271 grent = (const struct group *)getgrnam(name);
5273 else if (which == OP_GGRGID) {
5274 const Gid_t gid = POPi;
5275 grent = (const struct group *)getgrgid(gid);
5279 grent = (struct group *)getgrent();
5281 DIE(aTHX_ PL_no_func, "getgrent");
5285 if (GIMME != G_ARRAY) {
5286 SV * const sv = sv_newmortal();
5290 if (which == OP_GGRNAM)
5291 sv_setiv(sv, (IV)grent->gr_gid);
5293 sv_setpv(sv, grent->gr_name);
5299 PUSHs(sv_2mortal(newSVpv(grent->gr_name, 0)));
5302 PUSHs(sv_2mortal(newSVpv(grent->gr_passwd, 0)));
5304 PUSHs(sv_mortalcopy(&PL_sv_no));
5307 PUSHs(sv_2mortal(newSViv((IV)grent->gr_gid)));
5309 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5310 /* In UNICOS/mk (_CRAYMPP) the multithreading
5311 * versions (getgrnam_r, getgrgid_r)
5312 * seem to return an illegal pointer
5313 * as the group members list, gr_mem.
5314 * getgrent() doesn't even have a _r version
5315 * but the gr_mem is poisonous anyway.
5316 * So yes, you cannot get the list of group
5317 * members if building multithreaded in UNICOS/mk. */
5318 PUSHs(space_join_names_mortal(grent->gr_mem));
5324 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5330 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5335 DIE(aTHX_ PL_no_func, "setgrent");
5341 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5346 DIE(aTHX_ PL_no_func, "endgrent");
5356 if (!(tmps = PerlProc_getlogin()))
5358 PUSHp(tmps, strlen(tmps));
5361 DIE(aTHX_ PL_no_func, "getlogin");
5365 /* Miscellaneous. */
5370 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5371 register I32 items = SP - MARK;
5372 unsigned long a[20];
5377 while (++MARK <= SP) {
5378 if (SvTAINTED(*MARK)) {
5384 TAINT_PROPER("syscall");
5387 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5388 * or where sizeof(long) != sizeof(char*). But such machines will
5389 * not likely have syscall implemented either, so who cares?
5391 while (++MARK <= SP) {
5392 if (SvNIOK(*MARK) || !i)
5393 a[i++] = SvIV(*MARK);
5394 else if (*MARK == &PL_sv_undef)
5397 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5403 DIE(aTHX_ "Too many args to syscall");
5405 DIE(aTHX_ "Too few args to syscall");
5407 retval = syscall(a[0]);
5410 retval = syscall(a[0],a[1]);
5413 retval = syscall(a[0],a[1],a[2]);
5416 retval = syscall(a[0],a[1],a[2],a[3]);
5419 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5422 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5425 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5428 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5432 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5435 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5438 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5442 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5446 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5450 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5451 a[10],a[11],a[12],a[13]);
5453 #endif /* atarist */
5459 DIE(aTHX_ PL_no_func, "syscall");
5463 #ifdef FCNTL_EMULATE_FLOCK
5465 /* XXX Emulate flock() with fcntl().
5466 What's really needed is a good file locking module.
5470 fcntl_emulate_flock(int fd, int operation)
5474 switch (operation & ~LOCK_NB) {
5476 flock.l_type = F_RDLCK;
5479 flock.l_type = F_WRLCK;
5482 flock.l_type = F_UNLCK;
5488 flock.l_whence = SEEK_SET;
5489 flock.l_start = flock.l_len = (Off_t)0;
5491 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5494 #endif /* FCNTL_EMULATE_FLOCK */
5496 #ifdef LOCKF_EMULATE_FLOCK
5498 /* XXX Emulate flock() with lockf(). This is just to increase
5499 portability of scripts. The calls are not completely
5500 interchangeable. What's really needed is a good file
5504 /* The lockf() constants might have been defined in <unistd.h>.
5505 Unfortunately, <unistd.h> causes troubles on some mixed
5506 (BSD/POSIX) systems, such as SunOS 4.1.3.
5508 Further, the lockf() constants aren't POSIX, so they might not be
5509 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5510 just stick in the SVID values and be done with it. Sigh.
5514 # define F_ULOCK 0 /* Unlock a previously locked region */
5517 # define F_LOCK 1 /* Lock a region for exclusive use */
5520 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5523 # define F_TEST 3 /* Test a region for other processes locks */
5527 lockf_emulate_flock(int fd, int operation)
5530 const int save_errno = errno;
5533 /* flock locks entire file so for lockf we need to do the same */
5534 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5535 if (pos > 0) /* is seekable and needs to be repositioned */
5536 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5537 pos = -1; /* seek failed, so don't seek back afterwards */
5540 switch (operation) {
5542 /* LOCK_SH - get a shared lock */
5544 /* LOCK_EX - get an exclusive lock */
5546 i = lockf (fd, F_LOCK, 0);
5549 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5550 case LOCK_SH|LOCK_NB:
5551 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5552 case LOCK_EX|LOCK_NB:
5553 i = lockf (fd, F_TLOCK, 0);
5555 if ((errno == EAGAIN) || (errno == EACCES))
5556 errno = EWOULDBLOCK;
5559 /* LOCK_UN - unlock (non-blocking is a no-op) */
5561 case LOCK_UN|LOCK_NB:
5562 i = lockf (fd, F_ULOCK, 0);
5565 /* Default - can't decipher operation */
5572 if (pos > 0) /* need to restore position of the handle */
5573 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5578 #endif /* LOCKF_EMULATE_FLOCK */
5582 * c-indentation-style: bsd
5584 * indent-tabs-mode: t
5587 * ex: set ts=8 sts=4 sw=4 noet: