X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=6ed8e0a35070e68ca93e8c3f6260235042865e9f;hb=7a9e22343ee2c409475baf99c2f838dc7fc1f7b8;hp=826a5888e288ff749695a9904a72e8e30c0ce10d;hpb=0a0ada86d5873275d2ecec5cb3ffc5cb284ca30d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_sys.c b/pp_sys.c index 826a588..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. @@ -49,6 +49,10 @@ extern "C" int syscall(unsigned long,...); # include #endif +#ifdef NETWARE +NETDB_DEFINE_CONTEXT +#endif + #ifdef HAS_SELECT # ifdef I_SYS_SELECT # include @@ -76,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 @@ -88,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 @@ -100,11 +110,6 @@ extern int h_errno; # endif #endif -/* Put this after #includes because fork and vfork prototypes may conflict. */ -#ifndef HAS_VFORK -# define vfork fork -#endif - #ifdef HAS_CHSIZE # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */ # undef my_chsize @@ -274,6 +279,9 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) #endif #if !defined(PERL_EFF_ACCESS_R_OK) +/* With it or without it: anyway you get a warning: either that + it is unused, or it is declared static and never defined. + */ STATIC int S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) { @@ -387,15 +395,6 @@ PP(pp_glob) return result; } -#if 0 /* XXX never used! */ -PP(pp_indread) -{ - STRLEN n_a; - PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO); - return do_readline(); -} -#endif - PP(pp_rcatline) { PL_last_in_gv = cGVOP_gv; @@ -440,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); @@ -475,7 +477,7 @@ PP(pp_die) sv_setsv(error,*PL_stack_sp--); } } - DIE(aTHX_ Nullch); + DIE(aTHX_ Nullformat); } else { if (SvPOK(error) && SvCUR(error)) @@ -499,6 +501,7 @@ PP(pp_open) dTARGET; GV *gv; SV *sv; + IO *io; char *tmps; STRLEN len; MAGIC *mg; @@ -507,13 +510,13 @@ PP(pp_open) gv = (GV *)*++MARK; if (!isGV(gv)) DIE(aTHX_ PL_no_usym, "filehandle"); - if (GvIOp(gv)) + if ((io = GvIOp(gv))) IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; - if ((mg = SvTIED_mg((SV*)gv, 'q'))) { + if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { /* Method's args are same as ours ... */ /* ... except handle is replaced by the object */ - *MARK-- = SvTIED_obj((SV*)gv, mg); + *MARK-- = SvTIED_obj((SV*)io, mg); PUSHMARK(MARK); PUTBACK; ENTER; @@ -546,6 +549,7 @@ PP(pp_close) { dSP; GV *gv; + IO *io; MAGIC *mg; if (MAXARG == 0) @@ -553,9 +557,11 @@ PP(pp_close) else gv = (GV*)POPs; - if ((mg = SvTIED_mg((SV*)gv, 'q'))) { + if (gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)gv, mg)); + XPUSHs(SvTIED_obj((SV*)io, mg)); PUTBACK; ENTER; call_method("CLOSE", G_SCALAR); @@ -570,8 +576,8 @@ PP(pp_close) PP(pp_pipe_op) { - dSP; #ifdef HAS_PIPE + dSP; GV *rgv; GV *wgv; register IO *rstio; @@ -635,9 +641,11 @@ PP(pp_fileno) RETPUSHUNDEF; gv = (GV*)POPs; - if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) { + if (gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)gv, mg)); + XPUSHs(SvTIED_obj((SV*)io, mg)); PUTBACK; ENTER; call_method("FILENO", G_SCALAR); @@ -662,9 +670,9 @@ PP(pp_fileno) PP(pp_umask) { dSP; dTARGET; +#ifdef HAS_UMASK Mode_t anum; -#ifdef HAS_UMASK if (MAXARG < 1) { anum = PerlLIO_umask(0); (void)PerlLIO_umask(anum); @@ -692,8 +700,6 @@ PP(pp_binmode) PerlIO *fp; MAGIC *mg; SV *discp = Nullsv; - STRLEN len = 0; - char *names = NULL; if (MAXARG < 1) RETPUSHUNDEF; @@ -703,9 +709,11 @@ PP(pp_binmode) gv = (GV*)POPs; - if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) { + if (gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)gv, mg)); + XPUSHs(SvTIED_obj((SV*)io, mg)); if (discp) XPUSHs(discp); PUTBACK; @@ -723,10 +731,6 @@ PP(pp_binmode) RETPUSHUNDEF; } - if (discp) { - names = SvPV(discp,len); - } - if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp), (discp) ? SvPV_nolen(discp) : Nullch)) RETPUSHYES; @@ -744,7 +748,7 @@ PP(pp_tie) SV *sv; I32 markoff = MARK - PL_stack_base; char *methname; - int how = 'P'; + int how = PERL_MAGIC_tied; U32 items; STRLEN n_a; @@ -752,22 +756,28 @@ PP(pp_tie) switch(SvTYPE(varsv)) { case SVt_PVHV: methname = "TIEHASH"; + HvEITER((HV *)varsv) = Null(HE *); break; case SVt_PVAV: methname = "TIEARRAY"; break; case SVt_PVGV: -#ifdef GV_SHARED_CHECK - if (GvSHARED((GV*)varsv)) { - Perl_croak(aTHX_ "Attempt to tie shared GV"); +#ifdef GV_UNIQUE_CHECK + if (GvUNIQUE((GV*)varsv)) { + Perl_croak(aTHX_ "Attempt to tie unique GV"); } #endif methname = "TIEHANDLE"; - how = 'q'; + how = PERL_MAGIC_tiedscalar; + /* For tied filehandles, we apply tiedscalar magic to the IO + slot of the GP rather than the GV itself. AMS 20010812 */ + if (!GvIOp(varsv)) + GvIOp(varsv) = newIO(); + varsv = (SV *)GvIOp(varsv); break; default: methname = "TIESCALAR"; - how = 'q'; + how = PERL_MAGIC_tiedscalar; break; } items = SP - MARK++; @@ -822,42 +832,52 @@ PP(pp_tie) PP(pp_untie) { dSP; + MAGIC *mg; SV *sv = POPs; - char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q'; + char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) + ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; + + if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv))) + RETPUSHYES; - MAGIC * mg ; - if ((mg = SvTIED_mg(sv, how))) { + if ((mg = SvTIED_mg(sv, how))) { 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; } PP(pp_tied) { dSP; - SV *sv = POPs; - char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q'; MAGIC *mg; + SV *sv = POPs; + char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) + ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; + + if (SvTYPE(sv) == SVt_PVGV && !(sv = (SV *)GvIOp(sv))) + RETPUSHUNDEF; if ((mg = SvTIED_mg(sv, how))) { SV *osv = SvTIED_obj(sv, mg); @@ -919,8 +939,8 @@ PP(pp_dbmopen) } if (sv_isobject(TOPs)) { - sv_unmagic((SV *) hv, 'P'); - sv_magic((SV*)hv, TOPs, 'P', Nullch, 0); + sv_unmagic((SV *) hv, PERL_MAGIC_tied); + sv_magic((SV*)hv, TOPs, PERL_MAGIC_tied, Nullch, 0); } LEAVE; RETURN; @@ -933,8 +953,8 @@ PP(pp_dbmclose) PP(pp_sselect) { - dSP; dTARGET; #ifdef HAS_SELECT + dSP; dTARGET; register I32 i; register I32 j; register char *s; @@ -970,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 @@ -992,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); @@ -1120,6 +1139,7 @@ PP(pp_getc) { dSP; dTARGET; GV *gv; + IO *io = NULL; MAGIC *mg; if (MAXARG == 0) @@ -1127,10 +1147,12 @@ PP(pp_getc) else gv = (GV*)POPs; - if ((mg = SvTIED_mg((SV*)gv, 'q'))) { + if (gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { I32 gimme = GIMME_V; PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)gv, mg)); + XPUSHs(SvTIED_obj((SV*)io, mg)); PUTBACK; ENTER; call_method("GETC", gimme); @@ -1140,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 */ @@ -1337,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)) @@ -1351,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); @@ -1384,7 +1410,9 @@ PP(pp_prtf) else gv = PL_defoutgv; - if ((mg = SvTIED_mg((SV*)gv, 'q'))) { + if (gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { if (MARK == ORIGMARK) { MEXTEND(SP, 1); ++MARK; @@ -1392,7 +1420,7 @@ PP(pp_prtf) ++SP; } PUSHMARK(MARK - 1); - *MARK = SvTIED_obj((SV*)gv, mg); + *MARK = SvTIED_obj((SV*)io, mg); PUTBACK; ENTER; call_method("PRINTF", G_SCALAR); @@ -1421,10 +1449,10 @@ 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)) @@ -1500,15 +1528,19 @@ 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) && - (mg = SvTIED_mg((SV*)gv, 'q'))) + if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) + && gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { SV *sv; PUSHMARK(MARK-1); - *MARK = SvTIED_obj((SV*)gv, mg); + *MARK = SvTIED_obj((SV*)io, mg); ENTER; call_method("READ", G_SCALAR); LEAVE; @@ -1533,7 +1565,7 @@ PP(pp_sysread) io = GvIO(gv); if (!io || !IoIFP(io)) goto say_undef; - if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTE) { + if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) { buffer = SvPVutf8_force(bufsv, blen); /* UTF8 may not have been set if they are all low bytes */ SvUTF8_on(bufsv); @@ -1545,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; @@ -1650,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; @@ -1661,27 +1697,34 @@ PP(pp_sysread) SvCUR_set(bufsv, count+(buffer - SvPVX(bufsv))); *SvEND(bufsv) = '\0'; (void)SvPOK_only(bufsv); - if (fp_utf8 && !IN_BYTE) { + if (fp_utf8 && !IN_BYTES) { /* 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; } @@ -1729,11 +1772,14 @@ PP(pp_send) MAGIC *mg; gv = (GV*)*++MARK; - if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) { + if (PL_op->op_type == OP_SYSWRITE + && gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { SV *sv; PUSHMARK(MARK-1); - *MARK = SvTIED_obj((SV*)gv, mg); + *MARK = SvTIED_obj((SV*)io, mg); ENTER; call_method("WRITE", G_SCALAR); LEAVE; @@ -1828,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 @@ -1849,12 +1897,13 @@ PP(pp_eof) { dSP; GV *gv; + IO *io; MAGIC *mg; 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) { @@ -1874,9 +1923,11 @@ PP(pp_eof) else gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */ - if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) { + if (gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)gv, mg)); + XPUSHs(SvTIED_obj((SV*)io, mg)); PUTBACK; ENTER; call_method("EOF", G_SCALAR); @@ -1893,6 +1944,7 @@ PP(pp_tell) { dSP; dTARGET; GV *gv; + IO *io; MAGIC *mg; if (MAXARG == 0) @@ -1900,9 +1952,11 @@ PP(pp_tell) else gv = PL_last_in_gv = (GV*)POPs; - if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) { + if (gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)gv, mg)); + XPUSHs(SvTIED_obj((SV*)io, mg)); PUTBACK; ENTER; call_method("TELL", G_SCALAR); @@ -1928,6 +1982,7 @@ PP(pp_sysseek) { dSP; GV *gv; + IO *io; int whence = POPi; #if LSEEKSIZE > IVSIZE Off_t offset = (Off_t)SvNVx(POPs); @@ -1938,9 +1993,11 @@ PP(pp_sysseek) gv = PL_last_in_gv = (GV*)POPs; - if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) { + if (gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)gv, mg)); + XPUSHs(SvTIED_obj((SV*)io, mg)); #if LSEEKSIZE > IVSIZE XPUSHs(sv_2mortal(newSVnv((NV) offset))); #else @@ -1984,9 +2041,6 @@ PP(pp_truncate) * at least as wide as size_t, so using an off_t should be okay. */ /* XXX Configure probe for the length type of *truncate() needed XXX */ Off_t len; - int result = 1; - GV *tmpgv; - STRLEN n_a; #if Size_t_size > IVSIZE len = (Off_t)POPn; @@ -1998,60 +2052,67 @@ PP(pp_truncate) /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */ SETERRNO(0,0); #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP) - if (PL_op->op_flags & OPf_SPECIAL) { - tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO); - do_ftruncate: - TAINT_PROPER("truncate"); - if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv))) - result = 0; - else { - PerlIO_flush(IoIFP(GvIOp(tmpgv))); + { + STRLEN n_a; + int result = 1; + GV *tmpgv; + + if (PL_op->op_flags & OPf_SPECIAL) { + tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO); + + do_ftruncate: + TAINT_PROPER("truncate"); + if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv))) + result = 0; + else { + PerlIO_flush(IoIFP(GvIOp(tmpgv))); #ifdef HAS_TRUNCATE - if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0) + if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0) #else - if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0) + if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0) #endif - result = 0; - } - } - else { - SV *sv = POPs; - char *name; - STRLEN n_a; - - if (SvTYPE(sv) == SVt_PVGV) { - tmpgv = (GV*)sv; /* *main::FRED for example */ - goto do_ftruncate; - } - else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { - tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */ - goto do_ftruncate; + result = 0; + } } + else { + SV *sv = POPs; + char *name; + + if (SvTYPE(sv) == SVt_PVGV) { + tmpgv = (GV*)sv; /* *main::FRED for example */ + goto do_ftruncate; + } + else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) { + tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */ + goto do_ftruncate; + } - name = SvPV(sv, n_a); - TAINT_PROPER("truncate"); + name = SvPV(sv, n_a); + TAINT_PROPER("truncate"); #ifdef HAS_TRUNCATE - if (truncate(name, len) < 0) - result = 0; + if (truncate(name, len) < 0) + result = 0; #else - { - int tmpfd; - if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0) - result = 0; - else { - if (my_chsize(tmpfd, len) < 0) + { + int tmpfd; + + if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0) result = 0; - PerlLIO_close(tmpfd); + else { + if (my_chsize(tmpfd, len) < 0) + result = 0; + PerlLIO_close(tmpfd); + } } - } #endif - } + } - if (result) - RETPUSHYES; - if (!errno) - SETERRNO(EBADF,RMS$_IFI); - RETPUSHUNDEF; + if (result) + RETPUSHYES; + if (!errno) + SETERRNO(EBADF,RMS$_IFI); + RETPUSHUNDEF; + } #else DIE(aTHX_ "truncate not implemented"); #endif @@ -2066,7 +2127,7 @@ PP(pp_ioctl) { dSP; dTARGET; SV *argsv = POPs; - unsigned int func = U_I(POPn); + unsigned int func = POPu; int optype = PL_op->op_type; char *s; IV retval; @@ -2119,7 +2180,7 @@ PP(pp_ioctl) if (SvPOK(argsv)) { if (s[SvCUR(argsv)] != 17) DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument", - PL_op_name[optype]); + OP_NAME(PL_op)); s[SvCUR(argsv)] = 0; /* put our null back */ SvSETMAGIC(argsv); /* Assume it has changed */ } @@ -2137,6 +2198,7 @@ PP(pp_ioctl) PP(pp_flock) { +#ifdef FLOCK dSP; dTARGET; I32 value; int argtype; @@ -2144,7 +2206,6 @@ PP(pp_flock) IO *io = NULL; PerlIO *fp; -#ifdef FLOCK argtype = POPi; if (MAXARG == 0) gv = PL_last_in_gv; @@ -2177,8 +2238,8 @@ PP(pp_flock) PP(pp_socket) { - dSP; #ifdef HAS_SOCKET + dSP; GV *gv; register IO *io; int protocol = POPi; @@ -2230,8 +2291,8 @@ PP(pp_socket) PP(pp_sockpair) { +#if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET)) dSP; -#ifdef HAS_SOCKETPAIR GV *gv1; GV *gv2; register IO *io1; @@ -2295,11 +2356,11 @@ PP(pp_sockpair) PP(pp_bind) { - dSP; #ifdef HAS_SOCKET + dSP; #ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */ - extern GETPRIVMODE(); - extern GETUSERMODE(); + extern void GETPRIVMODE(); + extern void GETUSERMODE(); #endif SV *addrsv = POPs; char *addr; @@ -2354,8 +2415,8 @@ nuts: PP(pp_connect) { - dSP; #ifdef HAS_SOCKET + dSP; SV *addrsv = POPs; char *addr; GV *gv = (GV*)POPs; @@ -2384,8 +2445,8 @@ nuts: PP(pp_listen) { - dSP; #ifdef HAS_SOCKET + dSP; int backlog = POPi; GV *gv = (GV*)POPs; register IO *io = gv ? GvIOn(gv) : NULL; @@ -2410,8 +2471,8 @@ nuts: PP(pp_accept) { - dSP; dTARGET; #ifdef HAS_SOCKET + dSP; dTARGET; GV *ngv; GV *ggv; register IO *nstio; @@ -2419,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; @@ -2433,14 +2495,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)); @@ -2450,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 @@ -2475,8 +2541,8 @@ badexit: PP(pp_shutdown) { - dSP; dTARGET; #ifdef HAS_SOCKET + dSP; dTARGET; int how = POPi; GV *gv = (GV*)POPs; register IO *io = GvIOn(gv); @@ -2508,8 +2574,8 @@ PP(pp_gsockopt) PP(pp_ssockopt) { - dSP; #ifdef HAS_SOCKET + dSP; int optype = PL_op->op_type; SV *sv; int fd; @@ -2589,8 +2655,8 @@ PP(pp_getsockname) PP(pp_getpeername) { - dSP; #ifdef HAS_SOCKET + dSP; int optype = PL_op->op_type; SV *sv; int fd; @@ -2669,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: @@ -2699,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)); @@ -2712,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; } } @@ -3254,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); @@ -3296,7 +3366,7 @@ PP(pp_fttext) #else else if (*s & 128) { #ifdef USE_LOCALE - if ((PL_op->op_private & OPpLOCALE) && isALPHA_LC(*s)) + if (IN_LOCALE_RUNTIME && isALPHA_LC(*s)) continue; #endif /* utf8 characters don't count as odd */ @@ -3344,27 +3414,30 @@ PP(pp_chdir) SV **svp; STRLEN n_a; - if (MAXARG < 1) - tmps = Nullch; + if( MAXARG == 1 ) + tmps = POPpx; else - tmps = POPpx; - if (!tmps || !*tmps) { - svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE); - if (svp) - tmps = SvPV(*svp, n_a); - } - if (!tmps || !*tmps) { - svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE); - if (svp) - tmps = SvPV(*svp, n_a); - } + tmps = 0; + + if( !tmps || !*tmps ) { + if ( (svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE)) + || (svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE)) #ifdef VMS - if (!tmps || !*tmps) { - svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE); - if (svp) - tmps = SvPV(*svp, n_a); - } + || (svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE)) #endif + ) + { + if( MAXARG == 1 ) + deprecate("chdir('') or chdir(undef) as chdir()"); + tmps = SvPV(*svp, n_a); + } + else { + PUSHi(0); + TAINT_PROPER("chdir"); + RETURN; + } + } + TAINT_PROPER("chdir"); PUSHi( PerlDir_chdir(tmps) >= 0 ); #ifdef VMS @@ -3377,25 +3450,24 @@ PP(pp_chdir) PP(pp_chown) { - dSP; dMARK; dTARGET; - I32 value; #ifdef HAS_CHOWN - value = (I32)apply(PL_op->op_type, MARK, SP); + dSP; dMARK; dTARGET; + I32 value = (I32)apply(PL_op->op_type, MARK, SP); + SP = MARK; PUSHi(value); RETURN; #else - DIE(aTHX_ PL_no_func, "Unsupported function chown"); + DIE(aTHX_ PL_no_func, "chown"); #endif } PP(pp_chroot) { - dSP; dTARGET; - char *tmps; #ifdef HAS_CHROOT + dSP; dTARGET; STRLEN n_a; - tmps = POPpx; + char *tmps = POPpx; TAINT_PROPER("chroot"); PUSHi( chroot(tmps) >= 0 ); RETURN; @@ -3463,23 +3535,23 @@ PP(pp_rename) PP(pp_link) { - dSP; dTARGET; #ifdef HAS_LINK + dSP; dTARGET; STRLEN n_a; char *tmps2 = POPpx; char *tmps = SvPV(TOPs, n_a); TAINT_PROPER("link"); SETi( PerlLIO_link(tmps, tmps2) >= 0 ); + RETURN; #else - DIE(aTHX_ PL_no_func, "Unsupported function link"); + DIE(aTHX_ PL_no_func, "link"); #endif - RETURN; } PP(pp_symlink) { - dSP; dTARGET; #ifdef HAS_SYMLINK + dSP; dTARGET; STRLEN n_a; char *tmps2 = POPpx; char *tmps = SvPV(TOPs, n_a); @@ -3493,8 +3565,9 @@ PP(pp_symlink) PP(pp_readlink) { - dSP; dTARGET; + dSP; #ifdef HAS_SYMLINK + dTARGET; char *tmps; char buf[MAXPATHLEN]; int len; @@ -3504,7 +3577,7 @@ PP(pp_readlink) TAINT; #endif tmps = POPpx; - len = readlink(tmps, buf, sizeof buf); + len = readlink(tmps, buf, sizeof(buf) - 1); EXTEND(SP, 1); if (len < 0) RETPUSHUNDEF; @@ -3670,8 +3743,8 @@ PP(pp_rmdir) PP(pp_open_dir) { - dSP; #if defined(Direntry_t) && defined(HAS_READDIR) + dSP; STRLEN n_a; char *dirname = POPpx; GV *gv = (GV*)POPs; @@ -3697,8 +3770,8 @@ nope: PP(pp_readdir) { - dSP; #if defined(Direntry_t) && defined(HAS_READDIR) + dSP; #if !defined(I_DIRENT) && !defined(VMS) Direntry_t *readdir (DIR *); #endif @@ -3755,8 +3828,8 @@ nope: PP(pp_telldir) { - dSP; dTARGET; #if defined(HAS_TELLDIR) || defined(telldir) + dSP; dTARGET; /* XXX does _anyone_ need this? --AD 2/20/1998 */ /* XXX netbsd still seemed to. XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style. @@ -3783,8 +3856,8 @@ nope: PP(pp_seekdir) { - dSP; #if defined(HAS_SEEKDIR) || defined(seekdir) + dSP; long along = POPl; GV *gv = (GV*)POPs; register IO *io = GvIOn(gv); @@ -3806,8 +3879,8 @@ nope: PP(pp_rewinddir) { - dSP; #if defined(HAS_REWINDDIR) || defined(rewinddir) + dSP; GV *gv = (GV*)POPs; register IO *io = GvIOn(gv); @@ -3827,8 +3900,8 @@ nope: PP(pp_closedir) { - dSP; #if defined(Direntry_t) && defined(HAS_READDIR) + dSP; GV *gv = (GV*)POPs; register IO *io = GvIOn(gv); @@ -3866,13 +3939,16 @@ PP(pp_fork) EXTEND(SP, 1); PERL_FLUSHALL_FOR_CHILD; - childpid = fork(); + childpid = PerlProc_fork(); if (childpid < 0) 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); @@ -3890,7 +3966,7 @@ PP(pp_fork) PUSHi(childpid); RETURN; # else - DIE(aTHX_ PL_no_func, "Unsupported function fork"); + DIE(aTHX_ PL_no_func, "fork"); # endif #endif } @@ -3918,7 +3994,7 @@ PP(pp_wait) XPUSHi(childpid); RETURN; #else - DIE(aTHX_ PL_no_func, "Unsupported function wait"); + DIE(aTHX_ PL_no_func, "wait"); #endif } @@ -3948,7 +4024,7 @@ PP(pp_waitpid) SETi(childpid); RETURN; #else - DIE(aTHX_ PL_no_func, "Unsupported function waitpid"); + DIE(aTHX_ PL_no_func, "waitpid"); #endif } @@ -3956,83 +4032,96 @@ PP(pp_system) { dSP; dMARK; dORIGMARK; dTARGET; I32 value; - Pid_t childpid; - int result; - int status; - Sigsave_t ihand,qhand; /* place to save signals during system() */ STRLEN n_a; - I32 did_pipes = 0; + int result; int pp[2]; + I32 did_pipes = 0; - if (SP - MARK == 1) { - if (PL_tainting) { - char *junk = SvPV(TOPs, n_a); - 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"); } - } - PERL_FLUSHALL_FOR_CHILD; -#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) && !defined(__CYGWIN__) || defined(PERL_MICRO) - if (PerlProc_pipe(pp) >= 0) - did_pipes = 1; - while ((childpid = vfork()) == -1) { - if (errno != EAGAIN) { - value = -1; - SP = ORIGMARK; - PUSHi(value); - if (did_pipes) { - PerlLIO_close(pp[0]); - PerlLIO_close(pp[1]); - } - RETURN; + else if (ckWARN2(WARN_TAINT, WARN_DEPRECATED)) { + Perl_warner(aTHX_ packWARN2(WARN_TAINT, WARN_DEPRECATED), + "Use of tainted arguments in %s is deprecated", "system"); } - sleep(5); } - if (childpid > 0) { - if (did_pipes) - PerlLIO_close(pp[1]); + 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]); #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 vfork */ - 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; @@ -4072,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; @@ -4091,11 +4197,6 @@ PP(pp_exec) # endif #endif else { - if (PL_tainting) { - char *junk = SvPV(*SP, n_a); - TAINT_ENV(); - TAINT_PROPER("exec"); - } #ifdef VMS value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a)); #else @@ -4108,11 +4209,6 @@ PP(pp_exec) #endif } -#if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) - if (value >= 0) - my_exit(value); -#endif - SP = ORIGMARK; PUSHi(value); RETURN; @@ -4120,15 +4216,15 @@ PP(pp_exec) PP(pp_kill) { +#ifdef HAS_KILL dSP; dMARK; dTARGET; I32 value; -#ifdef HAS_KILL value = (I32)apply(PL_op->op_type, MARK, SP); SP = MARK; PUSHi(value); RETURN; #else - DIE(aTHX_ PL_no_func, "Unsupported function kill"); + DIE(aTHX_ PL_no_func, "kill"); #endif } @@ -4202,12 +4298,10 @@ PP(pp_setpgrp) PP(pp_getpriority) { - dSP; dTARGET; - int which; - int who; #ifdef HAS_GETPRIORITY - who = POPi; - which = TOPi; + dSP; dTARGET; + int who = POPi; + int which = TOPi; SETi( getpriority(which, who) ); RETURN; #else @@ -4217,14 +4311,11 @@ PP(pp_getpriority) PP(pp_setpriority) { - dSP; dTARGET; - int which; - int who; - int niceval; #ifdef HAS_SETPRIORITY - niceval = POPi; - who = POPi; - which = TOPi; + dSP; dTARGET; + int niceval = POPi; + int who = POPi; + int which = TOPi; TAINT_PROPER("setpriority"); SETi( setpriority(which, who, niceval) >= 0 ); RETURN; @@ -4254,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 @@ -4264,13 +4359,9 @@ PP(pp_time) PP(pp_tms) { +#ifdef HAS_TIMES dSP; - -#ifndef HAS_TIMES - DIE(aTHX_ "times not implemented"); -#else EXTEND(SP, 4); - #ifndef VMS (void)PerlProc_times(&PL_timesbuf); #else @@ -4286,6 +4377,8 @@ PP(pp_tms) PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ))); } RETURN; +#else + DIE(aTHX_ "times not implemented"); #endif /* HAS_TIMES */ } @@ -4317,10 +4410,10 @@ PP(pp_gmtime) else tmbuf = gmtime(&when); - EXTEND(SP, 9); - EXTEND_MORTAL(9); if (GIMME != G_ARRAY) { SV *tsv; + EXTEND(SP, 1); + EXTEND_MORTAL(1); if (!tmbuf) RETPUSHUNDEF; tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d", @@ -4334,7 +4427,9 @@ PP(pp_gmtime) PUSHs(sv_2mortal(tsv)); } else if (tmbuf) { - PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec))); + EXTEND(SP, 9); + EXTEND_MORTAL(9); + PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec))); PUSHs(sv_2mortal(newSViv(tmbuf->tm_min))); PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour))); PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday))); @@ -4349,9 +4444,9 @@ PP(pp_gmtime) PP(pp_alarm) { +#ifdef HAS_ALARM dSP; dTARGET; int anum; -#ifdef HAS_ALARM anum = POPi; anum = alarm((unsigned int)anum); EXTEND(SP, 1); @@ -4360,7 +4455,7 @@ PP(pp_alarm) PUSHi(anum); RETURN; #else - DIE(aTHX_ PL_no_func, "Unsupported function alarm"); + DIE(aTHX_ PL_no_func, "alarm"); #endif } @@ -4523,27 +4618,29 @@ PP(pp_ghbyaddr) PP(pp_ghostent) { - dSP; #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT) + dSP; I32 which = PL_op->op_type; 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; @@ -4564,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) { @@ -4632,29 +4735,31 @@ PP(pp_gnbyaddr) PP(pp_gnetent) { - dSP; #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT) + dSP; I32 which = PL_op->op_type; 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; - Netdb_net_t addr = (Netdb_net_t) U_L(POPn); + Netdb_net_t addr = (Netdb_net_t) (U32)POPu; nent = PerlSock_getnetbyaddr(addr, addrtype); #else DIE(aTHX_ PL_no_sock_func, "getnetbyaddr"); @@ -4667,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()); @@ -4720,31 +4836,35 @@ PP(pp_gpbynumber) PP(pp_gprotoent) { - dSP; #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT) + dSP; I32 which = PL_op->op_type; 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(); @@ -4803,15 +4923,15 @@ PP(pp_gsbyport) PP(pp_gservent) { - dSP; #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT) + dSP; I32 which = PL_op->op_type; 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; @@ -4893,8 +5013,8 @@ PP(pp_gservent) PP(pp_shostent) { - dSP; #ifdef HAS_SETHOSTENT + dSP; PerlSock_sethostent(TOPi); RETSETYES; #else @@ -4904,8 +5024,8 @@ PP(pp_shostent) PP(pp_snetent) { - dSP; #ifdef HAS_SETNETENT + dSP; PerlSock_setnetent(TOPi); RETSETYES; #else @@ -4915,8 +5035,8 @@ PP(pp_snetent) PP(pp_sprotoent) { - dSP; #ifdef HAS_SETPROTOENT + dSP; PerlSock_setprotoent(TOPi); RETSETYES; #else @@ -4926,8 +5046,8 @@ PP(pp_sprotoent) PP(pp_sservent) { - dSP; #ifdef HAS_SETSERVENT + dSP; PerlSock_setservent(TOPi); RETSETYES; #else @@ -4937,8 +5057,8 @@ PP(pp_sservent) PP(pp_ehostent) { - dSP; #ifdef HAS_ENDHOSTENT + dSP; PerlSock_endhostent(); EXTEND(SP,1); RETPUSHYES; @@ -4949,8 +5069,8 @@ PP(pp_ehostent) PP(pp_enetent) { - dSP; #ifdef HAS_ENDNETENT + dSP; PerlSock_endnetent(); EXTEND(SP,1); RETPUSHYES; @@ -4961,8 +5081,8 @@ PP(pp_enetent) PP(pp_eprotoent) { - dSP; #ifdef HAS_ENDPROTOENT + dSP; PerlSock_endprotoent(); EXTEND(SP,1); RETPUSHYES; @@ -4973,8 +5093,8 @@ PP(pp_eprotoent) PP(pp_eservent) { - dSP; #ifdef HAS_ENDSERVENT + dSP; PerlSock_endservent(); EXTEND(SP,1); RETPUSHYES; @@ -5003,8 +5123,8 @@ PP(pp_gpwuid) PP(pp_gpwent) { - dSP; #ifdef HAS_PASSWD + dSP; I32 which = PL_op->op_type; register SV *sv; STRLEN n_a; @@ -5065,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 @@ -5217,8 +5343,8 @@ PP(pp_gpwent) PP(pp_spwent) { - dSP; #if defined(HAS_PASSWD) && defined(HAS_SETPWENT) + dSP; setpwent(); RETPUSHYES; #else @@ -5228,8 +5354,8 @@ PP(pp_spwent) PP(pp_epwent) { - dSP; #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT) + dSP; endpwent(); RETPUSHYES; #else @@ -5257,18 +5383,22 @@ PP(pp_ggrgid) PP(pp_ggrent) { - dSP; #ifdef HAS_GROUP + dSP; I32 which = PL_op->op_type; register char **elem; register SV *sv; 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(); @@ -5300,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; @@ -5316,8 +5456,8 @@ PP(pp_ggrent) PP(pp_sgrent) { - dSP; #if defined(HAS_GROUP) && defined(HAS_SETGRENT) + dSP; setgrent(); RETPUSHYES; #else @@ -5327,8 +5467,8 @@ PP(pp_sgrent) PP(pp_egrent) { - dSP; #if defined(HAS_GROUP) && defined(HAS_ENDGRENT) + dSP; endgrent(); RETPUSHYES; #else @@ -5338,8 +5478,8 @@ PP(pp_egrent) PP(pp_getlogin) { - dSP; dTARGET; #ifdef HAS_GETLOGIN + dSP; dTARGET; char *tmps; EXTEND(SP, 1); if (!(tmps = PerlProc_getlogin()))