X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=bd2334ad48c8408a2c3424ba680d1eda1b43cb95;hb=abc0a0153433fe6596e1ca3a6b5572dc424d0f11;hp=b241a0e9312690e15b34019f0522c9ea8cdd778b;hpb=a385c4e7bdc7cbc9f50e4f013b7a373e7450e199;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_sys.c b/pp_sys.c index b241a0e..bd2334a 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 @@ -167,6 +173,8 @@ static char zero_but_true[ZBTLEN + 1] = "0 but true"; # define FD_CLOEXEC 1 /* NeXT needs this */ #endif +#include "reentr.h" + #undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */ #undef PERL_EFF_ACCESS_W_OK #undef PERL_EFF_ACCESS_X_OK @@ -315,10 +323,13 @@ PP(pp_backtick) ; } else if (gimme == G_SCALAR) { + SV *oldrs = PL_rs; + PL_rs = &PL_sv_undef; sv_setpv(TARG, ""); /* note that this preserves previous buffer */ while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch) /*SUPPRESS 530*/ ; + PL_rs = oldrs; XPUSHs(TARG); SvTAINTED_on(TARG); } @@ -433,6 +444,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); @@ -596,6 +610,7 @@ PP(pp_pipe_op) IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"); IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"); + IoOFP(rstio) = IoIFP(rstio); IoIFP(wstio) = IoOFP(wstio); IoTYPE(rstio) = IoTYPE_RDONLY; IoTYPE(wstio) = IoTYPE_WRONLY; @@ -722,11 +737,16 @@ PP(pp_binmode) RETPUSHUNDEF; } + PUTBACK; if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp), - (discp) ? SvPV_nolen(discp) : Nullch)) + (discp) ? SvPV_nolen(discp) : Nullch)) { + SPAGAIN; RETPUSHYES; - else + } + else { + SPAGAIN; RETPUSHUNDEF; + } } PP(pp_tie) @@ -776,7 +796,7 @@ PP(pp_tie) ENTER; PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); - EXTEND(SP,items); + EXTEND(SP,(I32)items); while (items--) PUSHs(*MARK++); PUTBACK; @@ -794,7 +814,7 @@ PP(pp_tie) ENTER; PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); - EXTEND(SP,items); + EXTEND(SP,(I32)items); while (items--) PUSHs(*MARK++); PUTBACK; @@ -808,11 +828,11 @@ PP(pp_tie) sv_unmagic(varsv, how); /* Croak if a self-tie on an aggregate is attempted. */ if (varsv == SvRV(sv) && - (SvTYPE(sv) == SVt_PVAV || - SvTYPE(sv) == SVt_PVHV)) + (SvTYPE(varsv) == SVt_PVAV || + SvTYPE(varsv) == SVt_PVHV)) Perl_croak(aTHX_ "Self-ties of arrays and hashes are not supported"); - sv_magic(varsv, sv, how, Nullch, 0); + sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0); } LEAVE; SP = PL_stack_base + markoff; @@ -835,24 +855,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 +1001,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 +1012,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 +1150,7 @@ PP(pp_getc) { dSP; dTARGET; GV *gv; - IO *io; + IO *io = NULL; MAGIC *mg; if (MAXARG == 0) @@ -1152,8 +1173,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 +1374,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 +1388,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 +1447,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 +1460,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 +1539,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 +1588,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; @@ -1572,7 +1604,7 @@ PP(pp_sysread) if (bufsize >= 256) bufsize = 255; #endif - buffer = SvGROW(bufsv, length+1); + buffer = SvGROW(bufsv, (STRLEN)(length+1)); /* 'offset' means 'flags' here */ count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset, (struct sockaddr *)namebuf, &bufsize); @@ -1605,7 +1637,7 @@ PP(pp_sysread) blen = sv_len_utf8(bufsv); } if (offset < 0) { - if (-offset > blen) + if (-offset > (int)blen) DIE(aTHX_ "Offset outside string"); offset += blen; } @@ -1615,7 +1647,7 @@ PP(pp_sysread) } more_bytes: bufsize = SvCUR(bufsv); - buffer = SvGROW(bufsv, length+offset+1); + buffer = SvGROW(bufsv, (STRLEN)(length+offset+1)); if (offset > bufsize) { /* Zero any newly allocated space */ Zero(buffer+bufsize, offset-bufsize, char); } @@ -1665,10 +1697,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 +1712,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; } @@ -1798,10 +1837,10 @@ PP(pp_send) if (MARK < SP) { offset = SvIVx(*++MARK); if (offset < 0) { - if (-offset > blen) + if (-offset > (IV)blen) DIE(aTHX_ "Offset outside string"); offset += blen; - } else if (offset >= blen && blen > 0) + } else if (offset >= (IV)blen && blen > 0) DIE(aTHX_ "Offset outside string"); } else offset = 0; @@ -1846,6 +1885,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 +1914,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) { @@ -2012,7 +2053,7 @@ PP(pp_truncate) /* XXX Configure probe for the length type of *truncate() needed XXX */ Off_t len; -#if Size_t_size > IVSIZE +#if Off_t_size > IVSIZE len = (Off_t)POPn; #else len = (Off_t)POPi; @@ -2047,7 +2088,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 +2121,7 @@ PP(pp_truncate) if (result) RETPUSHYES; if (!errno) - SETERRNO(EBADF,VMS_RMS_IFI); + SETERRNO(EBADF,RMS$_IFI); RETPUSHUNDEF; } #else @@ -2107,7 +2148,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; } @@ -2137,15 +2178,14 @@ PP(pp_ioctl) DIE(aTHX_ "ioctl is not implemented"); #endif else -#ifdef HAS_FCNTL +#ifndef HAS_FCNTL + DIE(aTHX_ "fcntl is not implemented"); +#else #if defined(OS2) && defined(__EMX__) retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s); #else retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s); #endif -#else - DIE(aTHX_ "fcntl is not implemented"); -#endif if (SvPOK(argsv)) { if (s[SvCUR(argsv)] != 17) @@ -2163,6 +2203,7 @@ PP(pp_ioctl) else { PUSHp(zero_but_true, ZBTLEN); } +#endif RETURN; } @@ -2195,7 +2236,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 +2266,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 +2302,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 +2417,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 +2447,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 +2473,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 +2491,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; @@ -2464,14 +2506,17 @@ PP(pp_accept) goto nuts; nstio = GvIOn(ngv); - if (IoIFP(nstio)) - do_close(ngv, FALSE); - fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len); if (fd < 0) goto badexit; + 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)); @@ -2481,6 +2526,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 @@ -2494,7 +2540,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; @@ -2521,7 +2567,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"); @@ -2600,7 +2646,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; @@ -2673,7 +2719,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; @@ -2700,12 +2746,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: @@ -2730,6 +2776,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)); @@ -2743,7 +2792,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; } } @@ -3276,7 +3325,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; } } @@ -3285,10 +3334,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); @@ -3392,8 +3442,9 @@ PP(pp_chdir) deprecate("chdir('') or chdir(undef) as chdir()"); tmps = SvPV(*svp, n_a); } - else { + else { PUSHi(0); + TAINT_PROPER("chdir"); RETURN; } } @@ -3495,9 +3546,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); @@ -3882,7 +3932,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"); @@ -3905,8 +3955,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); @@ -3992,104 +4045,127 @@ PP(pp_system) I32 value; STRLEN n_a; int result; - 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) { + int some_arg_tainted = 0; + TAINT_ENV(); + while (++MARK <= SP) { + (void)SvPV_nolen(*MARK); /* stringify for taint check */ + if (PL_tainted) { + some_arg_tainted = 1; + break; + } + } + MARK = ORIGMARK; + /* XXX Remove warning at end of deprecation cycle --RD 2002-02 */ + if (SP - MARK == 1) { TAINT_PROPER("system"); } + else if (some_arg_tainted && 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) { - 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) { - if (errno != EAGAIN) { - value = -1; - SP = ORIGMARK; - PUSHi(value); - if (did_pipes) { - PerlLIO_close(pp[0]); - PerlLIO_close(pp[1]); - } - RETURN; - } - sleep(5); - } - if (childpid > 0) { - if (did_pipes) - PerlLIO_close(pp[1]); + Pid_t childpid; + int pp[2]; + + if (PerlProc_pipe(pp) >= 0) + did_pipes = 1; + while ((childpid = PerlProc_fork()) == -1) { + if (errno != EAGAIN) { + value = -1; + SP = ORIGMARK; + PUSHi(value); + if (did_pipes) { + PerlLIO_close(pp[0]); + PerlLIO_close(pp[1]); + } + RETURN; + } + sleep(5); + } + if (childpid > 0) { + Sigsave_t ihand,qhand; /* place to save signals during system() */ + int status; + + if (did_pipes) + PerlLIO_close(pp[1]); #ifndef PERL_MICRO - rsignal_save(SIGINT, SIG_IGN, &ihand); - rsignal_save(SIGQUIT, SIG_IGN, &qhand); + rsignal_save(SIGINT, SIG_IGN, &ihand); + rsignal_save(SIGQUIT, SIG_IGN, &qhand); #endif - do { - result = wait4pid(childpid, &status, 0); - } while (result == -1 && errno == EINTR); + do { + result = wait4pid(childpid, &status, 0); + } while (result == -1 && errno == EINTR); #ifndef PERL_MICRO - (void)rsignal_restore(SIGINT, &ihand); - (void)rsignal_restore(SIGQUIT, &qhand); -#endif - STATUS_NATIVE_SET(result == -1 ? -1 : status); - do_execfree(); /* free any memory child malloced on fork */ - SP = ORIGMARK; - if (did_pipes) { - int errkid; - int n = 0, n1; - - while (n < sizeof(int)) { - n1 = PerlLIO_read(pp[0], - (void*)(((char*)&errkid)+n), - (sizeof(int)) - n); - if (n1 <= 0) - break; - n += n1; - } - PerlLIO_close(pp[0]); - if (n) { /* Error */ - if (n != sizeof(int)) - DIE(aTHX_ "panic: kid popen errno read"); - errno = errkid; /* Propagate errno from kid */ - STATUS_CURRENT = -1; - } - } - PUSHi(STATUS_CURRENT); - RETURN; - } - if (did_pipes) { - PerlLIO_close(pp[0]); + (void)rsignal_restore(SIGINT, &ihand); + (void)rsignal_restore(SIGQUIT, &qhand); +#endif + STATUS_NATIVE_SET(result == -1 ? -1 : status); + do_execfree(); /* free any memory child malloced on fork */ + SP = ORIGMARK; + if (did_pipes) { + int errkid; + int n = 0, n1; + + while (n < sizeof(int)) { + n1 = PerlLIO_read(pp[0], + (void*)(((char*)&errkid)+n), + (sizeof(int)) - n); + if (n1 <= 0) + break; + n += n1; + } + PerlLIO_close(pp[0]); + if (n) { /* Error */ + if (n != sizeof(int)) + DIE(aTHX_ "panic: kid popen errno read"); + errno = errkid; /* Propagate errno from kid */ + STATUS_CURRENT = -1; + } + } + PUSHi(STATUS_CURRENT); + RETURN; + } + if (did_pipes) { + PerlLIO_close(pp[0]); #if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(pp[1], F_SETFD, FD_CLOEXEC); + fcntl(pp[1], F_SETFD, FD_CLOEXEC); #endif - } - } - if (PL_op->op_flags & OPf_STACKED) { - SV *really = *++MARK; - value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes); - } - else if (SP - MARK != 1) - value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes); - else { - value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes); + } + if (PL_op->op_flags & OPf_STACKED) { + SV *really = *++MARK; + value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes); + } + else if (SP - MARK != 1) + value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes); + else { + value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes); + } + PerlProc__exit(-1); } - PerlProc__exit(-1); #else /* ! FORK or VMS or OS/2 */ PL_statusvalue = 0; result = 0; if (PL_op->op_flags & OPf_STACKED) { SV *really = *++MARK; +# ifdef WIN32 + value = (I32)do_aspawn(really, MARK, SP); +# else value = (I32)do_aspawn(really, (void **)MARK, (void **)SP); +# endif } - else if (SP - MARK != 1) + else if (SP - MARK != 1) { +# ifdef WIN32 + value = (I32)do_aspawn(Nullsv, MARK, SP); +# else value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP); +# endif + } else { value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a)); } @@ -4109,6 +4185,26 @@ PP(pp_exec) I32 value; STRLEN n_a; + if (PL_tainting) { + int some_arg_tainted = 0; + TAINT_ENV(); + while (++MARK <= SP) { + (void)SvPV_nolen(*MARK); /* stringify for taint check */ + if (PL_tainted) { + some_arg_tainted = 1; + break; + } + } + MARK = ORIGMARK; + /* XXX Remove warning at end of deprecation cycle --RD 2002-02 */ + if (SP - MARK == 1) { + TAINT_PROPER("exec"); + } + else if (some_arg_tainted && 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; @@ -4128,11 +4224,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 @@ -4281,6 +4372,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 @@ -4556,21 +4651,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; @@ -4591,8 +4688,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) { @@ -4665,19 +4768,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; @@ -4694,6 +4799,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()); @@ -4753,25 +4869,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(); @@ -4836,9 +4956,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; @@ -4859,7 +4979,7 @@ PP(pp_gservent) else if (which == OP_GSBYPORT) { #ifdef HAS_GETSERVBYPORT char *proto = POPpbytex; - unsigned short port = POPu; + unsigned short port = (unsigned short)POPu; #ifdef HAS_HTONS port = PerlSock_htons(port); @@ -5092,14 +5212,23 @@ 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 pwent = getpwent(); +#ifdef POSIX_BC /* In some cases pw_passwd has invalid addresses */ + if (pwent) pwent = getpwnam(pwent->pw_name); +#endif # else DIE(aTHX_ PL_no_func, "getpwent"); # endif @@ -5292,10 +5421,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(); @@ -5327,12 +5460,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;