diff options
| -rwxr-xr-x | Configure | 12 | ||||
| -rw-r--r-- | doio.c | 27 | ||||
| -rw-r--r-- | gv.c | 17 | ||||
| -rw-r--r-- | op.c | 1 | ||||
| -rw-r--r-- | pp_ctl.c | 10 | ||||
| -rw-r--r-- | sv.c | 3 | ||||
| -rwxr-xr-x | t/op/gv.t | 10 | ||||
| -rwxr-xr-x | t/op/local.t | 8 |
8 files changed, 57 insertions, 31 deletions
@@ -5464,13 +5464,13 @@ fi cat <<EOM -Previous version of $package used the standard IO mechanisms as defined in -<stdio.h>. Versions 5.003_02 and later of perl allow alternate IO +Previous version of $package used the standard IO mechanisms as defined +in <stdio.h>. Versions 5.003_02 and later of perl allow alternate IO mechanisms via a "PerlIO" abstraction, but the stdio mechanism is still -the default and is the only supported mechanism. This abstraction -layer can use AT&T's sfio (if you already have sfio installed) or -fall back on standard IO. This PerlIO abstraction layer is -experimental and may cause problems with some extension modules. +the default. This abstraction layer can use AT&T's sfio (if you already +have sfio installed) or regular stdio. Using PerlIO with sfio may cause +problems with some extension modules. Using PerlIO with stdio is safe, +but it is slower than plain stdio and therefore is not the default. If this doesn't make any sense to you, just accept the default 'n'. EOM @@ -40,12 +40,18 @@ # include <utime.h> # endif #endif + #ifdef I_FCNTL #include <fcntl.h> #endif #ifdef I_SYS_FILE #include <sys/file.h> #endif +#ifdef O_EXCL +# define OPEN_EXCL O_EXCL +#else +# define OPEN_EXCL 0 +#endif #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) #include <signal.h> @@ -381,16 +387,16 @@ nextargv(register GV *gv) filemode = 0; while (av_len(GvAV(gv)) >= 0) { dTHR; - STRLEN len; + STRLEN oldlen; sv = av_shift(GvAV(gv)); SAVEFREESV(sv); sv_setsv(GvSV(gv),sv); SvSETMAGIC(GvSV(gv)); - oldname = SvPVx(GvSV(gv), len); - if (do_open(gv,oldname,len,FALSE,0,0,Nullfp)) { + oldname = SvPVx(GvSV(gv), oldlen); + if (do_open(gv,oldname,oldlen,inplace!=0,0,0,Nullfp)) { if (inplace) { TAINT_PROPER("inplace open"); - if (strEQ(oldname,"-")) { + if (oldlen == 1 && *oldname == '-') { setdefout(gv_fetchpv("STDOUT",TRUE,SVt_PVIO)); return IoIFP(GvIOp(gv)); } @@ -439,7 +445,7 @@ nextargv(register GV *gv) do_close(gv,FALSE); (void)PerlLIO_unlink(SvPVX(sv)); (void)PerlLIO_rename(oldname,SvPVX(sv)); - do_open(gv,SvPVX(sv),SvCUR(sv),FALSE,0,0,Nullfp); + do_open(gv,SvPVX(sv),SvCUR(sv),inplace!=0,0,0,Nullfp); #endif /* DOSISH */ #else (void)UNLINK(SvPVX(sv)); @@ -456,8 +462,8 @@ nextargv(register GV *gv) #if !defined(DOSISH) && !defined(AMIGAOS) # ifndef VMS /* Don't delete; use automatic file versioning */ if (UNLINK(oldname) < 0) { - warn("Can't rename %s to %s: %s, skipping file", - oldname, SvPVX(sv), Strerror(errno) ); + warn("Can't remove %s: %s, skipping file", + oldname, Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -467,10 +473,11 @@ nextargv(register GV *gv) #endif } - sv_setpvn(sv,">",1); - sv_catpv(sv,oldname); + sv_setpvn(sv,">",!inplace); + sv_catpvn(sv,oldname,oldlen); SETERRNO(0,0); /* in case sprintf set errno */ - if (!do_open(argvoutgv,SvPVX(sv),SvCUR(sv),FALSE,0,0,Nullfp)) { + if (!do_open(argvoutgv,SvPVX(sv),SvCUR(sv),inplace!=0, + O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp)) { warn("Can't do inplace edit on %s: %s", oldname, Strerror(errno) ); do_close(gv,FALSE); @@ -97,7 +97,7 @@ gv_init(GV *gv, HV *stash, char *name, STRLEN len, int multi) GvFILEGV(gv) = curcop->cop_filegv; GvEGV(gv) = gv; sv_magic((SV*)gv, (SV*)gv, '*', name, len); - GvSTASH(gv) = stash; + GvSTASH(gv) = (HV*)SvREFCNT_inc(stash); GvNAME(gv) = savepvn(name, len); GvNAMELEN(gv) = len; if (multi) @@ -421,14 +421,15 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) tmpbuf[len++] = ':'; tmpbuf[len] = '\0'; gvp = (GV**)hv_fetch(stash,tmpbuf,len,add); + gv = gvp ? *gvp : Nullgv; + if (gv && gv != (GV*)&sv_undef) { + if (SvTYPE(gv) != SVt_PVGV) + gv_init(gv, stash, tmpbuf, len, (add & 2)); + else + GvMULTI_on(gv); + } Safefree(tmpbuf); - if (!gvp || *gvp == (GV*)&sv_undef) - return Nullgv; - gv = *gvp; - - if (SvTYPE(gv) == SVt_PVGV) - GvMULTI_on(gv); - else if (!add) + if (!gv || gv == (GV*)&sv_undef) return Nullgv; else gv_init(gv, stash, nambeg, namend - nambeg, (add & 2)); @@ -1162,6 +1162,7 @@ mod(OP *o, I32 type) /* FALL THROUGH */ case OP_GV: case OP_AV2ARYLEN: + hints |= HINT_BLOCK_SCOPE; case OP_SASSIGN: case OP_AELEMFAST: modcount++; @@ -86,10 +86,12 @@ PP(pp_regcomp) { else { t = SvPV(tmpstr, len); - /* JMR: Check against the last compiled regexp */ - if ( ! pm->op_pmregexp || ! pm->op_pmregexp->precomp - || strnNE(pm->op_pmregexp->precomp, t, len) - || pm->op_pmregexp->precomp[len]) { + /* JMR: Check against the last compiled regexp + To know for sure, we'd need the length of precomp. + But we don't have it, so we must ... take a guess. */ + if (!pm->op_pmregexp || !pm->op_pmregexp->precomp || + memNE(pm->op_pmregexp->precomp, t, len + 1)) + { if (pm->op_pmregexp) { ReREFCNT_dec(pm->op_pmregexp); pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */ @@ -1916,7 +1916,7 @@ sv_setsv(SV *dstr, register SV *sstr) STRLEN len = GvNAMELEN(sstr); sv_upgrade(dstr, SVt_PVGV); sv_magic(dstr, dstr, '*', name, len); - GvSTASH(dstr) = GvSTASH(sstr); + GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr)); GvNAME(dstr) = savepvn(name, len); GvNAMELEN(dstr) = len; SvFAKE_on(dstr); /* can coerce to non-glob */ @@ -2699,6 +2699,7 @@ sv_clear(register SV *sv) case SVt_PVGV: gp_free((GV*)sv); Safefree(GvNAME(sv)); + SvREFCNT_dec(GvSTASH(sv)); /* FALL THROUGH */ case SVt_PVLV: case SVt_PVMG: @@ -4,7 +4,7 @@ # various typeglob tests # -print "1..11\n"; +print "1..13\n"; # type coersion on assignment $foo = 'foo'; @@ -57,3 +57,11 @@ if (defined $baa) { print ref(\$baa) eq 'GLOB' ? "ok 11\n" : "not ok 11\n"; } +# nested package globs +# NOTE: It's probably OK if these semantics change, because the +# fact that %X::Y:: is stored in %X:: isn't documented. +# (I hope.) + +{ package Foo::Bar } +print exists $Foo::{'Bar::'} ? "ok 12\n" : "not ok 12\n"; +print $Foo::{'Bar::'} eq '*Foo::Bar::' ? "ok 13\n" : "not ok 13\n"; diff --git a/t/op/local.t b/t/op/local.t index f527c9c9a9..3e30306218 100755 --- a/t/op/local.t +++ b/t/op/local.t @@ -2,7 +2,7 @@ # $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $ -print "1..23\n"; +print "1..24\n"; sub foo { local($a, $b) = @_; @@ -52,3 +52,9 @@ print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 22\n"; eval 'local(%$e)'; print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 23\n"; + +# check for scope leakage +$a = 'outer'; +if (1) { local $a = 'inner' } +print +($a eq 'outer') ? "" : "not ", "ok 24\n"; + |