X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=6ed8e0a35070e68ca93e8c3f6260235042865e9f;hb=37361303e31c2073b3e9c4c5bce1a4cc42832f83;hp=516e7255ff73aa99c790506f4af93a9efc4fb754;hpb=91769ae35426bad270684425a251dfae5c8261fe;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_sys.c b/pp_sys.c index 516e725..6ed8e0a 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -1,6 +1,6 @@ /* pp_sys.c * - * Copyright (c) 1991-2001, Larry Wall + * Copyright (c) 1991-2002, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -80,7 +80,11 @@ extern int h_errno; # endif # endif # ifdef HAS_GETPWENT +#ifndef getpwent struct passwd *getpwent (void); +#elif defined (VMS) && defined (my_getpwent) + struct passwd *Perl_my_getpwent (void); +#endif # endif #endif @@ -92,7 +96,9 @@ extern int h_errno; struct group *getgrgid (Gid_t); # endif # ifdef HAS_GETGRENT +#ifndef getgrent struct group *getgrent (void); +#endif # endif #endif @@ -433,6 +439,9 @@ PP(pp_die) SV *tmpsv; STRLEN len; bool multiarg = 0; +#ifdef VMS + VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH); +#endif if (SP - MARK != 1) { dTARGET; do_join(TARG, &PL_sv_no, MARK, SP); @@ -835,24 +844,26 @@ PP(pp_untie) SV *obj = SvRV(mg->mg_obj); GV *gv; CV *cv = NULL; - if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) && - isGV(gv) && (cv = GvCV(gv))) { - PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)gv, mg)); - XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1))); - PUTBACK; - ENTER; - call_sv((SV *)cv, G_VOID); - LEAVE; - SPAGAIN; - } - else if (ckWARN(WARN_UNTIE)) { - if (mg && SvREFCNT(obj) > 1) - Perl_warner(aTHX_ WARN_UNTIE, - "untie attempted while %"UVuf" inner references still exist", - (UV)SvREFCNT(obj) - 1 ) ; + if (obj) { + if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) && + isGV(gv) && (cv = GvCV(gv))) { + PUSHMARK(SP); + XPUSHs(SvTIED_obj((SV*)gv, mg)); + XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1))); + PUTBACK; + ENTER; + call_sv((SV *)cv, G_VOID); + LEAVE; + SPAGAIN; + } + else if (ckWARN(WARN_UNTIE)) { + if (mg && SvREFCNT(obj) > 1) + Perl_warner(aTHX_ packWARN(WARN_UNTIE), + "untie attempted while %"UVuf" inner references still exist", + (UV)SvREFCNT(obj) - 1 ) ; + } } - sv_unmagic(sv, how); + sv_unmagic(sv, how) ; } RETPUSHYES; } @@ -979,18 +990,7 @@ PP(pp_sselect) } /* little endians can use vecs directly */ -#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 -# if SELECT_MIN_BITS > 1 - /* If SELECT_MIN_BITS is greater than one we most probably will want - * to align the sizes with SELECT_MIN_BITS/8 because for example - * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital - * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates - * on (sets/tests/clears bits) is 32 bits. */ - growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8))); -# else - growsize = sizeof(fd_set); -# endif -# else +#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 # ifdef NFDBITS # ifndef NBBY @@ -1001,10 +1001,20 @@ PP(pp_sselect) # else masksize = sizeof(long); /* documented int, everyone seems to use long */ # endif - growsize = maxlen + (masksize - (maxlen % masksize)); Zero(&fd_sets[0], 4, char*); #endif +# if SELECT_MIN_BITS > 1 + /* If SELECT_MIN_BITS is greater than one we most probably will want + * to align the sizes with SELECT_MIN_BITS/8 because for example + * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital + * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates + * on (sets/tests/clears bits) is 32 bits. */ + growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8))); +# else + growsize = sizeof(fd_set); +# endif + sv = SP[4]; if (SvOK(sv)) { value = SvNV(sv); @@ -1129,7 +1139,7 @@ PP(pp_getc) { dSP; dTARGET; GV *gv; - IO *io; + IO *io = NULL; MAGIC *mg; if (MAXARG == 0) @@ -1152,8 +1162,12 @@ PP(pp_getc) SvSetMagicSV_nosteal(TARG, TOPs); RETURN; } - if (!gv || do_eof(gv)) /* make sure we have fp with something */ + if (!gv || do_eof(gv)) { /* make sure we have fp with something */ + if (ckWARN2(WARN_UNOPENED,WARN_CLOSED) + && (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))) + report_evil_fh(gv, io, PL_op->op_type); RETPUSHUNDEF; + } TAINT; sv_setpv(TARG, " "); *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */ @@ -1349,10 +1363,10 @@ PP(pp_leavewrite) name = SvPV_nolen(sv); } if (name && *name) - Perl_warner(aTHX_ WARN_IO, + Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle %s opened only for input", name); else - Perl_warner(aTHX_ WARN_IO, + Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle opened only for input"); } else if (ckWARN(WARN_CLOSED)) @@ -1363,7 +1377,7 @@ PP(pp_leavewrite) else { if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) { if (ckWARN(WARN_IO)) - Perl_warner(aTHX_ WARN_IO, "page overflow"); + Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow"); } if (!do_print(PL_formtarget, fp)) PUSHs(&PL_sv_no); @@ -1422,7 +1436,7 @@ PP(pp_prtf) if (!(io = GvIO(gv))) { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,VMS_RMS_IFI); + SETERRNO(EBADF,RMS$_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { @@ -1435,16 +1449,16 @@ PP(pp_prtf) name = SvPV_nolen(sv); } if (name && *name) - Perl_warner(aTHX_ WARN_IO, + Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle %s opened only for input", name); else - Perl_warner(aTHX_ WARN_IO, + Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle opened only for input"); } else if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); } - SETERRNO(EBADF,IoIFP(io)?VMS_RMS_FAC:VMS_RMS_IFI); + SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; } else { @@ -1514,6 +1528,9 @@ PP(pp_sysread) int fp_utf8; Size_t got = 0; Size_t wanted; + bool charstart = FALSE; + STRLEN charskip = 0; + STRLEN skip = 0; gv = (GV*)*++MARK; if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) @@ -1560,10 +1577,14 @@ PP(pp_sysread) DIE(aTHX_ "Negative length"); wanted = length; + charstart = TRUE; + charskip = 0; + skip = 0; + #ifdef HAS_SOCKET if (PL_op->op_type == OP_RECV) { char namebuf[MAXPATHLEN]; -#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) +#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__) bufsize = sizeof (struct sockaddr_in); #else bufsize = sizeof namebuf; @@ -1665,10 +1686,10 @@ PP(pp_sysread) name = SvPV_nolen(sv); } if (name && *name) - Perl_warner(aTHX_ WARN_IO, + Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle %s opened only for output", name); else - Perl_warner(aTHX_ WARN_IO, + Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle opened only for output"); } goto say_undef; @@ -1680,23 +1701,30 @@ PP(pp_sysread) /* Look at utf8 we got back and count the characters */ char *bend = buffer + count; while (buffer < bend) { - STRLEN skip = UTF8SKIP(buffer); - if (buffer+skip > bend) { + if (charstart) { + skip = UTF8SKIP(buffer); + charskip = 0; + } + if (buffer - charskip + skip > bend) { /* partial character - try for rest of it */ length = skip - (bend-buffer); offset = bend - SvPVX(bufsv); + charstart = FALSE; + charskip += count; goto more_bytes; } else { got++; buffer += skip; + charstart = TRUE; + charskip = 0; } } /* If we have not 'got' the number of _characters_ we 'wanted' get some more provided amount read (count) was what was requested (length) */ if (got < wanted && count == length) { - length = (wanted-got); + length = wanted - got; offset = bend - SvPVX(bufsv); goto more_bytes; } @@ -1846,6 +1874,8 @@ PP(pp_send) if (retval < 0) goto say_undef; SP = ORIGMARK; + if (DO_UTF8(bufsv)) + retval = utf8_length((U8*)buffer, (U8*)buffer + retval); #if Size_t_size > IVSIZE PUSHn(retval); #else @@ -1873,7 +1903,7 @@ PP(pp_eof) if (MAXARG == 0) { if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */ IO *io; - gv = PL_last_in_gv = PL_argvgv; + gv = PL_last_in_gv = GvEGV(PL_argvgv); io = GvIO(gv); if (io && !IoIFP(io)) { if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) { @@ -2047,7 +2077,7 @@ PP(pp_truncate) else { SV *sv = POPs; char *name; - + if (SvTYPE(sv) == SVt_PVGV) { tmpgv = (GV*)sv; /* *main::FRED for example */ goto do_ftruncate; @@ -2080,7 +2110,7 @@ PP(pp_truncate) if (result) RETPUSHYES; if (!errno) - SETERRNO(EBADF,VMS_RMS_IFI); + SETERRNO(EBADF,RMS$_IFI); RETPUSHUNDEF; } #else @@ -2107,7 +2137,7 @@ PP(pp_ioctl) if (!io || !argsv || !IoIFP(io)) { if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,VMS_RMS_IFI); /* well, sort of... */ + SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */ RETPUSHUNDEF; } @@ -2195,7 +2225,7 @@ PP(pp_flock) if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); value = 0; - SETERRNO(EBADF,VMS_RMS_IFI); + SETERRNO(EBADF,RMS$_IFI); } PUSHi(value); RETURN; @@ -2225,7 +2255,7 @@ PP(pp_socket) report_evil_fh(gv, io, PL_op->op_type); if (IoIFP(io)) do_close(gv, FALSE); - SETERRNO(EBADF,VMS_LIB_INVARG); + SETERRNO(EBADF,LIB$_INVARG); RETPUSHUNDEF; } @@ -2261,7 +2291,7 @@ PP(pp_socket) PP(pp_sockpair) { -#ifdef HAS_SOCKETPAIR +#if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET)) dSP; GV *gv1; GV *gv2; @@ -2376,7 +2406,7 @@ PP(pp_bind) nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,VMS_SS_IVCHAN); + SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "bind"); @@ -2406,7 +2436,7 @@ PP(pp_connect) nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,VMS_SS_IVCHAN); + SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "connect"); @@ -2432,7 +2462,7 @@ PP(pp_listen) nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,VMS_SS_IVCHAN); + SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "listen"); @@ -2450,6 +2480,7 @@ PP(pp_accept) struct sockaddr saddr; /* use a struct to avoid alignment problems */ Sock_size_t len = sizeof saddr; int fd; + int fd2; ggv = (GV*)POPs; ngv = (GV*)POPs; @@ -2470,7 +2501,11 @@ PP(pp_accept) if (IoIFP(nstio)) do_close(ngv, FALSE); IoIFP(nstio) = PerlIO_fdopen(fd, "r"); - IoOFP(nstio) = PerlIO_fdopen(fd, "w"); + /* FIXME: we dup(fd) here so that refcounting of fd's does not inhibit + fclose of IoOFP's FILE * - and hence leak memory. + Special treatment of _this_ case of IoIFP != IoOFP seems wrong. + */ + IoOFP(nstio) = PerlIO_fdopen(fd2 = PerlLIO_dup(fd), "w"); IoTYPE(nstio) = IoTYPE_SOCKET; if (!IoIFP(nstio) || !IoOFP(nstio)) { if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio)); @@ -2480,6 +2515,7 @@ PP(pp_accept) } #if defined(HAS_FCNTL) && defined(F_SETFD) fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */ + fcntl(fd2, F_SETFD, fd2 > PL_maxsysfd); /* ensure close-on-exec */ #endif #ifdef EPOC @@ -2493,7 +2529,7 @@ PP(pp_accept) nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type); - SETERRNO(EBADF,VMS_SS_IVCHAN); + SETERRNO(EBADF,SS$_IVCHAN); badexit: RETPUSHUNDEF; @@ -2520,7 +2556,7 @@ PP(pp_shutdown) nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); - SETERRNO(EBADF,VMS_SS_IVCHAN); + SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_sock_func, "shutdown"); @@ -2599,7 +2635,7 @@ PP(pp_ssockopt) nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, optype); - SETERRNO(EBADF,VMS_SS_IVCHAN); + SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; @@ -2672,7 +2708,7 @@ PP(pp_getpeername) nuts: if (ckWARN(WARN_CLOSED)) report_evil_fh(gv, io, optype); - SETERRNO(EBADF,VMS_SS_IVCHAN); + SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; @@ -2699,12 +2735,12 @@ PP(pp_stat) if (PL_op->op_flags & OPf_REF) { gv = cGVOP_gv; if (PL_op->op_type == OP_LSTAT) { - if (PL_laststype != OP_LSTAT) - Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat"); - if (ckWARN(WARN_IO) && gv != PL_defgv) - Perl_warner(aTHX_ WARN_IO, + if (gv != PL_defgv) { + if (ckWARN(WARN_IO)) + Perl_warner(aTHX_ packWARN(WARN_IO), "lstat() on filehandle %s", GvENAME(gv)); - /* Perl_my_lstat (-l) croak's on filehandle, why warn here? */ + } else if (PL_laststype != OP_LSTAT) + Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat"); } do_fstat: @@ -2729,6 +2765,9 @@ PP(pp_stat) } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { gv = (GV*)SvRV(sv); + if (PL_op->op_type == OP_LSTAT && ckWARN(WARN_IO)) + Perl_warner(aTHX_ packWARN(WARN_IO), + "lstat() on filehandle %s", GvENAME(gv)); goto do_fstat; } sv_setpv(PL_statname, SvPV(sv,n_a)); @@ -2742,7 +2781,7 @@ PP(pp_stat) PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache); if (PL_laststatval < 0) { if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n')) - Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat"); + Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); max = 0; } } @@ -3275,7 +3314,7 @@ PP(pp_fttext) gv = cGVOP_gv; report_evil_fh(gv, GvIO(gv), PL_op->op_type); } - SETERRNO(EBADF,VMS_RMS_IFI); + SETERRNO(EBADF,RMS$_IFI); RETPUSHUNDEF; } } @@ -3284,10 +3323,11 @@ PP(pp_fttext) really_filename: PL_statgv = Nullgv; PL_laststatval = -1; + PL_laststype = OP_STAT; sv_setpv(PL_statname, SvPV(sv, n_a)); if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) { if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n')) - Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open"); + Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); RETPUSHUNDEF; } PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache); @@ -3391,8 +3431,9 @@ PP(pp_chdir) deprecate("chdir('') or chdir(undef) as chdir()"); tmps = SvPV(*svp, n_a); } - else { + else { PUSHi(0); + TAINT_PROPER("chdir"); RETURN; } } @@ -3494,9 +3535,8 @@ PP(pp_rename) PP(pp_link) { - dSP; #ifdef HAS_LINK - dTARGET; + dSP; dTARGET; STRLEN n_a; char *tmps2 = POPpx; char *tmps = SvPV(TOPs, n_a); @@ -3721,7 +3761,7 @@ PP(pp_open_dir) RETPUSHYES; nope: if (!errno) - SETERRNO(EBADF,VMS_RMS_DIR); + SETERRNO(EBADF,RMS$_DIR); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "opendir"); @@ -3776,7 +3816,7 @@ PP(pp_readdir) nope: if (!errno) - SETERRNO(EBADF,VMS_RMS_ISI); + SETERRNO(EBADF,RMS$_ISI); if (GIMME == G_ARRAY) RETURN; else @@ -3807,7 +3847,7 @@ PP(pp_telldir) RETURN; nope: if (!errno) - SETERRNO(EBADF,VMS_RMS_ISI); + SETERRNO(EBADF,RMS$_ISI); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "telldir"); @@ -3830,7 +3870,7 @@ PP(pp_seekdir) RETPUSHYES; nope: if (!errno) - SETERRNO(EBADF,VMS_RMS_ISI); + SETERRNO(EBADF,RMS$_ISI); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "seekdir"); @@ -3851,7 +3891,7 @@ PP(pp_rewinddir) RETPUSHYES; nope: if (!errno) - SETERRNO(EBADF,VMS_RMS_ISI); + SETERRNO(EBADF,RMS$_ISI); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "rewinddir"); @@ -3881,7 +3921,7 @@ PP(pp_closedir) RETPUSHYES; nope: if (!errno) - SETERRNO(EBADF,VMS_RMS_IFI); + SETERRNO(EBADF,RMS$_IFI); RETPUSHUNDEF; #else DIE(aTHX_ PL_no_dir_func, "closedir"); @@ -3904,8 +3944,11 @@ PP(pp_fork) RETSETUNDEF; if (!childpid) { /*SUPPRESS 560*/ - if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV))) + if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV))) { + SvREADONLY_off(GvSV(tmpgv)); sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid()); + SvREADONLY_on(GvSV(tmpgv)); + } hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */ } PUSHi(childpid); @@ -3994,12 +4037,22 @@ PP(pp_system) int pp[2]; I32 did_pipes = 0; - if (SP - MARK == 1) { - if (PL_tainting) { - (void)SvPV_nolen(TOPs); /* stringify for taint check */ - TAINT_ENV(); + if (PL_tainting) { + TAINT_ENV(); + while (++MARK <= SP) { + (void)SvPV_nolen(*MARK); /* stringify for taint check */ + if (PL_tainted) + break; + } + MARK = ORIGMARK; + /* XXX Remove warning at end of deprecation cycle --RD 2002-02 */ + if (SP - MARK == 1) { TAINT_PROPER("system"); } + else if (ckWARN2(WARN_TAINT, WARN_DEPRECATED)) { + Perl_warner(aTHX_ packWARN2(WARN_TAINT, WARN_DEPRECATED), + "Use of tainted arguments in %s is deprecated", "system"); + } } PERL_FLUSHALL_FOR_CHILD; #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO) @@ -4007,7 +4060,7 @@ PP(pp_system) Pid_t childpid; int status; Sigsave_t ihand,qhand; /* place to save signals during system() */ - + if (PerlProc_pipe(pp) >= 0) did_pipes = 1; while ((childpid = PerlProc_fork()) == -1) { @@ -4043,7 +4096,7 @@ PP(pp_system) if (did_pipes) { int errkid; int n = 0, n1; - + while (n < sizeof(int)) { n1 = PerlLIO_read(pp[0], (void*)(((char*)&errkid)+n), @@ -4108,6 +4161,23 @@ PP(pp_exec) I32 value; STRLEN n_a; + if (PL_tainting) { + TAINT_ENV(); + while (++MARK <= SP) { + (void)SvPV_nolen(*MARK); /* stringify for taint check */ + if (PL_tainted) + break; + } + MARK = ORIGMARK; + /* XXX Remove warning at end of deprecation cycle --RD 2002-02 */ + if (SP - MARK == 1) { + TAINT_PROPER("exec"); + } + else if (ckWARN2(WARN_TAINT, WARN_DEPRECATED)) { + Perl_warner(aTHX_ packWARN2(WARN_TAINT, WARN_DEPRECATED), + "Use of tainted arguments in %s is deprecated", "exec"); + } + } PERL_FLUSHALL_FOR_CHILD; if (PL_op->op_flags & OPf_STACKED) { SV *really = *++MARK; @@ -4127,11 +4197,6 @@ PP(pp_exec) # endif #endif else { - if (PL_tainting) { - (void)SvPV_nolen(*SP); /* stringify for taint check */ - TAINT_ENV(); - TAINT_PROPER("exec"); - } #ifdef VMS value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a)); #else @@ -4280,6 +4345,10 @@ PP(pp_time) it's supported. --AD 9/96. */ +#ifdef __BEOS__ +# define HZ 1000000 +#endif + #ifndef HZ # ifdef CLK_TCK # define HZ CLK_TCK @@ -4555,21 +4624,23 @@ PP(pp_ghostent) register char **elem; register SV *sv; #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */ - struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int); - struct hostent *PerlSock_gethostbyname(Netdb_name_t); - struct hostent *PerlSock_gethostent(void); + struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int); + struct hostent *gethostbyname(Netdb_name_t); + struct hostent *gethostent(void); #endif struct hostent *hent; unsigned long len; STRLEN n_a; EXTEND(SP, 10); - if (which == OP_GHBYNAME) + if (which == OP_GHBYNAME) { #ifdef HAS_GETHOSTBYNAME - hent = PerlSock_gethostbyname(POPpbytex); + char* name = POPpbytex; + hent = PerlSock_gethostbyname(name); #else DIE(aTHX_ PL_no_sock_func, "gethostbyname"); #endif + } else if (which == OP_GHBYADDR) { #ifdef HAS_GETHOSTBYADDR int addrtype = POPi; @@ -4590,8 +4661,14 @@ PP(pp_ghostent) #endif #ifdef HOST_NOT_FOUND - if (!hent) - STATUS_NATIVE_SET(h_errno); + if (!hent) { +#ifdef USE_REENTRANT_API +# ifdef USE_GETHOSTENT_ERRNO + h_errno = PL_reentrant_buffer->_gethostent_errno; +# endif +#endif + STATUS_NATIVE_SET(h_errno); + } #endif if (GIMME != G_ARRAY) { @@ -4664,19 +4741,21 @@ PP(pp_gnetent) register char **elem; register SV *sv; #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */ - struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int); - struct netent *PerlSock_getnetbyname(Netdb_name_t); - struct netent *PerlSock_getnetent(void); + struct netent *getnetbyaddr(Netdb_net_t, int); + struct netent *getnetbyname(Netdb_name_t); + struct netent *getnetent(void); #endif struct netent *nent; STRLEN n_a; - if (which == OP_GNBYNAME) + if (which == OP_GNBYNAME){ #ifdef HAS_GETNETBYNAME - nent = PerlSock_getnetbyname(POPpbytex); + char *name = POPpbytex; + nent = PerlSock_getnetbyname(name); #else DIE(aTHX_ PL_no_sock_func, "getnetbyname"); #endif + } else if (which == OP_GNBYADDR) { #ifdef HAS_GETNETBYADDR int addrtype = POPi; @@ -4693,6 +4772,17 @@ PP(pp_gnetent) DIE(aTHX_ PL_no_sock_func, "getnetent"); #endif +#ifdef HOST_NOT_FOUND + if (!nent) { +#ifdef USE_REENTRANT_API +# ifdef USE_GETNETENT_ERRNO + h_errno = PL_reentrant_buffer->_getnetent_errno; +# endif +#endif + STATUS_NATIVE_SET(h_errno); + } +#endif + EXTEND(SP, 4); if (GIMME != G_ARRAY) { PUSHs(sv = sv_newmortal()); @@ -4752,25 +4842,29 @@ PP(pp_gprotoent) register char **elem; register SV *sv; #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */ - struct protoent *PerlSock_getprotobyname(Netdb_name_t); - struct protoent *PerlSock_getprotobynumber(int); - struct protoent *PerlSock_getprotoent(void); + struct protoent *getprotobyname(Netdb_name_t); + struct protoent *getprotobynumber(int); + struct protoent *getprotoent(void); #endif struct protoent *pent; STRLEN n_a; - if (which == OP_GPBYNAME) + if (which == OP_GPBYNAME) { #ifdef HAS_GETPROTOBYNAME - pent = PerlSock_getprotobyname(POPpbytex); + char* name = POPpbytex; + pent = PerlSock_getprotobyname(name); #else DIE(aTHX_ PL_no_sock_func, "getprotobyname"); #endif - else if (which == OP_GPBYNUMBER) + } + else if (which == OP_GPBYNUMBER) { #ifdef HAS_GETPROTOBYNUMBER - pent = PerlSock_getprotobynumber(POPi); + int number = POPi; + pent = PerlSock_getprotobynumber(number); #else - DIE(aTHX_ PL_no_sock_func, "getprotobynumber"); + DIE(aTHX_ PL_no_sock_func, "getprotobynumber"); #endif + } else #ifdef HAS_GETPROTOENT pent = PerlSock_getprotoent(); @@ -4835,9 +4929,9 @@ PP(pp_gservent) register char **elem; register SV *sv; #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */ - struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t); - struct servent *PerlSock_getservbyport(int, Netdb_name_t); - struct servent *PerlSock_getservent(void); + struct servent *getservbyname(Netdb_name_t, Netdb_name_t); + struct servent *getservbyport(int, Netdb_name_t); + struct servent *getservent(void); #endif struct servent *sent; STRLEN n_a; @@ -5091,10 +5185,16 @@ PP(pp_gpwent) switch (which) { case OP_GPWNAM: - pwent = getpwnam(POPpbytex); - break; + { + char* name = POPpbytex; + pwent = getpwnam(name); + } + break; case OP_GPWUID: - pwent = getpwuid((Uid_t)POPi); + { + Uid_t uid = POPi; + pwent = getpwuid(uid); + } break; case OP_GPWENT: # ifdef HAS_GETPWENT @@ -5291,10 +5391,14 @@ PP(pp_ggrent) struct group *grent; STRLEN n_a; - if (which == OP_GGRNAM) - grent = (struct group *)getgrnam(POPpbytex); - else if (which == OP_GGRGID) - grent = (struct group *)getgrgid(POPi); + if (which == OP_GGRNAM) { + char* name = POPpbytex; + grent = (struct group *)getgrnam(name); + } + else if (which == OP_GGRGID) { + Gid_t gid = POPi; + grent = (struct group *)getgrgid(gid); + } else #ifdef HAS_GETGRENT grent = (struct group *)getgrent(); @@ -5326,12 +5430,22 @@ PP(pp_ggrent) PUSHs(sv = sv_mortalcopy(&PL_sv_no)); sv_setiv(sv, (IV)grent->gr_gid); +#if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API)) PUSHs(sv = sv_mortalcopy(&PL_sv_no)); + /* In UNICOS/mk (_CRAYMPP) the multithreading + * versions (getgrnam_r, getgrgid_r) + * seem to return an illegal pointer + * as the group members list, gr_mem. + * getgrent() doesn't even have a _r version + * but the gr_mem is poisonous anyway. + * So yes, you cannot get the list of group + * members if building multithreaded in UNICOS/mk. */ for (elem = grent->gr_mem; elem && *elem; elem++) { sv_catpv(sv, *elem); if (elem[1]) sv_catpvn(sv, " ", 1); } +#endif } RETURN;