3 * Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 * 2004, 2005, 2006, 2007 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) (S_emulate_eaccess(aTHX_ (p), (f)))
307 const char * const tmps = POPpconstx;
308 const I32 gimme = GIMME_V;
309 const char *mode = "r";
312 if (PL_op->op_private & OPpOPEN_IN_RAW)
314 else if (PL_op->op_private & OPpOPEN_IN_CRLF)
316 fp = PerlProc_popen(tmps, mode);
318 const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
320 PerlIO_apply_layers(aTHX_ fp,mode,type);
322 if (gimme == G_VOID) {
324 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
327 else if (gimme == G_SCALAR) {
330 PL_rs = &PL_sv_undef;
331 sv_setpvn(TARG, "", 0); /* note that this preserves previous buffer */
332 while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
340 SV * const sv = newSV(79);
341 if (sv_gets(sv, fp, 0) == NULL) {
345 XPUSHs(sv_2mortal(sv));
346 if (SvLEN(sv) - SvCUR(sv) > 20) {
347 SvPV_shrink_to_cur(sv);
352 STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
353 TAINT; /* "I believe that this is not gratuitous!" */
356 STATUS_NATIVE_CHILD_SET(-1);
357 if (gimme == G_SCALAR)
368 tryAMAGICunTARGET(iter, -1);
370 /* Note that we only ever get here if File::Glob fails to load
371 * without at the same time croaking, for some reason, or if
372 * perl was built with PERL_EXTERNAL_GLOB */
379 * The external globbing program may use things we can't control,
380 * so for security reasons we must assume the worst.
383 taint_proper(PL_no_security, "glob");
387 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
388 PL_last_in_gv = (GV*)*PL_stack_sp--;
390 SAVESPTR(PL_rs); /* This is not permanent, either. */
391 PL_rs = sv_2mortal(newSVpvs("\000"));
394 *SvPVX(PL_rs) = '\n';
398 result = do_readline();
406 PL_last_in_gv = cGVOP_gv;
407 return do_readline();
418 do_join(TARG, &PL_sv_no, MARK, SP);
422 else if (SP == MARK) {
430 tmps = SvPV_const(tmpsv, len);
431 if ((!tmps || !len) && PL_errgv) {
432 SV * const error = ERRSV;
433 SvUPGRADE(error, SVt_PV);
434 if (SvPOK(error) && SvCUR(error))
435 sv_catpvs(error, "\t...caught");
437 tmps = SvPV_const(tmpsv, len);
440 tmpsv = sv_2mortal(newSVpvs("Warning: something's wrong"));
442 Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv));
454 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
456 if (SP - MARK != 1) {
458 do_join(TARG, &PL_sv_no, MARK, SP);
460 tmps = SvPV_const(tmpsv, len);
466 tmps = SvROK(tmpsv) ? (const char *)NULL : SvPV_const(tmpsv, len);
469 SV * const error = ERRSV;
470 SvUPGRADE(error, SVt_PV);
471 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
473 SvSetSV(error,tmpsv);
474 else if (sv_isobject(error)) {
475 HV * const stash = SvSTASH(SvRV(error));
476 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
478 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
479 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
486 call_sv((SV*)GvCV(gv),
487 G_SCALAR|G_EVAL|G_KEEPERR);
488 sv_setsv(error,*PL_stack_sp--);
494 if (SvPOK(error) && SvCUR(error))
495 sv_catpvs(error, "\t...propagated");
498 tmps = SvPV_const(tmpsv, len);
504 tmpsv = sv_2mortal(newSVpvs("Died"));
506 DIE(aTHX_ "%"SVf, SVfARG(tmpsv));
522 GV * const gv = (GV *)*++MARK;
525 DIE(aTHX_ PL_no_usym, "filehandle");
527 if ((io = GvIOp(gv))) {
529 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
531 if (IoDIRP(io) && ckWARN2(WARN_IO, WARN_DEPRECATED))
532 Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
533 "Opening dirhandle %s also as a file", GvENAME(gv));
535 mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
537 /* Method's args are same as ours ... */
538 /* ... except handle is replaced by the object */
539 *MARK-- = SvTIED_obj((SV*)io, mg);
543 call_method("OPEN", G_SCALAR);
557 tmps = SvPV_const(sv, len);
558 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
561 PUSHi( (I32)PL_forkprocess );
562 else if (PL_forkprocess == 0) /* we are a new child */
572 GV * const gv = (MAXARG == 0) ? PL_defoutgv : (GV*)POPs;
575 IO * const io = GvIO(gv);
577 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
580 XPUSHs(SvTIED_obj((SV*)io, mg));
583 call_method("CLOSE", G_SCALAR);
591 PUSHs(boolSV(do_close(gv, TRUE)));
604 GV * const wgv = (GV*)POPs;
605 GV * const rgv = (GV*)POPs;
610 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
611 DIE(aTHX_ PL_no_usym, "filehandle");
616 do_close(rgv, FALSE);
618 do_close(wgv, FALSE);
620 if (PerlProc_pipe(fd) < 0)
623 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
624 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
625 IoOFP(rstio) = IoIFP(rstio);
626 IoIFP(wstio) = IoOFP(wstio);
627 IoTYPE(rstio) = IoTYPE_RDONLY;
628 IoTYPE(wstio) = IoTYPE_WRONLY;
630 if (!IoIFP(rstio) || !IoOFP(wstio)) {
632 PerlIO_close(IoIFP(rstio));
634 PerlLIO_close(fd[0]);
636 PerlIO_close(IoOFP(wstio));
638 PerlLIO_close(fd[1]);
641 #if defined(HAS_FCNTL) && defined(F_SETFD)
642 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
643 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
650 DIE(aTHX_ PL_no_func, "pipe");
666 if (gv && (io = GvIO(gv))
667 && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
670 XPUSHs(SvTIED_obj((SV*)io, mg));
673 call_method("FILENO", G_SCALAR);
679 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
680 /* Can't do this because people seem to do things like
681 defined(fileno($foo)) to check whether $foo is a valid fh.
682 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
683 report_evil_fh(gv, io, PL_op->op_type);
688 PUSHi(PerlIO_fileno(fp));
701 anum = PerlLIO_umask(022);
702 /* setting it to 022 between the two calls to umask avoids
703 * to have a window where the umask is set to 0 -- meaning
704 * that another thread could create world-writeable files. */
706 (void)PerlLIO_umask(anum);
709 anum = PerlLIO_umask(POPi);
710 TAINT_PROPER("umask");
713 /* Only DIE if trying to restrict permissions on "user" (self).
714 * Otherwise it's harmless and more useful to just return undef
715 * since 'group' and 'other' concepts probably don't exist here. */
716 if (MAXARG >= 1 && (POPi & 0700))
717 DIE(aTHX_ "umask not implemented");
718 XPUSHs(&PL_sv_undef);
739 if (gv && (io = GvIO(gv))) {
740 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
743 XPUSHs(SvTIED_obj((SV*)io, mg));
748 call_method("BINMODE", G_SCALAR);
756 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
757 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
758 report_evil_fh(gv, io, PL_op->op_type);
759 SETERRNO(EBADF,RMS_IFI);
765 const int mode = mode_from_discipline(discp);
766 const char *const d = (discp ? SvPV_nolen_const(discp) : NULL);
767 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
768 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
769 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
790 const I32 markoff = MARK - PL_stack_base;
791 const char *methname;
792 int how = PERL_MAGIC_tied;
796 switch(SvTYPE(varsv)) {
798 methname = "TIEHASH";
799 HvEITER_set((HV *)varsv, 0);
802 methname = "TIEARRAY";
805 #ifdef GV_UNIQUE_CHECK
806 if (GvUNIQUE((GV*)varsv)) {
807 Perl_croak(aTHX_ "Attempt to tie unique GV");
810 methname = "TIEHANDLE";
811 how = PERL_MAGIC_tiedscalar;
812 /* For tied filehandles, we apply tiedscalar magic to the IO
813 slot of the GP rather than the GV itself. AMS 20010812 */
815 GvIOp(varsv) = newIO();
816 varsv = (SV *)GvIOp(varsv);
819 methname = "TIESCALAR";
820 how = PERL_MAGIC_tiedscalar;
824 if (sv_isobject(*MARK)) {
826 PUSHSTACKi(PERLSI_MAGIC);
828 EXTEND(SP,(I32)items);
832 call_method(methname, G_SCALAR);
835 /* Not clear why we don't call call_method here too.
836 * perhaps to get different error message ?
838 stash = gv_stashsv(*MARK, 0);
839 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
840 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
841 methname, SVfARG(*MARK));
844 PUSHSTACKi(PERLSI_MAGIC);
846 EXTEND(SP,(I32)items);
850 call_sv((SV*)GvCV(gv), G_SCALAR);
856 if (sv_isobject(sv)) {
857 sv_unmagic(varsv, how);
858 /* Croak if a self-tie on an aggregate is attempted. */
859 if (varsv == SvRV(sv) &&
860 (SvTYPE(varsv) == SVt_PVAV ||
861 SvTYPE(varsv) == SVt_PVHV))
863 "Self-ties of arrays and hashes are not supported");
864 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
867 SP = PL_stack_base + markoff;
877 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
878 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
880 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
883 if ((mg = SvTIED_mg(sv, how))) {
884 SV * const obj = SvRV(SvTIED_obj(sv, mg));
886 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
888 if (gv && isGV(gv) && (cv = GvCV(gv))) {
890 XPUSHs(SvTIED_obj((SV*)gv, mg));
891 XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
894 call_sv((SV *)cv, G_VOID);
898 else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) {
899 Perl_warner(aTHX_ packWARN(WARN_UNTIE),
900 "untie attempted while %"UVuf" inner references still exist",
901 (UV)SvREFCNT(obj) - 1 ) ;
905 sv_unmagic(sv, how) ;
915 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
916 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
918 if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv)))
921 if ((mg = SvTIED_mg(sv, how))) {
922 SV *osv = SvTIED_obj(sv, mg);
923 if (osv == mg->mg_obj)
924 osv = sv_mortalcopy(osv);
938 HV * const hv = (HV*)POPs;
939 SV * const sv = sv_2mortal(newSVpvs("AnyDBM_File"));
940 stash = gv_stashsv(sv, 0);
941 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
943 require_pv("AnyDBM_File.pm");
945 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
946 DIE(aTHX_ "No dbm on this machine");
956 PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
958 PUSHs(sv_2mortal(newSVuv(O_RDWR)));
961 call_sv((SV*)GvCV(gv), G_SCALAR);
964 if (!sv_isobject(TOPs)) {
969 PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
972 call_sv((SV*)GvCV(gv), G_SCALAR);
976 if (sv_isobject(TOPs)) {
977 sv_unmagic((SV *) hv, PERL_MAGIC_tied);
978 sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, NULL, 0);
995 struct timeval timebuf;
996 struct timeval *tbuf = &timebuf;
999 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1004 # if BYTEORDER & 0xf0000
1005 # define ORDERBYTE (0x88888888 - BYTEORDER)
1007 # define ORDERBYTE (0x4444 - BYTEORDER)
1013 for (i = 1; i <= 3; i++) {
1014 SV * const sv = SP[i];
1017 if (SvREADONLY(sv)) {
1019 sv_force_normal_flags(sv, 0);
1020 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
1021 DIE(aTHX_ PL_no_modify);
1024 if (ckWARN(WARN_MISC))
1025 Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
1026 SvPV_force_nolen(sv); /* force string conversion */
1033 /* little endians can use vecs directly */
1034 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1041 masksize = NFDBITS / NBBY;
1043 masksize = sizeof(long); /* documented int, everyone seems to use long */
1045 Zero(&fd_sets[0], 4, char*);
1048 # if SELECT_MIN_BITS == 1
1049 growsize = sizeof(fd_set);
1051 # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1052 # undef SELECT_MIN_BITS
1053 # define SELECT_MIN_BITS __FD_SETSIZE
1055 /* If SELECT_MIN_BITS is greater than one we most probably will want
1056 * to align the sizes with SELECT_MIN_BITS/8 because for example
1057 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1058 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1059 * on (sets/tests/clears bits) is 32 bits. */
1060 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1068 timebuf.tv_sec = (long)value;
1069 value -= (NV)timebuf.tv_sec;
1070 timebuf.tv_usec = (long)(value * 1000000.0);
1075 for (i = 1; i <= 3; i++) {
1077 if (!SvOK(sv) || SvCUR(sv) == 0) {
1084 Sv_Grow(sv, growsize);
1088 while (++j <= growsize) {
1092 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1094 Newx(fd_sets[i], growsize, char);
1095 for (offset = 0; offset < growsize; offset += masksize) {
1096 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1097 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1100 fd_sets[i] = SvPVX(sv);
1104 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1105 /* Can't make just the (void*) conditional because that would be
1106 * cpp #if within cpp macro, and not all compilers like that. */
1107 nfound = PerlSock_select(
1109 (Select_fd_set_t) fd_sets[1],
1110 (Select_fd_set_t) fd_sets[2],
1111 (Select_fd_set_t) fd_sets[3],
1112 (void*) tbuf); /* Workaround for compiler bug. */
1114 nfound = PerlSock_select(
1116 (Select_fd_set_t) fd_sets[1],
1117 (Select_fd_set_t) fd_sets[2],
1118 (Select_fd_set_t) fd_sets[3],
1121 for (i = 1; i <= 3; i++) {
1124 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1126 for (offset = 0; offset < growsize; offset += masksize) {
1127 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1128 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1130 Safefree(fd_sets[i]);
1137 if (GIMME == G_ARRAY && tbuf) {
1138 value = (NV)(timebuf.tv_sec) +
1139 (NV)(timebuf.tv_usec) / 1000000.0;
1140 PUSHs(sv_2mortal(newSVnv(value)));
1144 DIE(aTHX_ "select not implemented");
1149 Perl_setdefout(pTHX_ GV *gv)
1152 SvREFCNT_inc_simple_void(gv);
1154 SvREFCNT_dec(PL_defoutgv);
1162 GV * const newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : NULL;
1163 GV * egv = GvEGV(PL_defoutgv);
1169 XPUSHs(&PL_sv_undef);
1171 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
1172 if (gvp && *gvp == egv) {
1173 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1177 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1182 if (!GvIO(newdefout))
1183 gv_IOadd(newdefout);
1184 setdefout(newdefout);
1194 GV * const gv = (MAXARG==0) ? PL_stdingv : (GV*)POPs;
1196 if (gv && (io = GvIO(gv))) {
1197 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1199 const I32 gimme = GIMME_V;
1201 XPUSHs(SvTIED_obj((SV*)io, mg));
1204 call_method("GETC", gimme);
1207 if (gimme == G_SCALAR)
1208 SvSetMagicSV_nosteal(TARG, TOPs);
1212 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1213 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1214 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1215 report_evil_fh(gv, io, PL_op->op_type);
1216 SETERRNO(EBADF,RMS_IFI);
1220 sv_setpvn(TARG, " ", 1);
1221 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1222 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1223 /* Find out how many bytes the char needs */
1224 Size_t len = UTF8SKIP(SvPVX_const(TARG));
1227 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1228 SvCUR_set(TARG,1+len);
1237 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1240 register PERL_CONTEXT *cx;
1241 const I32 gimme = GIMME_V;
1246 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1248 cx->blk_sub.retop = retop;
1250 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1252 setdefout(gv); /* locally select filehandle so $% et al work */
1284 goto not_a_format_reference;
1289 tmpsv = sv_newmortal();
1290 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1291 name = SvPV_nolen_const(tmpsv);
1293 DIE(aTHX_ "Undefined format \"%s\" called", name);
1295 not_a_format_reference:
1296 DIE(aTHX_ "Not a format reference");
1299 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1301 IoFLAGS(io) &= ~IOf_DIDTOP;
1302 return doform(cv,gv,PL_op->op_next);
1308 GV * const gv = cxstack[cxstack_ix].blk_sub.gv;
1309 register IO * const io = GvIOp(gv);
1314 register PERL_CONTEXT *cx;
1316 if (!io || !(ofp = IoOFP(io)))
1319 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1320 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1322 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1323 PL_formtarget != PL_toptarget)
1327 if (!IoTOP_GV(io)) {
1330 if (!IoTOP_NAME(io)) {
1332 if (!IoFMT_NAME(io))
1333 IoFMT_NAME(io) = savepv(GvNAME(gv));
1334 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
1335 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1336 if ((topgv && GvFORM(topgv)) ||
1337 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1338 IoTOP_NAME(io) = savesvpv(topname);
1340 IoTOP_NAME(io) = savepvs("top");
1342 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1343 if (!topgv || !GvFORM(topgv)) {
1344 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1347 IoTOP_GV(io) = topgv;
1349 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1350 I32 lines = IoLINES_LEFT(io);
1351 const char *s = SvPVX_const(PL_formtarget);
1352 if (lines <= 0) /* Yow, header didn't even fit!!! */
1354 while (lines-- > 0) {
1355 s = strchr(s, '\n');
1361 const STRLEN save = SvCUR(PL_formtarget);
1362 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1363 do_print(PL_formtarget, ofp);
1364 SvCUR_set(PL_formtarget, save);
1365 sv_chop(PL_formtarget, s);
1366 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1369 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1370 do_print(PL_formfeed, ofp);
1371 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1373 PL_formtarget = PL_toptarget;
1374 IoFLAGS(io) |= IOf_DIDTOP;
1377 DIE(aTHX_ "bad top format reference");
1380 SV * const sv = sv_newmortal();
1382 gv_efullname4(sv, fgv, NULL, FALSE);
1383 name = SvPV_nolen_const(sv);
1385 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1387 DIE(aTHX_ "Undefined top format called");
1389 if (cv && CvCLONE(cv))
1390 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1391 return doform(cv, gv, PL_op);
1395 POPBLOCK(cx,PL_curpm);
1401 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1403 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1404 else if (ckWARN(WARN_CLOSED))
1405 report_evil_fh(gv, io, PL_op->op_type);
1410 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1411 if (ckWARN(WARN_IO))
1412 Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1414 if (!do_print(PL_formtarget, fp))
1417 FmLINES(PL_formtarget) = 0;
1418 SvCUR_set(PL_formtarget, 0);
1419 *SvEND(PL_formtarget) = '\0';
1420 if (IoFLAGS(io) & IOf_FLUSH)
1421 (void)PerlIO_flush(fp);
1426 PL_formtarget = PL_bodytarget;
1428 PERL_UNUSED_VAR(newsp);
1429 PERL_UNUSED_VAR(gimme);
1430 return cx->blk_sub.retop;
1435 dVAR; dSP; dMARK; dORIGMARK;
1440 GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
1442 if (gv && (io = GvIO(gv))) {
1443 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1445 if (MARK == ORIGMARK) {
1448 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1452 *MARK = SvTIED_obj((SV*)io, mg);
1455 call_method("PRINTF", G_SCALAR);
1458 MARK = ORIGMARK + 1;
1466 if (!(io = GvIO(gv))) {
1467 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1468 report_evil_fh(gv, io, PL_op->op_type);
1469 SETERRNO(EBADF,RMS_IFI);
1472 else if (!(fp = IoOFP(io))) {
1473 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
1475 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1476 else if (ckWARN(WARN_CLOSED))
1477 report_evil_fh(gv, io, PL_op->op_type);
1479 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1483 if (SvTAINTED(MARK[1]))
1484 TAINT_PROPER("printf");
1485 do_sprintf(sv, SP - MARK, MARK + 1);
1486 if (!do_print(sv, fp))
1489 if (IoFLAGS(io) & IOf_FLUSH)
1490 if (PerlIO_flush(fp) == EOF)
1501 PUSHs(&PL_sv_undef);
1509 const int perm = (MAXARG > 3) ? POPi : 0666;
1510 const int mode = POPi;
1511 SV * const sv = POPs;
1512 GV * const gv = (GV *)POPs;
1515 /* Need TIEHANDLE method ? */
1516 const char * const tmps = SvPV_const(sv, len);
1517 /* FIXME? do_open should do const */
1518 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1519 IoLINES(GvIOp(gv)) = 0;
1523 PUSHs(&PL_sv_undef);
1530 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1536 Sock_size_t bufsize;
1544 bool charstart = FALSE;
1545 STRLEN charskip = 0;
1548 GV * const gv = (GV*)*++MARK;
1549 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1550 && gv && (io = GvIO(gv)) )
1552 const MAGIC * mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1556 *MARK = SvTIED_obj((SV*)io, mg);
1558 call_method("READ", G_SCALAR);
1572 sv_setpvn(bufsv, "", 0);
1573 length = SvIVx(*++MARK);
1576 offset = SvIVx(*++MARK);
1580 if (!io || !IoIFP(io)) {
1581 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1582 report_evil_fh(gv, io, PL_op->op_type);
1583 SETERRNO(EBADF,RMS_IFI);
1586 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1587 buffer = SvPVutf8_force(bufsv, blen);
1588 /* UTF-8 may not have been set if they are all low bytes */
1593 buffer = SvPV_force(bufsv, blen);
1594 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1597 DIE(aTHX_ "Negative length");
1605 if (PL_op->op_type == OP_RECV) {
1606 char namebuf[MAXPATHLEN];
1607 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1608 bufsize = sizeof (struct sockaddr_in);
1610 bufsize = sizeof namebuf;
1612 #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1616 buffer = SvGROW(bufsv, (STRLEN)(length+1));
1617 /* 'offset' means 'flags' here */
1618 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1619 (struct sockaddr *)namebuf, &bufsize);
1623 /* Bogus return without padding */
1624 bufsize = sizeof (struct sockaddr_in);
1626 SvCUR_set(bufsv, count);
1627 *SvEND(bufsv) = '\0';
1628 (void)SvPOK_only(bufsv);
1632 /* This should not be marked tainted if the fp is marked clean */
1633 if (!(IoFLAGS(io) & IOf_UNTAINT))
1634 SvTAINTED_on(bufsv);
1636 sv_setpvn(TARG, namebuf, bufsize);
1641 if (PL_op->op_type == OP_RECV)
1642 DIE(aTHX_ PL_no_sock_func, "recv");
1644 if (DO_UTF8(bufsv)) {
1645 /* offset adjust in characters not bytes */
1646 blen = sv_len_utf8(bufsv);
1649 if (-offset > (int)blen)
1650 DIE(aTHX_ "Offset outside string");
1653 if (DO_UTF8(bufsv)) {
1654 /* convert offset-as-chars to offset-as-bytes */
1655 if (offset >= (int)blen)
1656 offset += SvCUR(bufsv) - blen;
1658 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1661 bufsize = SvCUR(bufsv);
1662 /* Allocating length + offset + 1 isn't perfect in the case of reading
1663 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1665 (should be 2 * length + offset + 1, or possibly something longer if
1666 PL_encoding is true) */
1667 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
1668 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1669 Zero(buffer+bufsize, offset-bufsize, char);
1671 buffer = buffer + offset;
1673 read_target = bufsv;
1675 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1676 concatenate it to the current buffer. */
1678 /* Truncate the existing buffer to the start of where we will be
1680 SvCUR_set(bufsv, offset);
1682 read_target = sv_newmortal();
1683 SvUPGRADE(read_target, SVt_PV);
1684 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1687 if (PL_op->op_type == OP_SYSREAD) {
1688 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1689 if (IoTYPE(io) == IoTYPE_SOCKET) {
1690 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1696 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1701 #ifdef HAS_SOCKET__bad_code_maybe
1702 if (IoTYPE(io) == IoTYPE_SOCKET) {
1703 char namebuf[MAXPATHLEN];
1704 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1705 bufsize = sizeof (struct sockaddr_in);
1707 bufsize = sizeof namebuf;
1709 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1710 (struct sockaddr *)namebuf, &bufsize);
1715 count = PerlIO_read(IoIFP(io), buffer, length);
1716 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1717 if (count == 0 && PerlIO_error(IoIFP(io)))
1721 if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1722 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1725 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1726 *SvEND(read_target) = '\0';
1727 (void)SvPOK_only(read_target);
1728 if (fp_utf8 && !IN_BYTES) {
1729 /* Look at utf8 we got back and count the characters */
1730 const char *bend = buffer + count;
1731 while (buffer < bend) {
1733 skip = UTF8SKIP(buffer);
1736 if (buffer - charskip + skip > bend) {
1737 /* partial character - try for rest of it */
1738 length = skip - (bend-buffer);
1739 offset = bend - SvPVX_const(bufsv);
1751 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1752 provided amount read (count) was what was requested (length)
1754 if (got < wanted && count == length) {
1755 length = wanted - got;
1756 offset = bend - SvPVX_const(bufsv);
1759 /* return value is character count */
1763 else if (buffer_utf8) {
1764 /* Let svcatsv upgrade the bytes we read in to utf8.
1765 The buffer is a mortal so will be freed soon. */
1766 sv_catsv_nomg(bufsv, read_target);
1769 /* This should not be marked tainted if the fp is marked clean */
1770 if (!(IoFLAGS(io) & IOf_UNTAINT))
1771 SvTAINTED_on(bufsv);
1783 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1789 STRLEN orig_blen_bytes;
1790 const int op_type = PL_op->op_type;
1794 GV *const gv = (GV*)*++MARK;
1795 if (PL_op->op_type == OP_SYSWRITE
1796 && gv && (io = GvIO(gv))) {
1797 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1801 if (MARK == SP - 1) {
1803 sv = sv_2mortal(newSViv(sv_len(*SP)));
1809 *(ORIGMARK+1) = SvTIED_obj((SV*)io, mg);
1811 call_method("WRITE", G_SCALAR);
1827 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1829 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1830 if (io && IoIFP(io))
1831 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1833 report_evil_fh(gv, io, PL_op->op_type);
1835 SETERRNO(EBADF,RMS_IFI);
1839 /* Do this first to trigger any overloading. */
1840 buffer = SvPV_const(bufsv, blen);
1841 orig_blen_bytes = blen;
1842 doing_utf8 = DO_UTF8(bufsv);
1844 if (PerlIO_isutf8(IoIFP(io))) {
1845 if (!SvUTF8(bufsv)) {
1846 /* We don't modify the original scalar. */
1847 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1848 buffer = (char *) tmpbuf;
1852 else if (doing_utf8) {
1853 STRLEN tmplen = blen;
1854 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1857 buffer = (char *) tmpbuf;
1861 assert((char *)result == buffer);
1862 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1866 if (op_type == OP_SYSWRITE) {
1867 Size_t length = 0; /* This length is in characters. */
1873 /* The SV is bytes, and we've had to upgrade it. */
1874 blen_chars = orig_blen_bytes;
1876 /* The SV really is UTF-8. */
1877 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1878 /* Don't call sv_len_utf8 again because it will call magic
1879 or overloading a second time, and we might get back a
1880 different result. */
1881 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1883 /* It's safe, and it may well be cached. */
1884 blen_chars = sv_len_utf8(bufsv);
1892 length = blen_chars;
1894 #if Size_t_size > IVSIZE
1895 length = (Size_t)SvNVx(*++MARK);
1897 length = (Size_t)SvIVx(*++MARK);
1899 if ((SSize_t)length < 0) {
1901 DIE(aTHX_ "Negative length");
1906 offset = SvIVx(*++MARK);
1908 if (-offset > (IV)blen_chars) {
1910 DIE(aTHX_ "Offset outside string");
1912 offset += blen_chars;
1913 } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1915 DIE(aTHX_ "Offset outside string");
1919 if (length > blen_chars - offset)
1920 length = blen_chars - offset;
1922 /* Here we convert length from characters to bytes. */
1923 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1924 /* Either we had to convert the SV, or the SV is magical, or
1925 the SV has overloading, in which case we can't or mustn't
1926 or mustn't call it again. */
1928 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1929 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1931 /* It's a real UTF-8 SV, and it's not going to change under
1932 us. Take advantage of any cache. */
1934 I32 len_I32 = length;
1936 /* Convert the start and end character positions to bytes.
1937 Remember that the second argument to sv_pos_u2b is relative
1939 sv_pos_u2b(bufsv, &start, &len_I32);
1946 buffer = buffer+offset;
1948 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1949 if (IoTYPE(io) == IoTYPE_SOCKET) {
1950 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1956 /* See the note at doio.c:do_print about filesize limits. --jhi */
1957 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1963 const int flags = SvIVx(*++MARK);
1966 char * const sockbuf = SvPVx(*++MARK, mlen);
1967 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1968 flags, (struct sockaddr *)sockbuf, mlen);
1972 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1977 DIE(aTHX_ PL_no_sock_func, "send");
1984 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
1987 #if Size_t_size > IVSIZE
2006 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
2008 gv = PL_last_in_gv = GvEGV(PL_argvgv);
2010 if (io && !IoIFP(io)) {
2011 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2013 IoFLAGS(io) &= ~IOf_START;
2014 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2015 sv_setpvn(GvSV(gv), "-", 1);
2016 SvSETMAGIC(GvSV(gv));
2018 else if (!nextargv(gv))
2023 gv = PL_last_in_gv; /* eof */
2026 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
2029 IO * const io = GvIO(gv);
2031 if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
2033 XPUSHs(SvTIED_obj((SV*)io, mg));
2036 call_method("EOF", G_SCALAR);
2043 PUSHs(boolSV(!gv || do_eof(gv)));
2054 PL_last_in_gv = (GV*)POPs;
2057 if (gv && (io = GvIO(gv))) {
2058 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2061 XPUSHs(SvTIED_obj((SV*)io, mg));
2064 call_method("TELL", G_SCALAR);
2071 #if LSEEKSIZE > IVSIZE
2072 PUSHn( do_tell(gv) );
2074 PUSHi( do_tell(gv) );
2082 const int whence = POPi;
2083 #if LSEEKSIZE > IVSIZE
2084 const Off_t offset = (Off_t)SvNVx(POPs);
2086 const Off_t offset = (Off_t)SvIVx(POPs);
2089 GV * const gv = PL_last_in_gv = (GV*)POPs;
2092 if (gv && (io = GvIO(gv))) {
2093 MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
2096 XPUSHs(SvTIED_obj((SV*)io, mg));
2097 #if LSEEKSIZE > IVSIZE
2098 XPUSHs(sv_2mortal(newSVnv((NV) offset)));
2100 XPUSHs(sv_2mortal(newSViv(offset)));
2102 XPUSHs(sv_2mortal(newSViv(whence)));
2105 call_method("SEEK", G_SCALAR);
2112 if (PL_op->op_type == OP_SEEK)
2113 PUSHs(boolSV(do_seek(gv, offset, whence)));
2115 const Off_t sought = do_sysseek(gv, offset, whence);
2117 PUSHs(&PL_sv_undef);
2119 SV* const sv = sought ?
2120 #if LSEEKSIZE > IVSIZE
2125 : newSVpvn(zero_but_true, ZBTLEN);
2126 PUSHs(sv_2mortal(sv));
2136 /* There seems to be no consensus on the length type of truncate()
2137 * and ftruncate(), both off_t and size_t have supporters. In
2138 * general one would think that when using large files, off_t is
2139 * at least as wide as size_t, so using an off_t should be okay. */
2140 /* XXX Configure probe for the length type of *truncate() needed XXX */
2143 #if Off_t_size > IVSIZE
2148 /* Checking for length < 0 is problematic as the type might or
2149 * might not be signed: if it is not, clever compilers will moan. */
2150 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2157 if (PL_op->op_flags & OPf_SPECIAL) {
2158 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2167 TAINT_PROPER("truncate");
2168 if (!(fp = IoIFP(io))) {
2174 if (ftruncate(PerlIO_fileno(fp), len) < 0)
2176 if (my_chsize(PerlIO_fileno(fp), len) < 0)
2183 SV * const sv = POPs;
2186 if (SvTYPE(sv) == SVt_PVGV) {
2187 tmpgv = (GV*)sv; /* *main::FRED for example */
2188 goto do_ftruncate_gv;
2190 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2191 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
2192 goto do_ftruncate_gv;
2194 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2195 io = (IO*) SvRV(sv); /* *main::FRED{IO} for example */
2196 goto do_ftruncate_io;
2199 name = SvPV_nolen_const(sv);
2200 TAINT_PROPER("truncate");
2202 if (truncate(name, len) < 0)
2206 const int tmpfd = PerlLIO_open(name, O_RDWR);
2211 if (my_chsize(tmpfd, len) < 0)
2213 PerlLIO_close(tmpfd);
2222 SETERRNO(EBADF,RMS_IFI);
2230 SV * const argsv = POPs;
2231 const unsigned int func = POPu;
2232 const int optype = PL_op->op_type;
2233 GV * const gv = (GV*)POPs;
2234 IO * const io = gv ? GvIOn(gv) : NULL;
2238 if (!io || !argsv || !IoIFP(io)) {
2239 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2240 report_evil_fh(gv, io, PL_op->op_type);
2241 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2245 if (SvPOK(argsv) || !SvNIOK(argsv)) {
2248 s = SvPV_force(argsv, len);
2249 need = IOCPARM_LEN(func);
2251 s = Sv_Grow(argsv, need + 1);
2252 SvCUR_set(argsv, need);
2255 s[SvCUR(argsv)] = 17; /* a little sanity check here */
2258 retval = SvIV(argsv);
2259 s = INT2PTR(char*,retval); /* ouch */
2262 TAINT_PROPER(PL_op_desc[optype]);
2264 if (optype == OP_IOCTL)
2266 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2268 DIE(aTHX_ "ioctl is not implemented");
2272 DIE(aTHX_ "fcntl is not implemented");
2274 #if defined(OS2) && defined(__EMX__)
2275 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2277 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2281 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2283 if (s[SvCUR(argsv)] != 17)
2284 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2286 s[SvCUR(argsv)] = 0; /* put our null back */
2287 SvSETMAGIC(argsv); /* Assume it has changed */
2296 PUSHp(zero_but_true, ZBTLEN);
2309 const int argtype = POPi;
2310 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : (GV*)POPs;
2312 if (gv && (io = GvIO(gv)))
2318 /* XXX Looks to me like io is always NULL at this point */
2320 (void)PerlIO_flush(fp);
2321 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2324 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2325 report_evil_fh(gv, io, PL_op->op_type);
2327 SETERRNO(EBADF,RMS_IFI);
2332 DIE(aTHX_ PL_no_func, "flock()");
2342 const int protocol = POPi;
2343 const int type = POPi;
2344 const int domain = POPi;
2345 GV * const gv = (GV*)POPs;
2346 register IO * const io = gv ? GvIOn(gv) : NULL;
2350 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2351 report_evil_fh(gv, io, PL_op->op_type);
2352 if (io && IoIFP(io))
2353 do_close(gv, FALSE);
2354 SETERRNO(EBADF,LIB_INVARG);
2359 do_close(gv, FALSE);
2361 TAINT_PROPER("socket");
2362 fd = PerlSock_socket(domain, type, protocol);
2365 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2366 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2367 IoTYPE(io) = IoTYPE_SOCKET;
2368 if (!IoIFP(io) || !IoOFP(io)) {
2369 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2370 if (IoOFP(io)) PerlIO_close(IoOFP(io));
2371 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2374 #if defined(HAS_FCNTL) && defined(F_SETFD)
2375 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2379 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2384 DIE(aTHX_ PL_no_sock_func, "socket");
2390 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2392 const int protocol = POPi;
2393 const int type = POPi;
2394 const int domain = POPi;
2395 GV * const gv2 = (GV*)POPs;
2396 GV * const gv1 = (GV*)POPs;
2397 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2398 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2401 if (!gv1 || !gv2 || !io1 || !io2) {
2402 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2404 report_evil_fh(gv1, io1, PL_op->op_type);
2406 report_evil_fh(gv1, io2, PL_op->op_type);
2408 if (io1 && IoIFP(io1))
2409 do_close(gv1, FALSE);
2410 if (io2 && IoIFP(io2))
2411 do_close(gv2, FALSE);
2416 do_close(gv1, FALSE);
2418 do_close(gv2, FALSE);
2420 TAINT_PROPER("socketpair");
2421 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2423 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2424 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2425 IoTYPE(io1) = IoTYPE_SOCKET;
2426 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2427 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2428 IoTYPE(io2) = IoTYPE_SOCKET;
2429 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2430 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2431 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2432 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2433 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2434 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2435 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2438 #if defined(HAS_FCNTL) && defined(F_SETFD)
2439 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2440 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2445 DIE(aTHX_ PL_no_sock_func, "socketpair");
2453 SV * const addrsv = POPs;
2454 /* OK, so on what platform does bind modify addr? */
2456 GV * const gv = (GV*)POPs;
2457 register IO * const io = GvIOn(gv);
2460 if (!io || !IoIFP(io))
2463 addr = SvPV_const(addrsv, len);
2464 TAINT_PROPER("bind");
2465 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2471 if (ckWARN(WARN_CLOSED))
2472 report_evil_fh(gv, io, PL_op->op_type);
2473 SETERRNO(EBADF,SS_IVCHAN);
2476 DIE(aTHX_ PL_no_sock_func, "bind");
2484 SV * const addrsv = POPs;
2485 GV * const gv = (GV*)POPs;
2486 register IO * const io = GvIOn(gv);
2490 if (!io || !IoIFP(io))
2493 addr = SvPV_const(addrsv, len);
2494 TAINT_PROPER("connect");
2495 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2501 if (ckWARN(WARN_CLOSED))
2502 report_evil_fh(gv, io, PL_op->op_type);
2503 SETERRNO(EBADF,SS_IVCHAN);
2506 DIE(aTHX_ PL_no_sock_func, "connect");
2514 const int backlog = POPi;
2515 GV * const gv = (GV*)POPs;
2516 register IO * const io = gv ? GvIOn(gv) : NULL;
2518 if (!gv || !io || !IoIFP(io))
2521 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2527 if (ckWARN(WARN_CLOSED))
2528 report_evil_fh(gv, io, PL_op->op_type);
2529 SETERRNO(EBADF,SS_IVCHAN);
2532 DIE(aTHX_ PL_no_sock_func, "listen");
2542 char namebuf[MAXPATHLEN];
2543 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2544 Sock_size_t len = sizeof (struct sockaddr_in);
2546 Sock_size_t len = sizeof namebuf;
2548 GV * const ggv = (GV*)POPs;
2549 GV * const ngv = (GV*)POPs;
2558 if (!gstio || !IoIFP(gstio))
2562 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2565 /* Some platforms indicate zero length when an AF_UNIX client is
2566 * not bound. Simulate a non-zero-length sockaddr structure in
2568 namebuf[0] = 0; /* sun_len */
2569 namebuf[1] = AF_UNIX; /* sun_family */
2577 do_close(ngv, FALSE);
2578 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2579 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2580 IoTYPE(nstio) = IoTYPE_SOCKET;
2581 if (!IoIFP(nstio) || !IoOFP(nstio)) {
2582 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2583 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2584 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2587 #if defined(HAS_FCNTL) && defined(F_SETFD)
2588 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2592 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2593 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2595 #ifdef __SCO_VERSION__
2596 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2599 PUSHp(namebuf, len);
2603 if (ckWARN(WARN_CLOSED))
2604 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2605 SETERRNO(EBADF,SS_IVCHAN);
2611 DIE(aTHX_ PL_no_sock_func, "accept");
2619 const int how = POPi;
2620 GV * const gv = (GV*)POPs;
2621 register IO * const io = GvIOn(gv);
2623 if (!io || !IoIFP(io))
2626 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2630 if (ckWARN(WARN_CLOSED))
2631 report_evil_fh(gv, io, PL_op->op_type);
2632 SETERRNO(EBADF,SS_IVCHAN);
2635 DIE(aTHX_ PL_no_sock_func, "shutdown");
2643 const int optype = PL_op->op_type;
2644 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2645 const unsigned int optname = (unsigned int) POPi;
2646 const unsigned int lvl = (unsigned int) POPi;
2647 GV * const gv = (GV*)POPs;
2648 register IO * const io = GvIOn(gv);
2652 if (!io || !IoIFP(io))
2655 fd = PerlIO_fileno(IoIFP(io));
2659 (void)SvPOK_only(sv);
2663 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2670 #if defined(__SYMBIAN32__)
2671 # define SETSOCKOPT_OPTION_VALUE_T void *
2673 # define SETSOCKOPT_OPTION_VALUE_T const char *
2675 /* XXX TODO: We need to have a proper type (a Configure probe,
2676 * etc.) for what the C headers think of the third argument of
2677 * setsockopt(), the option_value read-only buffer: is it
2678 * a "char *", or a "void *", const or not. Some compilers
2679 * don't take kindly to e.g. assuming that "char *" implicitly
2680 * promotes to a "void *", or to explicitly promoting/demoting
2681 * consts to non/vice versa. The "const void *" is the SUS
2682 * definition, but that does not fly everywhere for the above
2684 SETSOCKOPT_OPTION_VALUE_T buf;
2688 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2692 aint = (int)SvIV(sv);
2693 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2696 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2705 if (ckWARN(WARN_CLOSED))
2706 report_evil_fh(gv, io, optype);
2707 SETERRNO(EBADF,SS_IVCHAN);
2712 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2720 const int optype = PL_op->op_type;
2721 GV * const gv = (GV*)POPs;
2722 register IO * const io = GvIOn(gv);
2727 if (!io || !IoIFP(io))
2730 sv = sv_2mortal(newSV(257));
2731 (void)SvPOK_only(sv);
2735 fd = PerlIO_fileno(IoIFP(io));
2737 case OP_GETSOCKNAME:
2738 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2741 case OP_GETPEERNAME:
2742 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2744 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2746 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";
2747 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2748 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2749 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2750 sizeof(u_short) + sizeof(struct in_addr))) {
2757 #ifdef BOGUS_GETNAME_RETURN
2758 /* Interactive Unix, getpeername() and getsockname()
2759 does not return valid namelen */
2760 if (len == BOGUS_GETNAME_RETURN)
2761 len = sizeof(struct sockaddr);
2769 if (ckWARN(WARN_CLOSED))
2770 report_evil_fh(gv, io, optype);
2771 SETERRNO(EBADF,SS_IVCHAN);
2776 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2791 if (PL_op->op_flags & OPf_REF) {
2793 if (PL_op->op_type == OP_LSTAT) {
2794 if (gv != PL_defgv) {
2795 do_fstat_warning_check:
2796 if (ckWARN(WARN_IO))
2797 Perl_warner(aTHX_ packWARN(WARN_IO),
2798 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2799 } else if (PL_laststype != OP_LSTAT)
2800 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2804 if (gv != PL_defgv) {
2805 PL_laststype = OP_STAT;
2807 sv_setpvn(PL_statname, "", 0);
2814 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2815 } else if (IoDIRP(io)) {
2817 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2819 PL_laststatval = -1;
2825 if (PL_laststatval < 0) {
2826 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2827 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2832 SV* const sv = POPs;
2833 if (SvTYPE(sv) == SVt_PVGV) {
2836 } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2838 if (PL_op->op_type == OP_LSTAT)
2839 goto do_fstat_warning_check;
2841 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2843 if (PL_op->op_type == OP_LSTAT)
2844 goto do_fstat_warning_check;
2845 goto do_fstat_have_io;
2848 sv_setpv(PL_statname, SvPV_nolen_const(sv));
2850 PL_laststype = PL_op->op_type;
2851 if (PL_op->op_type == OP_LSTAT)
2852 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2854 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2855 if (PL_laststatval < 0) {
2856 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2857 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2863 if (gimme != G_ARRAY) {
2864 if (gimme != G_VOID)
2865 XPUSHs(boolSV(max));
2871 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2872 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2873 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2874 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
2875 #if Uid_t_size > IVSIZE
2876 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2878 # if Uid_t_sign <= 0
2879 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
2881 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2884 #if Gid_t_size > IVSIZE
2885 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2887 # if Gid_t_sign <= 0
2888 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
2890 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2893 #ifdef USE_STAT_RDEV
2894 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
2896 PUSHs(sv_2mortal(newSVpvs("")));
2898 #if Off_t_size > IVSIZE
2899 PUSHs(sv_2mortal(newSVnv((NV)PL_statcache.st_size)));
2901 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
2904 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2905 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2906 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
2908 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_atime)));
2909 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_mtime)));
2910 PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_ctime)));
2912 #ifdef USE_STAT_BLOCKS
2913 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2914 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
2916 PUSHs(sv_2mortal(newSVpvs("")));
2917 PUSHs(sv_2mortal(newSVpvs("")));
2923 /* This macro is used by the stacked filetest operators :
2924 * if the previous filetest failed, short-circuit and pass its value.
2925 * Else, discard it from the stack and continue. --rgs
2927 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2928 if (TOPs == &PL_sv_no || TOPs == &PL_sv_undef) { RETURN; } \
2929 else { (void)POPs; PUTBACK; } \
2936 /* Not const, because things tweak this below. Not bool, because there's
2937 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2938 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2939 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2940 /* Giving some sort of initial value silences compilers. */
2942 int access_mode = R_OK;
2944 int access_mode = 0;
2947 /* access_mode is never used, but leaving use_access in makes the
2948 conditional compiling below much clearer. */
2951 int stat_mode = S_IRUSR;
2953 bool effective = FALSE;
2956 STACKED_FTEST_CHECK;
2958 switch (PL_op->op_type) {
2960 #if !(defined(HAS_ACCESS) && defined(R_OK))
2966 #if defined(HAS_ACCESS) && defined(W_OK)
2971 stat_mode = S_IWUSR;
2975 #if defined(HAS_ACCESS) && defined(X_OK)
2980 stat_mode = S_IXUSR;
2984 #ifdef PERL_EFF_ACCESS
2987 stat_mode = S_IWUSR;
2991 #ifndef PERL_EFF_ACCESS
2999 #ifdef PERL_EFF_ACCESS
3004 stat_mode = S_IXUSR;
3010 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3011 const char *name = POPpx;
3013 # ifdef PERL_EFF_ACCESS
3014 result = PERL_EFF_ACCESS(name, access_mode);
3016 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3022 result = access(name, access_mode);
3024 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3039 if (cando(stat_mode, effective, &PL_statcache))
3048 const int op_type = PL_op->op_type;
3050 STACKED_FTEST_CHECK;
3055 if (op_type == OP_FTIS)
3058 /* You can't dTARGET inside OP_FTIS, because you'll get
3059 "panic: pad_sv po" - the op is not flagged to have a target. */
3063 #if Off_t_size > IVSIZE
3064 PUSHn(PL_statcache.st_size);
3066 PUSHi(PL_statcache.st_size);
3070 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3073 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3076 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3089 /* I believe that all these three are likely to be defined on most every
3090 system these days. */
3092 if(PL_op->op_type == OP_FTSUID)
3096 if(PL_op->op_type == OP_FTSGID)
3100 if(PL_op->op_type == OP_FTSVTX)
3104 STACKED_FTEST_CHECK;
3109 switch (PL_op->op_type) {
3111 if (PL_statcache.st_uid == PL_uid)
3115 if (PL_statcache.st_uid == PL_euid)
3119 if (PL_statcache.st_size == 0)
3123 if (S_ISSOCK(PL_statcache.st_mode))
3127 if (S_ISCHR(PL_statcache.st_mode))
3131 if (S_ISBLK(PL_statcache.st_mode))
3135 if (S_ISREG(PL_statcache.st_mode))
3139 if (S_ISDIR(PL_statcache.st_mode))
3143 if (S_ISFIFO(PL_statcache.st_mode))
3148 if (PL_statcache.st_mode & S_ISUID)
3154 if (PL_statcache.st_mode & S_ISGID)
3160 if (PL_statcache.st_mode & S_ISVTX)
3171 I32 result = my_lstat();
3175 if (S_ISLNK(PL_statcache.st_mode))
3188 STACKED_FTEST_CHECK;
3190 if (PL_op->op_flags & OPf_REF)
3192 else if (isGV(TOPs))
3194 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3195 gv = (GV*)SvRV(POPs);
3197 gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3199 if (GvIO(gv) && IoIFP(GvIOp(gv)))
3200 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3201 else if (tmpsv && SvOK(tmpsv)) {
3202 const char *tmps = SvPV_nolen_const(tmpsv);
3210 if (PerlLIO_isatty(fd))
3215 #if defined(atarist) /* this will work with atariST. Configure will
3216 make guesses for other systems. */
3217 # define FILE_base(f) ((f)->_base)
3218 # define FILE_ptr(f) ((f)->_ptr)
3219 # define FILE_cnt(f) ((f)->_cnt)
3220 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3231 register STDCHAR *s;
3237 STACKED_FTEST_CHECK;
3239 if (PL_op->op_flags & OPf_REF)
3241 else if (isGV(TOPs))
3243 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3244 gv = (GV*)SvRV(POPs);
3250 if (gv == PL_defgv) {
3252 io = GvIO(PL_statgv);
3255 goto really_filename;
3260 PL_laststatval = -1;
3261 sv_setpvn(PL_statname, "", 0);
3262 io = GvIO(PL_statgv);
3264 if (io && IoIFP(io)) {
3265 if (! PerlIO_has_base(IoIFP(io)))
3266 DIE(aTHX_ "-T and -B not implemented on filehandles");
3267 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3268 if (PL_laststatval < 0)
3270 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3271 if (PL_op->op_type == OP_FTTEXT)
3276 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3277 i = PerlIO_getc(IoIFP(io));
3279 (void)PerlIO_ungetc(IoIFP(io),i);
3281 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3283 len = PerlIO_get_bufsiz(IoIFP(io));
3284 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3285 /* sfio can have large buffers - limit to 512 */
3290 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3292 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3294 SETERRNO(EBADF,RMS_IFI);
3302 PL_laststype = OP_STAT;
3303 sv_setpv(PL_statname, SvPV_nolen_const(sv));
3304 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3305 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3307 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3310 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3311 if (PL_laststatval < 0) {
3312 (void)PerlIO_close(fp);
3315 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3316 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3317 (void)PerlIO_close(fp);
3319 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3320 RETPUSHNO; /* special case NFS directories */
3321 RETPUSHYES; /* null file is anything */
3326 /* now scan s to look for textiness */
3327 /* XXX ASCII dependent code */
3329 #if defined(DOSISH) || defined(USEMYBINMODE)
3330 /* ignore trailing ^Z on short files */
3331 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3335 for (i = 0; i < len; i++, s++) {
3336 if (!*s) { /* null never allowed in text */
3341 else if (!(isPRINT(*s) || isSPACE(*s)))
3344 else if (*s & 128) {
3346 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3349 /* utf8 characters don't count as odd */
3350 if (UTF8_IS_START(*s)) {
3351 int ulen = UTF8SKIP(s);
3352 if (ulen < len - i) {
3354 for (j = 1; j < ulen; j++) {
3355 if (!UTF8_IS_CONTINUATION(s[j]))
3358 --ulen; /* loop does extra increment */
3368 *s != '\n' && *s != '\r' && *s != '\b' &&
3369 *s != '\t' && *s != '\f' && *s != 27)
3374 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3385 const char *tmps = NULL;
3389 SV * const sv = POPs;
3390 if (PL_op->op_flags & OPf_SPECIAL) {
3391 gv = gv_fetchsv(sv, 0, SVt_PVIO);
3393 else if (SvTYPE(sv) == SVt_PVGV) {
3396 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
3400 tmps = SvPV_nolen_const(sv);
3404 if( !gv && (!tmps || !*tmps) ) {
3405 HV * const table = GvHVn(PL_envgv);
3408 if ( (svp = hv_fetchs(table, "HOME", FALSE))
3409 || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3411 || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3416 deprecate("chdir('') or chdir(undef) as chdir()");
3417 tmps = SvPV_nolen_const(*svp);
3421 TAINT_PROPER("chdir");
3426 TAINT_PROPER("chdir");
3429 IO* const io = GvIO(gv);
3432 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3433 } else if (IoIFP(io)) {
3434 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3437 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3438 report_evil_fh(gv, io, PL_op->op_type);
3439 SETERRNO(EBADF, RMS_IFI);
3444 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3445 report_evil_fh(gv, io, PL_op->op_type);
3446 SETERRNO(EBADF,RMS_IFI);
3450 DIE(aTHX_ PL_no_func, "fchdir");
3454 PUSHi( PerlDir_chdir(tmps) >= 0 );
3456 /* Clear the DEFAULT element of ENV so we'll get the new value
3458 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3465 dVAR; dSP; dMARK; dTARGET;
3466 const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3477 char * const tmps = POPpx;
3478 TAINT_PROPER("chroot");
3479 PUSHi( chroot(tmps) >= 0 );
3482 DIE(aTHX_ PL_no_func, "chroot");
3490 const char * const tmps2 = POPpconstx;
3491 const char * const tmps = SvPV_nolen_const(TOPs);
3492 TAINT_PROPER("rename");
3494 anum = PerlLIO_rename(tmps, tmps2);
3496 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3497 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3500 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3501 (void)UNLINK(tmps2);
3502 if (!(anum = link(tmps, tmps2)))
3503 anum = UNLINK(tmps);
3511 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3515 const int op_type = PL_op->op_type;
3519 if (op_type == OP_LINK)
3520 DIE(aTHX_ PL_no_func, "link");
3522 # ifndef HAS_SYMLINK
3523 if (op_type == OP_SYMLINK)
3524 DIE(aTHX_ PL_no_func, "symlink");
3528 const char * const tmps2 = POPpconstx;
3529 const char * const tmps = SvPV_nolen_const(TOPs);
3530 TAINT_PROPER(PL_op_desc[op_type]);
3532 # if defined(HAS_LINK)
3533 # if defined(HAS_SYMLINK)
3534 /* Both present - need to choose which. */
3535 (op_type == OP_LINK) ?
3536 PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3538 /* Only have link, so calls to pp_symlink will have DIE()d above. */
3539 PerlLIO_link(tmps, tmps2);
3542 # if defined(HAS_SYMLINK)
3543 /* Only have symlink, so calls to pp_link will have DIE()d above. */
3544 symlink(tmps, tmps2);
3549 SETi( result >= 0 );
3556 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3567 char buf[MAXPATHLEN];
3570 #ifndef INCOMPLETE_TAINTS
3574 len = readlink(tmps, buf, sizeof(buf) - 1);
3582 RETSETUNDEF; /* just pretend it's a normal file */
3586 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3588 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3590 char * const save_filename = filename;
3595 Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3597 Newx(cmdline, size, char);
3598 my_strlcpy(cmdline, cmd, size);
3599 my_strlcat(cmdline, " ", size);
3600 for (s = cmdline + strlen(cmdline); *filename; ) {
3604 if (s - cmdline < size)
3605 my_strlcpy(s, " 2>&1", size - (s - cmdline));
3606 myfp = PerlProc_popen(cmdline, "r");
3610 SV * const tmpsv = sv_newmortal();
3611 /* Need to save/restore 'PL_rs' ?? */
3612 s = sv_gets(tmpsv, myfp, 0);
3613 (void)PerlProc_pclose(myfp);
3617 #ifdef HAS_SYS_ERRLIST
3622 /* you don't see this */
3623 const char * const errmsg =
3624 #ifdef HAS_SYS_ERRLIST
3632 if (instr(s, errmsg)) {
3639 #define EACCES EPERM
3641 if (instr(s, "cannot make"))
3642 SETERRNO(EEXIST,RMS_FEX);
3643 else if (instr(s, "existing file"))
3644 SETERRNO(EEXIST,RMS_FEX);
3645 else if (instr(s, "ile exists"))
3646 SETERRNO(EEXIST,RMS_FEX);
3647 else if (instr(s, "non-exist"))
3648 SETERRNO(ENOENT,RMS_FNF);
3649 else if (instr(s, "does not exist"))
3650 SETERRNO(ENOENT,RMS_FNF);
3651 else if (instr(s, "not empty"))
3652 SETERRNO(EBUSY,SS_DEVOFFLINE);
3653 else if (instr(s, "cannot access"))
3654 SETERRNO(EACCES,RMS_PRV);
3656 SETERRNO(EPERM,RMS_PRV);
3659 else { /* some mkdirs return no failure indication */
3660 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3661 if (PL_op->op_type == OP_RMDIR)
3666 SETERRNO(EACCES,RMS_PRV); /* a guess */
3675 /* This macro removes trailing slashes from a directory name.
3676 * Different operating and file systems take differently to
3677 * trailing slashes. According to POSIX 1003.1 1996 Edition
3678 * any number of trailing slashes should be allowed.
3679 * Thusly we snip them away so that even non-conforming
3680 * systems are happy.
3681 * We should probably do this "filtering" for all
3682 * the functions that expect (potentially) directory names:
3683 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3684 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3686 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3687 if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3690 } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3691 (tmps) = savepvn((tmps), (len)); \
3701 const int mode = (MAXARG > 1) ? POPi : 0777;
3703 TRIMSLASHES(tmps,len,copy);
3705 TAINT_PROPER("mkdir");
3707 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3711 SETi( dooneliner("mkdir", tmps) );
3712 oldumask = PerlLIO_umask(0);
3713 PerlLIO_umask(oldumask);
3714 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3729 TRIMSLASHES(tmps,len,copy);
3730 TAINT_PROPER("rmdir");
3732 SETi( PerlDir_rmdir(tmps) >= 0 );
3734 SETi( dooneliner("rmdir", tmps) );
3741 /* Directory calls. */
3745 #if defined(Direntry_t) && defined(HAS_READDIR)
3747 const char * const dirname = POPpconstx;
3748 GV * const gv = (GV*)POPs;
3749 register IO * const io = GvIOn(gv);
3754 if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED))
3755 Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3756 "Opening filehandle %s also as a directory", GvENAME(gv));
3758 PerlDir_close(IoDIRP(io));
3759 if (!(IoDIRP(io) = PerlDir_open(dirname)))
3765 SETERRNO(EBADF,RMS_DIR);
3768 DIE(aTHX_ PL_no_dir_func, "opendir");
3774 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3775 DIE(aTHX_ PL_no_dir_func, "readdir");
3777 #if !defined(I_DIRENT) && !defined(VMS)
3778 Direntry_t *readdir (DIR *);
3784 const I32 gimme = GIMME;
3785 GV * const gv = (GV *)POPs;
3786 register const Direntry_t *dp;
3787 register IO * const io = GvIOn(gv);
3789 if (!io || !IoDIRP(io)) {
3790 if(ckWARN(WARN_IO)) {
3791 Perl_warner(aTHX_ packWARN(WARN_IO),
3792 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3798 dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3802 sv = newSVpvn(dp->d_name, dp->d_namlen);
3804 sv = newSVpv(dp->d_name, 0);
3806 #ifndef INCOMPLETE_TAINTS
3807 if (!(IoFLAGS(io) & IOf_UNTAINT))
3810 XPUSHs(sv_2mortal(sv));
3811 } while (gimme == G_ARRAY);
3813 if (!dp && gimme != G_ARRAY)
3820 SETERRNO(EBADF,RMS_ISI);
3821 if (GIMME == G_ARRAY)
3830 #if defined(HAS_TELLDIR) || defined(telldir)
3832 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3833 /* XXX netbsd still seemed to.
3834 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3835 --JHI 1999-Feb-02 */
3836 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3837 long telldir (DIR *);
3839 GV * const gv = (GV*)POPs;
3840 register IO * const io = GvIOn(gv);
3842 if (!io || !IoDIRP(io)) {
3843 if(ckWARN(WARN_IO)) {
3844 Perl_warner(aTHX_ packWARN(WARN_IO),
3845 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3850 PUSHi( PerlDir_tell(IoDIRP(io)) );
3854 SETERRNO(EBADF,RMS_ISI);
3857 DIE(aTHX_ PL_no_dir_func, "telldir");
3863 #if defined(HAS_SEEKDIR) || defined(seekdir)
3865 const long along = POPl;
3866 GV * const gv = (GV*)POPs;
3867 register IO * const io = GvIOn(gv);
3869 if (!io || !IoDIRP(io)) {
3870 if(ckWARN(WARN_IO)) {
3871 Perl_warner(aTHX_ packWARN(WARN_IO),
3872 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3876 (void)PerlDir_seek(IoDIRP(io), along);
3881 SETERRNO(EBADF,RMS_ISI);
3884 DIE(aTHX_ PL_no_dir_func, "seekdir");
3890 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3892 GV * const gv = (GV*)POPs;
3893 register IO * const io = GvIOn(gv);
3895 if (!io || !IoDIRP(io)) {
3896 if(ckWARN(WARN_IO)) {
3897 Perl_warner(aTHX_ packWARN(WARN_IO),
3898 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3902 (void)PerlDir_rewind(IoDIRP(io));
3906 SETERRNO(EBADF,RMS_ISI);
3909 DIE(aTHX_ PL_no_dir_func, "rewinddir");
3915 #if defined(Direntry_t) && defined(HAS_READDIR)
3917 GV * const gv = (GV*)POPs;
3918 register IO * const io = GvIOn(gv);
3920 if (!io || !IoDIRP(io)) {
3921 if(ckWARN(WARN_IO)) {
3922 Perl_warner(aTHX_ packWARN(WARN_IO),
3923 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3927 #ifdef VOID_CLOSEDIR
3928 PerlDir_close(IoDIRP(io));
3930 if (PerlDir_close(IoDIRP(io)) < 0) {
3931 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3940 SETERRNO(EBADF,RMS_IFI);
3943 DIE(aTHX_ PL_no_dir_func, "closedir");
3947 /* Process control. */
3956 PERL_FLUSHALL_FOR_CHILD;
3957 childpid = PerlProc_fork();
3961 GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3963 SvREADONLY_off(GvSV(tmpgv));
3964 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3965 SvREADONLY_on(GvSV(tmpgv));
3967 #ifdef THREADS_HAVE_PIDS
3968 PL_ppid = (IV)getppid();
3970 #ifdef PERL_USES_PL_PIDSTATUS
3971 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3977 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3982 PERL_FLUSHALL_FOR_CHILD;
3983 childpid = PerlProc_fork();
3989 DIE(aTHX_ PL_no_func, "fork");
3996 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4001 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4002 childpid = wait4pid(-1, &argflags, 0);
4004 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4009 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4010 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4011 STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4013 STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4018 DIE(aTHX_ PL_no_func, "wait");
4024 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4026 const int optype = POPi;
4027 const Pid_t pid = TOPi;
4031 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4032 result = wait4pid(pid, &argflags, optype);
4034 while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4039 # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4040 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4041 STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4043 STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4048 DIE(aTHX_ PL_no_func, "waitpid");
4054 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4055 #if defined(__LIBCATAMOUNT__)
4056 PL_statusvalue = -1;
4065 while (++MARK <= SP) {
4066 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4071 TAINT_PROPER("system");
4073 PERL_FLUSHALL_FOR_CHILD;
4074 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4080 if (PerlProc_pipe(pp) >= 0)
4082 while ((childpid = PerlProc_fork()) == -1) {
4083 if (errno != EAGAIN) {
4088 PerlLIO_close(pp[0]);
4089 PerlLIO_close(pp[1]);
4096 Sigsave_t ihand,qhand; /* place to save signals during system() */
4100 PerlLIO_close(pp[1]);
4102 rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand);
4103 rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4106 result = wait4pid(childpid, &status, 0);
4107 } while (result == -1 && errno == EINTR);
4109 (void)rsignal_restore(SIGINT, &ihand);
4110 (void)rsignal_restore(SIGQUIT, &qhand);
4112 STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4113 do_execfree(); /* free any memory child malloced on fork */
4120 while (n < sizeof(int)) {
4121 n1 = PerlLIO_read(pp[0],
4122 (void*)(((char*)&errkid)+n),
4128 PerlLIO_close(pp[0]);
4129 if (n) { /* Error */
4130 if (n != sizeof(int))
4131 DIE(aTHX_ "panic: kid popen errno read");
4132 errno = errkid; /* Propagate errno from kid */
4133 STATUS_NATIVE_CHILD_SET(-1);
4136 XPUSHi(STATUS_CURRENT);
4140 PerlLIO_close(pp[0]);
4141 #if defined(HAS_FCNTL) && defined(F_SETFD)
4142 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4145 if (PL_op->op_flags & OPf_STACKED) {
4146 SV * const really = *++MARK;
4147 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4149 else if (SP - MARK != 1)
4150 value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4152 value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4156 #else /* ! FORK or VMS or OS/2 */
4159 if (PL_op->op_flags & OPf_STACKED) {
4160 SV * const really = *++MARK;
4161 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4162 value = (I32)do_aspawn(really, MARK, SP);
4164 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4167 else if (SP - MARK != 1) {
4168 # if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4169 value = (I32)do_aspawn(NULL, MARK, SP);
4171 value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4175 value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4177 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4179 STATUS_NATIVE_CHILD_SET(value);
4182 XPUSHi(result ? value : STATUS_CURRENT);
4183 #endif /* !FORK or VMS or OS/2 */
4190 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4195 while (++MARK <= SP) {
4196 (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4201 TAINT_PROPER("exec");
4203 PERL_FLUSHALL_FOR_CHILD;
4204 if (PL_op->op_flags & OPf_STACKED) {
4205 SV * const really = *++MARK;
4206 value = (I32)do_aexec(really, MARK, SP);
4208 else if (SP - MARK != 1)
4210 value = (I32)vms_do_aexec(NULL, MARK, SP);
4214 (void ) do_aspawn(NULL, MARK, SP);
4218 value = (I32)do_aexec(NULL, MARK, SP);
4223 value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4226 (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4229 value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4243 # ifdef THREADS_HAVE_PIDS
4244 if (PL_ppid != 1 && getppid() == 1)
4245 /* maybe the parent process has died. Refresh ppid cache */
4249 XPUSHi( getppid() );
4253 DIE(aTHX_ PL_no_func, "getppid");
4262 const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4265 pgrp = (I32)BSD_GETPGRP(pid);
4267 if (pid != 0 && pid != PerlProc_getpid())
4268 DIE(aTHX_ "POSIX getpgrp can't take an argument");
4274 DIE(aTHX_ PL_no_func, "getpgrp()");
4293 TAINT_PROPER("setpgrp");
4295 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4297 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4298 || (pid != 0 && pid != PerlProc_getpid()))
4300 DIE(aTHX_ "setpgrp can't take arguments");
4302 SETi( setpgrp() >= 0 );
4303 #endif /* USE_BSDPGRP */
4306 DIE(aTHX_ PL_no_func, "setpgrp()");
4312 #ifdef HAS_GETPRIORITY
4314 const int who = POPi;
4315 const int which = TOPi;
4316 SETi( getpriority(which, who) );
4319 DIE(aTHX_ PL_no_func, "getpriority()");
4325 #ifdef HAS_SETPRIORITY
4327 const int niceval = POPi;
4328 const int who = POPi;
4329 const int which = TOPi;
4330 TAINT_PROPER("setpriority");
4331 SETi( setpriority(which, who, niceval) >= 0 );
4334 DIE(aTHX_ PL_no_func, "setpriority()");
4344 XPUSHn( time(NULL) );
4346 XPUSHi( time(NULL) );
4358 (void)PerlProc_times(&PL_timesbuf);
4360 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
4361 /* struct tms, though same data */
4365 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick)));
4366 if (GIMME == G_ARRAY) {
4367 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick)));
4368 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick)));
4369 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick)));
4375 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4377 if (GIMME == G_ARRAY) {
4378 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4379 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4380 PUSHs(sv_2mortal(newSVnv((NV)0.0)));
4384 DIE(aTHX_ "times not implemented");
4386 #endif /* HAS_TIMES */
4389 #ifdef LOCALTIME_EDGECASE_BROKEN
4390 static struct tm *S_my_localtime (pTHX_ Time_t *tp)
4395 /* No workarounds in the valid range */
4396 if (!tp || *tp < 0x7fff573f || *tp >= 0x80000000)
4397 return (localtime (tp));
4399 /* This edge case is to workaround the undefined behaviour, where the
4400 * TIMEZONE makes the time go beyond the defined range.
4401 * gmtime (0x7fffffff) => 2038-01-19 03:14:07
4402 * If there is a negative offset in TZ, like MET-1METDST, some broken
4403 * implementations of localtime () (like AIX 5.2) barf with bogus
4405 * 0x7fffffff gmtime 2038-01-19 03:14:07
4406 * 0x7fffffff localtime 1901-12-13 21:45:51
4407 * 0x7fffffff mylocaltime 2038-01-19 04:14:07
4408 * 0x3c19137f gmtime 2001-12-13 20:45:51
4409 * 0x3c19137f localtime 2001-12-13 21:45:51
4410 * 0x3c19137f mylocaltime 2001-12-13 21:45:51
4411 * Given that legal timezones are typically between GMT-12 and GMT+12
4412 * we turn back the clock 23 hours before calling the localtime
4413 * function, and add those to the return value. This will never cause
4414 * day wrapping problems, since the edge case is Tue Jan *19*
4416 T = *tp - 82800; /* 23 hour. allows up to GMT-23 */
4419 if (P->tm_hour >= 24) {
4421 P->tm_mday++; /* 18 -> 19 */
4422 P->tm_wday++; /* Mon -> Tue */
4423 P->tm_yday++; /* 18 -> 19 */
4426 } /* S_my_localtime */
4434 const struct tm *tmbuf;
4435 static const char * const dayname[] =
4436 {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4437 static const char * const monname[] =
4438 {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4439 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4445 when = (Time_t)SvNVx(POPs);
4447 when = (Time_t)SvIVx(POPs);
4450 if (PL_op->op_type == OP_LOCALTIME)
4451 #ifdef LOCALTIME_EDGECASE_BROKEN
4452 tmbuf = S_my_localtime(aTHX_ &when);
4454 tmbuf = localtime(&when);
4457 tmbuf = gmtime(&when);
4459 if (GIMME != G_ARRAY) {
4465 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
4466 dayname[tmbuf->tm_wday],
4467 monname[tmbuf->tm_mon],
4472 tmbuf->tm_year + 1900);
4473 PUSHs(sv_2mortal(tsv));
4478 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4479 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4480 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4481 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4482 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4483 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4484 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4485 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4486 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
4497 anum = alarm((unsigned int)anum);
4504 DIE(aTHX_ PL_no_func, "alarm");
4515 (void)time(&lasttime);
4520 PerlProc_sleep((unsigned int)duration);
4523 XPUSHi(when - lasttime);
4527 /* Shared memory. */
4528 /* Merged with some message passing. */
4532 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4533 dVAR; dSP; dMARK; dTARGET;
4534 const int op_type = PL_op->op_type;
4539 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4542 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4545 value = (I32)(do_semop(MARK, SP) >= 0);
4548 value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4564 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4565 dVAR; dSP; dMARK; dTARGET;
4566 const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4573 DIE(aTHX_ "System V IPC is not implemented on this machine");
4579 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4580 dVAR; dSP; dMARK; dTARGET;
4581 const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4589 PUSHp(zero_but_true, ZBTLEN);
4597 /* I can't const this further without getting warnings about the types of
4598 various arrays passed in from structures. */
4600 S_space_join_names_mortal(pTHX_ char *const *array)
4604 if (array && *array) {
4605 target = sv_2mortal(newSVpvs(""));
4607 sv_catpv(target, *array);
4610 sv_catpvs(target, " ");
4613 target = sv_mortalcopy(&PL_sv_no);
4618 /* Get system info. */
4622 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4624 I32 which = PL_op->op_type;
4625 register char **elem;
4627 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4628 struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4629 struct hostent *gethostbyname(Netdb_name_t);
4630 struct hostent *gethostent(void);
4632 struct hostent *hent;
4636 if (which == OP_GHBYNAME) {
4637 #ifdef HAS_GETHOSTBYNAME
4638 const char* const name = POPpbytex;
4639 hent = PerlSock_gethostbyname(name);
4641 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4644 else if (which == OP_GHBYADDR) {
4645 #ifdef HAS_GETHOSTBYADDR
4646 const int addrtype = POPi;
4647 SV * const addrsv = POPs;
4649 const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4651 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4653 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4657 #ifdef HAS_GETHOSTENT
4658 hent = PerlSock_gethostent();
4660 DIE(aTHX_ PL_no_sock_func, "gethostent");
4663 #ifdef HOST_NOT_FOUND
4665 #ifdef USE_REENTRANT_API
4666 # ifdef USE_GETHOSTENT_ERRNO
4667 h_errno = PL_reentrant_buffer->_gethostent_errno;
4670 STATUS_UNIX_SET(h_errno);
4674 if (GIMME != G_ARRAY) {
4675 PUSHs(sv = sv_newmortal());
4677 if (which == OP_GHBYNAME) {
4679 sv_setpvn(sv, hent->h_addr, hent->h_length);
4682 sv_setpv(sv, (char*)hent->h_name);
4688 PUSHs(sv_2mortal(newSVpv((char*)hent->h_name, 0)));
4689 PUSHs(space_join_names_mortal(hent->h_aliases));
4690 PUSHs(sv_2mortal(newSViv((IV)hent->h_addrtype)));
4691 len = hent->h_length;
4692 PUSHs(sv_2mortal(newSViv((IV)len)));
4694 for (elem = hent->h_addr_list; elem && *elem; elem++) {
4695 XPUSHs(sv_2mortal(newSVpvn(*elem, len)));
4699 PUSHs(newSVpvn(hent->h_addr, len));
4701 PUSHs(sv_mortalcopy(&PL_sv_no));
4706 DIE(aTHX_ PL_no_sock_func, "gethostent");
4712 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4714 I32 which = PL_op->op_type;
4716 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4717 struct netent *getnetbyaddr(Netdb_net_t, int);
4718 struct netent *getnetbyname(Netdb_name_t);
4719 struct netent *getnetent(void);
4721 struct netent *nent;
4723 if (which == OP_GNBYNAME){
4724 #ifdef HAS_GETNETBYNAME
4725 const char * const name = POPpbytex;
4726 nent = PerlSock_getnetbyname(name);
4728 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4731 else if (which == OP_GNBYADDR) {
4732 #ifdef HAS_GETNETBYADDR
4733 const int addrtype = POPi;
4734 const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4735 nent = PerlSock_getnetbyaddr(addr, addrtype);
4737 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4741 #ifdef HAS_GETNETENT
4742 nent = PerlSock_getnetent();
4744 DIE(aTHX_ PL_no_sock_func, "getnetent");
4747 #ifdef HOST_NOT_FOUND
4749 #ifdef USE_REENTRANT_API
4750 # ifdef USE_GETNETENT_ERRNO
4751 h_errno = PL_reentrant_buffer->_getnetent_errno;
4754 STATUS_UNIX_SET(h_errno);
4759 if (GIMME != G_ARRAY) {
4760 PUSHs(sv = sv_newmortal());
4762 if (which == OP_GNBYNAME)
4763 sv_setiv(sv, (IV)nent->n_net);
4765 sv_setpv(sv, nent->n_name);
4771 PUSHs(sv_2mortal(newSVpv(nent->n_name, 0)));
4772 PUSHs(space_join_names_mortal(nent->n_aliases));
4773 PUSHs(sv_2mortal(newSViv((IV)nent->n_addrtype)));
4774 PUSHs(sv_2mortal(newSViv((IV)nent->n_net)));
4779 DIE(aTHX_ PL_no_sock_func, "getnetent");
4785 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4787 I32 which = PL_op->op_type;
4789 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4790 struct protoent *getprotobyname(Netdb_name_t);
4791 struct protoent *getprotobynumber(int);
4792 struct protoent *getprotoent(void);
4794 struct protoent *pent;
4796 if (which == OP_GPBYNAME) {
4797 #ifdef HAS_GETPROTOBYNAME
4798 const char* const name = POPpbytex;
4799 pent = PerlSock_getprotobyname(name);
4801 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4804 else if (which == OP_GPBYNUMBER) {
4805 #ifdef HAS_GETPROTOBYNUMBER
4806 const int number = POPi;
4807 pent = PerlSock_getprotobynumber(number);
4809 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4813 #ifdef HAS_GETPROTOENT
4814 pent = PerlSock_getprotoent();
4816 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4820 if (GIMME != G_ARRAY) {
4821 PUSHs(sv = sv_newmortal());
4823 if (which == OP_GPBYNAME)
4824 sv_setiv(sv, (IV)pent->p_proto);
4826 sv_setpv(sv, pent->p_name);
4832 PUSHs(sv_2mortal(newSVpv(pent->p_name, 0)));
4833 PUSHs(space_join_names_mortal(pent->p_aliases));
4834 PUSHs(sv_2mortal(newSViv((IV)pent->p_proto)));
4839 DIE(aTHX_ PL_no_sock_func, "getprotoent");
4845 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4847 I32 which = PL_op->op_type;
4849 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4850 struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4851 struct servent *getservbyport(int, Netdb_name_t);
4852 struct servent *getservent(void);
4854 struct servent *sent;
4856 if (which == OP_GSBYNAME) {
4857 #ifdef HAS_GETSERVBYNAME
4858 const char * const proto = POPpbytex;
4859 const char * const name = POPpbytex;
4860 sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4862 DIE(aTHX_ PL_no_sock_func, "getservbyname");
4865 else if (which == OP_GSBYPORT) {
4866 #ifdef HAS_GETSERVBYPORT
4867 const char * const proto = POPpbytex;
4868 unsigned short port = (unsigned short)POPu;
4870 port = PerlSock_htons(port);
4872 sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4874 DIE(aTHX_ PL_no_sock_func, "getservbyport");
4878 #ifdef HAS_GETSERVENT
4879 sent = PerlSock_getservent();
4881 DIE(aTHX_ PL_no_sock_func, "getservent");
4885 if (GIMME != G_ARRAY) {
4886 PUSHs(sv = sv_newmortal());
4888 if (which == OP_GSBYNAME) {
4890 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4892 sv_setiv(sv, (IV)(sent->s_port));
4896 sv_setpv(sv, sent->s_name);
4902 PUSHs(sv_2mortal(newSVpv(sent->s_name, 0)));
4903 PUSHs(space_join_names_mortal(sent->s_aliases));
4905 PUSHs(sv_2mortal(newSViv((IV)PerlSock_ntohs(sent->s_port))));
4907 PUSHs(sv_2mortal(newSViv((IV)(sent->s_port))));
4909 PUSHs(sv_2mortal(newSVpv(sent->s_proto, 0)));
4914 DIE(aTHX_ PL_no_sock_func, "getservent");
4920 #ifdef HAS_SETHOSTENT
4922 PerlSock_sethostent(TOPi);
4925 DIE(aTHX_ PL_no_sock_func, "sethostent");
4931 #ifdef HAS_SETNETENT
4933 PerlSock_setnetent(TOPi);
4936 DIE(aTHX_ PL_no_sock_func, "setnetent");
4942 #ifdef HAS_SETPROTOENT
4944 PerlSock_setprotoent(TOPi);
4947 DIE(aTHX_ PL_no_sock_func, "setprotoent");
4953 #ifdef HAS_SETSERVENT
4955 PerlSock_setservent(TOPi);
4958 DIE(aTHX_ PL_no_sock_func, "setservent");
4964 #ifdef HAS_ENDHOSTENT
4966 PerlSock_endhostent();
4970 DIE(aTHX_ PL_no_sock_func, "endhostent");
4976 #ifdef HAS_ENDNETENT
4978 PerlSock_endnetent();
4982 DIE(aTHX_ PL_no_sock_func, "endnetent");
4988 #ifdef HAS_ENDPROTOENT
4990 PerlSock_endprotoent();
4994 DIE(aTHX_ PL_no_sock_func, "endprotoent");
5000 #ifdef HAS_ENDSERVENT
5002 PerlSock_endservent();
5006 DIE(aTHX_ PL_no_sock_func, "endservent");
5014 I32 which = PL_op->op_type;
5016 struct passwd *pwent = NULL;
5018 * We currently support only the SysV getsp* shadow password interface.
5019 * The interface is declared in <shadow.h> and often one needs to link
5020 * with -lsecurity or some such.
5021 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5024 * AIX getpwnam() is clever enough to return the encrypted password
5025 * only if the caller (euid?) is root.
5027 * There are at least three other shadow password APIs. Many platforms
5028 * seem to contain more than one interface for accessing the shadow
5029 * password databases, possibly for compatibility reasons.
5030 * The getsp*() is by far he simplest one, the other two interfaces
5031 * are much more complicated, but also very similar to each other.
5036 * struct pr_passwd *getprpw*();
5037 * The password is in
5038 * char getprpw*(...).ufld.fd_encrypt[]
5039 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5044 * struct es_passwd *getespw*();
5045 * The password is in
5046 * char *(getespw*(...).ufld.fd_encrypt)
5047 * Mention HAS_GETESPWNAM here so that Configure probes for it.
5050 * struct userpw *getuserpw();
5051 * The password is in
5052 * char *(getuserpw(...)).spw_upw_passwd
5053 * (but the de facto standard getpwnam() should work okay)
5055 * Mention I_PROT here so that Configure probes for it.
5057 * In HP-UX for getprpw*() the manual page claims that one should include
5058 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5059 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5060 * and pp_sys.c already includes <shadow.h> if there is such.
5062 * Note that <sys/security.h> is already probed for, but currently
5063 * it is only included in special cases.
5065 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5066 * be preferred interface, even though also the getprpw*() interface
5067 * is available) one needs to link with -lsecurity -ldb -laud -lm.
5068 * One also needs to call set_auth_parameters() in main() before
5069 * doing anything else, whether one is using getespw*() or getprpw*().
5071 * Note that accessing the shadow databases can be magnitudes
5072 * slower than accessing the standard databases.
5077 # if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5078 /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5079 * the pw_comment is left uninitialized. */
5080 PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5086 const char* const name = POPpbytex;
5087 pwent = getpwnam(name);
5093 pwent = getpwuid(uid);
5097 # ifdef HAS_GETPWENT
5099 #ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */
5100 if (pwent) pwent = getpwnam(pwent->pw_name);
5103 DIE(aTHX_ PL_no_func, "getpwent");
5109 if (GIMME != G_ARRAY) {
5110 PUSHs(sv = sv_newmortal());
5112 if (which == OP_GPWNAM)
5113 # if Uid_t_sign <= 0
5114 sv_setiv(sv, (IV)pwent->pw_uid);
5116 sv_setuv(sv, (UV)pwent->pw_uid);
5119 sv_setpv(sv, pwent->pw_name);
5125 PUSHs(sv_2mortal(newSVpv(pwent->pw_name, 0)));
5127 PUSHs(sv = sv_2mortal(newSViv(0)));
5128 /* If we have getspnam(), we try to dig up the shadow
5129 * password. If we are underprivileged, the shadow
5130 * interface will set the errno to EACCES or similar,
5131 * and return a null pointer. If this happens, we will
5132 * use the dummy password (usually "*" or "x") from the
5133 * standard password database.
5135 * In theory we could skip the shadow call completely
5136 * if euid != 0 but in practice we cannot know which
5137 * security measures are guarding the shadow databases
5138 * on a random platform.
5140 * Resist the urge to use additional shadow interfaces.
5141 * Divert the urge to writing an extension instead.
5144 /* Some AIX setups falsely(?) detect some getspnam(), which
5145 * has a different API than the Solaris/IRIX one. */
5146 # if defined(HAS_GETSPNAM) && !defined(_AIX)
5148 const int saverrno = errno;
5149 const struct spwd * const spwent = getspnam(pwent->pw_name);
5150 /* Save and restore errno so that
5151 * underprivileged attempts seem
5152 * to have never made the unsccessful
5153 * attempt to retrieve the shadow password. */
5155 if (spwent && spwent->sp_pwdp)
5156 sv_setpv(sv, spwent->sp_pwdp);
5160 if (!SvPOK(sv)) /* Use the standard password, then. */
5161 sv_setpv(sv, pwent->pw_passwd);
5164 # ifndef INCOMPLETE_TAINTS
5165 /* passwd is tainted because user himself can diddle with it.
5166 * admittedly not much and in a very limited way, but nevertheless. */
5170 # if Uid_t_sign <= 0
5171 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_uid)));
5173 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_uid)));
5176 # if Uid_t_sign <= 0
5177 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_gid)));
5179 PUSHs(sv_2mortal(newSVuv((UV)pwent->pw_gid)));
5181 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5182 * because of the poor interface of the Perl getpw*(),
5183 * not because there's some standard/convention saying so.
5184 * A better interface would have been to return a hash,
5185 * but we are accursed by our history, alas. --jhi. */
5187 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_change)));
5190 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_quota)));
5193 PUSHs(sv_2mortal(newSVpv(pwent->pw_age, 0)));
5195 /* I think that you can never get this compiled, but just in case. */
5196 PUSHs(sv_mortalcopy(&PL_sv_no));
5201 /* pw_class and pw_comment are mutually exclusive--.
5202 * see the above note for pw_change, pw_quota, and pw_age. */
5204 PUSHs(sv_2mortal(newSVpv(pwent->pw_class, 0)));
5207 PUSHs(sv_2mortal(newSVpv(pwent->pw_comment, 0)));
5209 /* I think that you can never get this compiled, but just in case. */
5210 PUSHs(sv_mortalcopy(&PL_sv_no));
5215 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5217 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5219 # ifndef INCOMPLETE_TAINTS
5220 /* pw_gecos is tainted because user himself can diddle with it. */
5224 PUSHs(sv_2mortal(newSVpv(pwent->pw_dir, 0)));
5226 PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5227 # ifndef INCOMPLETE_TAINTS
5228 /* pw_shell is tainted because user himself can diddle with it. */
5233 PUSHs(sv_2mortal(newSViv((IV)pwent->pw_expire)));
5238 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5244 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5249 DIE(aTHX_ PL_no_func, "setpwent");
5255 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5260 DIE(aTHX_ PL_no_func, "endpwent");
5268 const I32 which = PL_op->op_type;
5269 const struct group *grent;
5271 if (which == OP_GGRNAM) {
5272 const char* const name = POPpbytex;
5273 grent = (const struct group *)getgrnam(name);
5275 else if (which == OP_GGRGID) {
5276 const Gid_t gid = POPi;
5277 grent = (const struct group *)getgrgid(gid);
5281 grent = (struct group *)getgrent();
5283 DIE(aTHX_ PL_no_func, "getgrent");
5287 if (GIMME != G_ARRAY) {
5288 SV * const sv = sv_newmortal();
5292 if (which == OP_GGRNAM)
5293 sv_setiv(sv, (IV)grent->gr_gid);
5295 sv_setpv(sv, grent->gr_name);
5301 PUSHs(sv_2mortal(newSVpv(grent->gr_name, 0)));
5304 PUSHs(sv_2mortal(newSVpv(grent->gr_passwd, 0)));
5306 PUSHs(sv_mortalcopy(&PL_sv_no));
5309 PUSHs(sv_2mortal(newSViv((IV)grent->gr_gid)));
5311 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5312 /* In UNICOS/mk (_CRAYMPP) the multithreading
5313 * versions (getgrnam_r, getgrgid_r)
5314 * seem to return an illegal pointer
5315 * as the group members list, gr_mem.
5316 * getgrent() doesn't even have a _r version
5317 * but the gr_mem is poisonous anyway.
5318 * So yes, you cannot get the list of group
5319 * members if building multithreaded in UNICOS/mk. */
5320 PUSHs(space_join_names_mortal(grent->gr_mem));
5326 DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5332 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5337 DIE(aTHX_ PL_no_func, "setgrent");
5343 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5348 DIE(aTHX_ PL_no_func, "endgrent");
5358 if (!(tmps = PerlProc_getlogin()))
5360 PUSHp(tmps, strlen(tmps));
5363 DIE(aTHX_ PL_no_func, "getlogin");
5367 /* Miscellaneous. */
5372 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
5373 register I32 items = SP - MARK;
5374 unsigned long a[20];
5379 while (++MARK <= SP) {
5380 if (SvTAINTED(*MARK)) {
5386 TAINT_PROPER("syscall");
5389 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5390 * or where sizeof(long) != sizeof(char*). But such machines will
5391 * not likely have syscall implemented either, so who cares?
5393 while (++MARK <= SP) {
5394 if (SvNIOK(*MARK) || !i)
5395 a[i++] = SvIV(*MARK);
5396 else if (*MARK == &PL_sv_undef)
5399 a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5405 DIE(aTHX_ "Too many args to syscall");
5407 DIE(aTHX_ "Too few args to syscall");
5409 retval = syscall(a[0]);
5412 retval = syscall(a[0],a[1]);
5415 retval = syscall(a[0],a[1],a[2]);
5418 retval = syscall(a[0],a[1],a[2],a[3]);
5421 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5424 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5427 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5430 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5434 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5437 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5440 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5444 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5448 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5452 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5453 a[10],a[11],a[12],a[13]);
5455 #endif /* atarist */
5461 DIE(aTHX_ PL_no_func, "syscall");
5465 #ifdef FCNTL_EMULATE_FLOCK
5467 /* XXX Emulate flock() with fcntl().
5468 What's really needed is a good file locking module.
5472 fcntl_emulate_flock(int fd, int operation)
5476 switch (operation & ~LOCK_NB) {
5478 flock.l_type = F_RDLCK;
5481 flock.l_type = F_WRLCK;
5484 flock.l_type = F_UNLCK;
5490 flock.l_whence = SEEK_SET;
5491 flock.l_start = flock.l_len = (Off_t)0;
5493 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5496 #endif /* FCNTL_EMULATE_FLOCK */
5498 #ifdef LOCKF_EMULATE_FLOCK
5500 /* XXX Emulate flock() with lockf(). This is just to increase
5501 portability of scripts. The calls are not completely
5502 interchangeable. What's really needed is a good file
5506 /* The lockf() constants might have been defined in <unistd.h>.
5507 Unfortunately, <unistd.h> causes troubles on some mixed
5508 (BSD/POSIX) systems, such as SunOS 4.1.3.
5510 Further, the lockf() constants aren't POSIX, so they might not be
5511 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5512 just stick in the SVID values and be done with it. Sigh.
5516 # define F_ULOCK 0 /* Unlock a previously locked region */
5519 # define F_LOCK 1 /* Lock a region for exclusive use */
5522 # define F_TLOCK 2 /* Test and lock a region for exclusive use */
5525 # define F_TEST 3 /* Test a region for other processes locks */
5529 lockf_emulate_flock(int fd, int operation)
5532 const int save_errno = errno;
5535 /* flock locks entire file so for lockf we need to do the same */
5536 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
5537 if (pos > 0) /* is seekable and needs to be repositioned */
5538 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5539 pos = -1; /* seek failed, so don't seek back afterwards */
5542 switch (operation) {
5544 /* LOCK_SH - get a shared lock */
5546 /* LOCK_EX - get an exclusive lock */
5548 i = lockf (fd, F_LOCK, 0);
5551 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5552 case LOCK_SH|LOCK_NB:
5553 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5554 case LOCK_EX|LOCK_NB:
5555 i = lockf (fd, F_TLOCK, 0);
5557 if ((errno == EAGAIN) || (errno == EACCES))
5558 errno = EWOULDBLOCK;
5561 /* LOCK_UN - unlock (non-blocking is a no-op) */
5563 case LOCK_UN|LOCK_NB:
5564 i = lockf (fd, F_ULOCK, 0);
5567 /* Default - can't decipher operation */
5574 if (pos > 0) /* need to restore position of the handle */
5575 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
5580 #endif /* LOCKF_EMULATE_FLOCK */
5584 * c-indentation-style: bsd
5586 * indent-tabs-mode: t
5589 * ex: set ts=8 sts=4 sw=4 noet: