X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_sys.c;h=aa8fb77acc0afce198330b0f81b6377711069706;hb=f05bbc4047b4e519eb0edbaf2fce2004f4838d1a;hp=b14ab9caf8b9bb964b74182aedd6865d37a801b5;hpb=72f496dcd0fc92435ef5c603c8a681183058a7bc;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_sys.c b/pp_sys.c index b14ab9c..aa8fb77 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 @@ -838,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; } @@ -982,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 @@ -1004,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); @@ -1132,7 +1139,7 @@ PP(pp_getc) { dSP; dTARGET; GV *gv; - IO *io; + IO *io = NULL; MAGIC *mg; if (MAXARG == 0) @@ -1155,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 */ @@ -1352,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)) @@ -1366,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); @@ -1438,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)) @@ -1573,7 +1584,7 @@ PP(pp_sysread) #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; @@ -1675,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; @@ -1892,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) { @@ -2280,7 +2291,7 @@ PP(pp_socket) PP(pp_sockpair) { -#if defined (HAS_SOCKETPAIR) || defined (HAS_SOCKET) +#if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET)) dSP; GV *gv1; GV *gv2; @@ -2724,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: @@ -2754,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)); @@ -2767,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; } } @@ -3309,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); @@ -3732,17 +3747,39 @@ PP(pp_open_dir) dSP; STRLEN n_a; char *dirname = POPpx; - GV *gv = (GV*)POPs; - register IO *io = GvIOn(gv); + char *dscp = NULL; + GV *gv; + register IO *io; + bool want_utf8 = FALSE; + + if (MAXARG == 3) + dscp = POPpx; + + gv = (GV*)POPs; + io = GvIOn(gv); if (!io) goto nope; + if (dscp) { + if (*dscp == ':') { + if (strnEQ(dscp + 1, "utf8", 4)) + want_utf8 = TRUE; + else + Perl_croak(aTHX_ "Unknown discipline '%s'", dscp); + } + else + Perl_croak(aTHX_ "Unknown discipline '%s'", dscp); + } + if (IoDIRP(io)) PerlDir_close(IoDIRP(io)); if (!(IoDIRP(io) = PerlDir_open(dirname))) goto nope; + if (want_utf8) + IoFLAGS(io) |= IOf_DIR_UTF8; + RETPUSHYES; nope: if (!errno) @@ -3780,6 +3817,8 @@ PP(pp_readdir) if (!(IoFLAGS(io) & IOf_UNTAINT)) SvTAINTED_on(sv); #endif + if (IoFLAGS(io) & IOf_DIR_UTF8 && !IN_BYTES) + SvUTF8_on(sv); XPUSHs(sv_2mortal(sv)); } } @@ -3795,6 +3834,8 @@ PP(pp_readdir) if (!(IoFLAGS(io) & IOf_UNTAINT)) SvTAINTED_on(sv); #endif + if (IoFLAGS(io) & IOf_DIR_UTF8) + sv_utf8_upgrade(sv); XPUSHs(sv_2mortal(sv)); } RETURN; @@ -4022,12 +4063,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) @@ -4035,16 +4086,6 @@ PP(pp_system) Pid_t childpid; int status; Sigsave_t ihand,qhand; /* place to save signals during system() */ - - if (PL_tainting) { - SV *cmd = NULL; - if (PL_op->op_flags & OPf_STACKED) - cmd = *(MARK + 1); - else if (SP - MARK != 1) - cmd = *SP; - if (cmd && *(SvPV_nolen(cmd)) != '/') - TAINT_ENV(); - } if (PerlProc_pipe(pp) >= 0) did_pipes = 1; @@ -4146,6 +4187,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; @@ -4165,11 +4223,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 @@ -4597,21 +4650,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; @@ -4632,8 +4687,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) { @@ -4706,19 +4767,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; @@ -4735,6 +4798,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()); @@ -4794,25 +4868,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(); @@ -4877,9 +4955,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; @@ -5133,10 +5211,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 @@ -5333,10 +5417,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(); @@ -5368,12 +5456,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;