%^H not lexical enough #9832

p5pRT · 2009-08-17T11:26:08Z

Migrated from rt.perl.org#68590 (status was 'resolved')

Searchable as RT68590$

p5pRT · 2009-08-17T11:26:09Z

From zefram@fysh.org

Created by zefram@fysh.org

perlvar(1) says:

# %^H The %^H hash provides the same scoping semantic as $^H. This
# makes it useful for implementation of lexically scoped pragmas.
# See perlpragma.

The first sentence of that description is not true. Specifically, the
scoping semantics match within a single file, but when require/use-ing
a new file, $^H gets reset to its initial value but %^H inherits the
value from the outer file. Demonstration:

$ cat x0.pm
package x0;
printf "0x%08x %s\n", $^H, $^H{foo};
1;
$ perl -e 'BEGIN { $^H |= 1; $^H{foo} = "zzz"; printf "0x%08x %s\n", $^H, $^H{foo}; } use x0; BEGIN { printf "0x%08x %s\n", $^H, $^H{foo}; }'
0x00020101 zzz
0x00000100 zzz
0x00020101 zzz

Observe that the 0x1 bit of $^H has been reset, as seen in x0.pm, but
$^H{foo} retains its value.

This occurs both in 5.10.0 and 5.10.1-RC1, despite this interesting diff
between them in pp_require:

{{{
@@ -3466,6 +3535,11 @@

SAVEHINTS();
PL_hints = 0;
+ if (PL_compiling.cop_hints_hash) {
+ Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
+ PL_compiling.cop_hints_hash = NULL;
+ }
+
SAVECOMPILEWARNINGS();
if (PL_dowarn & G_WARN_ALL_ON)
PL_compiling.cop_warnings = pWARN_ALL ;
}}}

Perl Info


Flags:
    category=core
    severity=medium

Site configuration information for perl 5.10.0:

Configured by Debian Project at Thu Jan  1 12:43:38 UTC 2009.

Summary of my perl5 (revision 5 version 10 subversion 0) configuration:
  Platform:
    osname=linux, osvers=2.6.26-1-686, archname=i486-linux-gnu-thread-multi
    uname='linux rebekka 2.6.26-1-686 #1 smp mon dec 15 18:15:07 utc 2008 i686 gnulinux '
    config_args='-Dusethreads -Duselargefiles -Dccflags=-DDEBIAN -Dcccdlflags=-fPIC -Darchname=i486-linux-gnu -Dprefix=/usr -Dprivlib=/usr/share/perl/5.10 -Darchlib=/usr/lib/perl/5.10 -Dvendorprefix=/usr -Dvendorlib=/usr/share/perl5 -Dvendorarch=/usr/lib/perl5 -Dsiteprefix=/usr/local -Dsitelib=/usr/local/share/perl/5.10.0 -Dsitearch=/usr/local/lib/perl/5.10.0 -Dman1dir=/usr/share/man/man1 -Dman3dir=/usr/share/man/man3 -Dsiteman1dir=/usr/local/man/man1 -Dsiteman3dir=/usr/local/man/man3 -Dman1ext=1 -Dman3ext=3perl -Dpager=/usr/bin/sensible-pager -Uafs -Ud_csh -Ud_ualarm -Uusesfio -Uusenm -DDEBUGGING=-g -Doptimize=-O2 -Duseshrplib -Dlibperl=libperl.so.5.10.0 -Dd_dosuid -des'
    hint=recommended, useposix=true, d_sigaction=define
    useithreads=define, usemultiplicity=define
    useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef
    use64bitint=undef, use64bitall=undef, uselongdouble=undef
    usemymalloc=n, bincompat5005=undef
  Compiler:
    cc='cc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -DDEBIAN -fno-strict-aliasing -pipe -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
    optimize='-O2 -g',
    cppflags='-D_REENTRANT -D_GNU_SOURCE -DDEBIAN -fno-strict-aliasing -pipe -I/usr/local/include'
    ccversion='', gccversion='4.3.2', gccosandvers=''
    intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234
    d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
    ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
    alignbytes=4, prototype=define
  Linker and Libraries:
    ld='cc', ldflags =' -L/usr/local/lib'
    libpth=/usr/local/lib /lib /usr/lib /usr/lib64
    libs=-lgdbm -lgdbm_compat -ldb -ldl -lm -lpthread -lc -lcrypt
    perllibs=-ldl -lm -lpthread -lc -lcrypt
    libc=/lib/libc-2.7.so, so=so, useshrplib=true, libperl=libperl.so.5.10.0
    gnulibc_version='2.7'
  Dynamic Linking:
    dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E'
    cccdlflags='-fPIC', lddlflags='-shared -O2 -g -L/usr/local/lib'

Locally applied patches:
    


@INC for perl 5.10.0:
    /etc/perl
    /usr/local/lib/perl/5.10.0
    /usr/local/share/perl/5.10.0
    /usr/lib/perl5
    /usr/share/perl5
    /usr/lib/perl/5.10
    /usr/share/perl/5.10
    /usr/local/lib/site_perl
    .


Environment for perl 5.10.0:
    HOME=/home/zefram
    LANG (unset)
    LANGUAGE (unset)
    LD_LIBRARY_PATH (unset)
    LOGDIR (unset)
    PATH=/home/zefram/pub/i686-pc-linux-gnu/bin:/home/zefram/pub/common/bin:/usr/bin:/usr/X11R6/bin:/bin:/usr/local/bin:/usr/games
    PERL_BADLANG (unset)
    SHELL=/usr/bin/zsh

p5pRT · 2009-08-17T17:08:16Z

From perl@profvince.com

{{{
@@ -3466,6 +3535,11 @@
 SAVEHINTS;
 PL\_hints = 0;
+ if (PL_compiling.cop_hints_hash) {
+ Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
+ PL_compiling.cop_hints_hash = NULL;
+ }
+
SAVECOMPILEWARNINGS();
if (PL_dowarn & G_WARN_ALL_ON)
PL_compiling.cop_warnings = pWARN_ALL ;
}}}

%^H holds magic so that all changes it receives are immediately
reflected into the HE chain, but here we update the chain itself. Hence
this problem happens because %^H isn't reset here, although it is saved
by SAVEHINTS (that's why changes to %^H inside the require scope don't
leak inside the caller).

Shoving a hv_clear(GvHV(PL_hintgv)) in there should be enough to solve
the issue.

On IRC, Nicholas suggested to keep some "core" entries of %^H, like the
ones for ${^OPEN} or $[. I'm more in favor of cleaning it completely, as :
- if the corresponding features are lexical, they ought not to leak
inside requires ;
- the HE chain and %^H should be in the same state, and the former is empty.

Thoughts?

Vincent.

p5pRT · 2009-08-17T17:08:16Z

The RT System itself - Status changed from 'new' to 'open'

p5pRT · 2009-08-17T17:13:02Z

From @nwc10

On Mon, Aug 17, 2009 at 07:07:31PM +0200, Vincent Pit wrote:

{{{
@@ -3466,6 +3535,11 @@
 SAVEHINTS;
 PL\_hints = 0;
+ if (PL_compiling.cop_hints_hash) {
+ Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
+ PL_compiling.cop_hints_hash = NULL;
+ }
+
SAVECOMPILEWARNINGS();
if (PL_dowarn & G_WARN_ALL_ON)
PL_compiling.cop_warnings = pWARN_ALL ;
}}}
%^H holds magic so that all changes it receives are immediately
reflected into the HE chain, but here we update the chain itself. Hence
this problem happens because %^H isn't reset here, although it is saved
by SAVEHINTS (that's why changes to %^H inside the require scope don't
leak inside the caller).

Shoving a hv_clear(GvHV(PL_hintgv)) in there should be enough to solve
the issue.

On IRC, Nicholas suggested to keep some "core" entries of %^H, like the
ones for ${^OPEN} or $[. I'm more in favor of cleaning it completely, as :
- if the corresponding features are lexical, they ought not to leak
inside requires ;
- the HE chain and %^H should be in the same state, and the former is empty.

Not quite.. I meant that we needed to check whether it's necessary to keep
those keys. I think it might only need to be ${^OPEN}, and that's if I
remember how the implementation of -C works, and is "scoped". (ie, -C is
scoped across every file)

Thinking further, $] is lexical, so it needs resetting for each new file
scope.

Nicholas Clark

p5pRT · 2009-08-17T22:27:50Z

From zefram@fysh.org

Vincent Pit wrote:

Shoving a hv_clear(GvHV(PL_hintgv)) in there should be enough to solve
the issue.

Logically the hv_clear() ought to write through to the chain, such that
it could actually be used *instead* of the direct write to the chain.
But actually its behaviour is otherwise.

Experimenting with "no indirect", I see that its behaviour is mediated by
%^H, with a pointer-like numerical value in $^H{indirect}. If I change
the numerical value by "BEGIN{$^H{indirect}=1}" then I get a segv (no
surprise there, and I don't regard it as a bug). If I remove the entry by
"BEGIN{delete$^H{indirect}}" then the effect of the pragma is cancelled.
But if I empty the hint hash with "BEGIN{%^H=()}", the pragma remains in
effect, even though %^H now appears empty just as if I had explicitly
deleted the entry. A "BEGIN{delete$^H{indirect}}" after the hash has
been thus `emptied' does succeed in turning off the pragma.

So hv_clear() isn't writing through, and leaves %^H in a misleading state.
I think it should be possible to clear %^H and have that behave as
one would expect (cancelling all lexical state that it mediates); it
could be useful for, say, Devel::Declare-based code to create a fresh
lexical scope.

Aside from this clearing, is there anywhere else that writes directly
to the chain, making a modification that wouldn't show up in %^H?

On IRC, Nicholas suggested to keep some "core" entries of %^H, like the
ones for ${^OPEN} or $[.

Apparently they're not actually being retained in the chain across
a require boundary, and I think %^H should always accurately reflect
the chain. So these should not get any special handling.

I note that $^H{'$['} isn't actually visible in %^H, after assigning to
$[, but (as with the pseudo-emptied hash above) deleting the entry does
cancel out an earlier assignment to $[. This thus appears to be another
thing that writes to the chain without updating %^H. Incidentally,
if you're experimenting, writing to $^H{'$['}, other than deleting it,
doesn't actually take effect unless $^H bit 0x10 is also set.

-zefram

p5pRT · 2009-08-17T23:01:51Z

From perl@profvince.com

Zefram a écrit :

Vincent Pit wrote:

Shoving a hv_clear(GvHV(PL_hintgv)) in there should be enough to solve
the issue.

Logically the hv_clear() ought to write through to the chain, such that
it could actually be used *instead* of the direct write to the chain.
But actually its behaviour is otherwise.

Experimenting with "no indirect", I see that its behaviour is mediated by
%^H, with a pointer-like numerical value in $^H{indirect}. If I change
the numerical value by "BEGIN{$^H{indirect}=1}" then I get a segv (no
surprise there, and I don't regard it as a bug).
Off-topic: the value of the indirect hint is not important by itself.
It's just an unique identifier for the scope (I use a pointer to some
memory bound to the scope for this). It's then used to fetch the real
hint value from a thread-local pointer table. When a new thread a
spawned, its pointer table is initialized from his parent's, but the
values are relinked to the cloned instances. This is how I manage to
store coderefs "inside" the hints hash in a thread safe way.

If I remove the entry by
"BEGIN{delete$^H{indirect}}" then the effect of the pragma is cancelled.
But if I empty the hint hash with "BEGIN{%^H=()}", the pragma remains in
effect, even though %^H now appears empty just as if I had explicitly
deleted the entry. A "BEGIN{delete$^H{indirect}}" after the hash has
been thus `emptied' does succeed in turning off the pragma.

So hv_clear() isn't writing through, and leaves %^H in a misleading state.
I think it should be possible to clear %^H and have that behave as
one would expect (cancelling all lexical state that it mediates); it
could be useful for, say, Devel::Declare-based code to create a fresh
lexical scope.

Yes, that makes sense. A 'clear' magic callback could be added to %^H,
which would either :
- add a placeholder in the chain for every hint present in %^H ;
- free the whole chain, just like what the chunk Rafael added does.
After this, it should be enough to clear %^H in pp_require().

Aside from this clearing, is there anywhere else that writes directly
to the chain, making a modification that wouldn't show up in %^H?

I can see "$[", "open<" and "open>".

On IRC, Nicholas suggested to keep some "core" entries of %^H, like the
ones for ${^OPEN} or $[.

Apparently they're not actually being retained in the chain across
a require boundary, and I think %^H should always accurately reflect
the chain. So these should not get any special handling.

I note that $^H{'$['} isn't actually visible in %^H, after assigning to
$[, but (as with the pseudo-emptied hash above) deleting the entry does
cancel out an earlier assignment to $[. This thus appears to be another
thing that writes to the chain without updating %^H. Incidentally,
if you're experimenting, writing to $^H{'$['}, other than deleting it,
doesn't actually take effect unless $^H bit 0x10 is also set.

You spotted $[ without even having to look at the source. :)

Vincent.

p5pRT · 2009-08-20T23:17:31Z

From zefram@fysh.org

Attached is a patch that implements what we've been talking about:

* clearing %^H writes through to clear current lexical hints
* pp_require clears %^H
* @^H{qw($[ open< open>)} are visible when set by internals
* tests for most of this

There appear to be no existing tests regarding ${^OPEN} or @^H{qw(open<
open>)}, and I haven't added any, because I'm not familiar with how
they're meant to behave. Everything else that I changed is covered by
new tests.

-zefram

p5pRT · 2009-08-20T23:17:31Z

From zefram@fysh.org

Inline Patch

diff -ur perl-5.10.1-RC2.orig/cop.h perl-5.10.1-RC2.mod0/cop.h
--- perl-5.10.1-RC2.orig/cop.h	2009-04-15 19:51:08.000000000 +0100
+++ perl-5.10.1-RC2.mod0/cop.h	2009-08-20 22:02:18.385707067 +0100
@@ -258,12 +258,17 @@
 #define CopARYBASE_set(c, b) STMT_START { \
 	if (b || ((c)->cop_hints & HINT_ARYBASE)) {			\
 	    (c)->cop_hints |= HINT_ARYBASE;				\
-	    if ((c) == &PL_compiling)					\
-		PL_hints |= HINT_LOCALIZE_HH | HINT_ARYBASE;		\
-	    (c)->cop_hints_hash						\
-	       = Perl_refcounted_he_new(aTHX_ (c)->cop_hints_hash,	\
+	    if ((c) == &PL_compiling) {					\
+		SV *val = newSViv(b);					\
+		(void)hv_stores(GvHV(PL_hintgv), "$[", val);		\
+		mg_set(val);						\
+		PL_hints |= HINT_ARYBASE;				\
+	    } else {							\
+		(c)->cop_hints_hash					\
+		   = Perl_refcounted_he_new(aTHX_ (c)->cop_hints_hash,	\
 					newSVpvs_flags("$[", SVs_TEMP),	\
 					sv_2mortal(newSViv(b)));	\
+	    }								\
 	}								\
     } STMT_END
 
diff -ur perl-5.10.1-RC2.orig/dump.c perl-5.10.1-RC2.mod0/dump.c
--- perl-5.10.1-RC2.orig/dump.c	2009-07-09 16:00:51.000000000 +0100
+++ perl-5.10.1-RC2.mod0/dump.c	2009-08-20 22:57:07.809553490 +0100
@@ -1258,6 +1258,7 @@
 	    else if (v == &PL_vtbl_utf8)       s = "utf8";
             else if (v == &PL_vtbl_arylen_p)   s = "arylen_p";
             else if (v == &PL_vtbl_hintselem)  s = "hintselem";
+            else if (v == &PL_vtbl_hints)      s = "hints";
 	    else			       s = NULL;
 	    if (s)
 	        Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", s);
diff -ur perl-5.10.1-RC2.orig/embed.fnc perl-5.10.1-RC2.mod0/embed.fnc
--- perl-5.10.1-RC2.orig/embed.fnc	2009-08-15 17:36:34.000000000 +0100
+++ perl-5.10.1-RC2.mod0/embed.fnc	2009-08-20 22:59:43.620007135 +0100
@@ -512,6 +512,7 @@
 p	|int	|magic_clearenv	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_clear_all_env|NN SV* sv|NN MAGIC* mg
 dp	|int	|magic_clearhint|NN SV* sv|NN MAGIC* mg
+dp	|int	|magic_clearhints|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_clearisa	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_clearpack|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_clearsig	|NN SV* sv|NN MAGIC* mg
diff -ur perl-5.10.1-RC2.orig/embed.h perl-5.10.1-RC2.mod0/embed.h
--- perl-5.10.1-RC2.orig/embed.h	2009-07-27 22:37:52.000000000 +0100
+++ perl-5.10.1-RC2.mod0/embed.h	2009-08-20 23:13:17.963369719 +0100
@@ -403,6 +403,7 @@
 #define magic_clearenv		Perl_magic_clearenv
 #define magic_clear_all_env	Perl_magic_clear_all_env
 #define magic_clearhint		Perl_magic_clearhint
+#define magic_clearhints	Perl_magic_clearhints
 #define magic_clearisa		Perl_magic_clearisa
 #define magic_clearpack		Perl_magic_clearpack
 #define magic_clearsig		Perl_magic_clearsig
@@ -2725,6 +2726,7 @@
 #define magic_clearenv(a,b)	Perl_magic_clearenv(aTHX_ a,b)
 #define magic_clear_all_env(a,b)	Perl_magic_clear_all_env(aTHX_ a,b)
 #define magic_clearhint(a,b)	Perl_magic_clearhint(aTHX_ a,b)
+#define magic_clearhints(a,b)	Perl_magic_clearhints(aTHX_ a,b)
 #define magic_clearisa(a,b)	Perl_magic_clearisa(aTHX_ a,b)
 #define magic_clearpack(a,b)	Perl_magic_clearpack(aTHX_ a,b)
 #define magic_clearsig(a,b)	Perl_magic_clearsig(aTHX_ a,b)
diff -ur perl-5.10.1-RC2.orig/mg.c perl-5.10.1-RC2.mod0/mg.c
--- perl-5.10.1-RC2.orig/mg.c	2009-05-26 22:20:38.000000000 +0100
+++ perl-5.10.1-RC2.mod0/mg.c	2009-08-20 23:18:01.000000000 +0100
@@ -2447,31 +2447,23 @@
 	    const char *const start = SvPV(sv, len);
 	    const char *out = (const char*)memchr(start, '\0', len);
 	    SV *tmp;
-	    struct refcounted_he *tmp_he;
 
 
 	    PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
-	    PL_hints
-		|= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
+	    PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
 
 	    /* Opening for input is more common than opening for output, so
 	       ensure that hints for input are sooner on linked list.  */
 	    tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
 				       SVs_TEMP | SvUTF8(sv))
 		: newSVpvs_flags("", SVs_TEMP | SvUTF8(sv));
+	    (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
+	    mg_set(tmp);
 
-	    tmp_he
-		= Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, 
-					 newSVpvs_flags("open>", SVs_TEMP),
-					 tmp);
-
-	    /* The UTF-8 setting is carried over  */
-	    sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
-
-	    PL_compiling.cop_hints_hash
-		= Perl_refcounted_he_new(aTHX_ tmp_he,
-					 newSVpvs_flags("open<", SVs_TEMP),
-					 tmp);
+	    tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
+				       SVs_TEMP | SvUTF8(sv));
+	    (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
+	    mg_set(tmp);
 	}
 	break;
     case '\020':	/* ^P */
@@ -3164,6 +3156,26 @@
 }
 
 /*
+=for apidoc magic_clearhints
+
+Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
+
+=cut
+*/
+int
+Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
+{
+    PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
+    PERL_UNUSED_ARG(sv);
+    PERL_UNUSED_ARG(mg);
+    if (PL_compiling.cop_hints_hash) {
+	Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
+	PL_compiling.cop_hints_hash = NULL;
+    }
+    return 0;
+}
+
+/*
  * Local variables:
  * c-indentation-style: bsd
  * c-basic-offset: 4
diff -ur perl-5.10.1-RC2.orig/perl.h perl-5.10.1-RC2.mod0/perl.h
--- perl-5.10.1-RC2.orig/perl.h	2009-07-06 12:18:58.000000000 +0100
+++ perl-5.10.1-RC2.mod0/perl.h	2009-08-20 22:56:06.000000000 +0100
@@ -4645,7 +4645,8 @@
     want_vtbl_utf8,
     want_vtbl_symtab,
     want_vtbl_arylen_p,
-    want_vtbl_hintselem
+    want_vtbl_hintselem,
+    want_vtbl_hints
 };
 
 
@@ -4944,7 +4945,6 @@
     0
 );
 
-/* For now, hints magic will also use vtbl_sig, because it is all 0  */
 MGVTBL_SET(
     PL_vtbl_sig,
     0,
@@ -5309,6 +5309,18 @@
     0
 );
 
+MGVTBL_SET(
+    PL_vtbl_hints,
+    0,
+    0,
+    0,
+    MEMBER_TO_FPTR(Perl_magic_clearhints),
+    0,
+    0,
+    0,
+    0
+);
+
 #include "overload.h"
 
 END_EXTERN_C
diff -ur perl-5.10.1-RC2.orig/pod/perlguts.pod perl-5.10.1-RC2.mod0/pod/perlguts.pod
--- perl-5.10.1-RC2.orig/pod/perlguts.pod	2009-05-11 00:36:20.000000000 +0100
+++ perl-5.10.1-RC2.mod0/pod/perlguts.pod	2009-08-20 23:06:31.000000000 +0100
@@ -1038,7 +1038,7 @@
     e  PERL_MAGIC_envelem        vtbl_envelem    %ENV hash element
     f  PERL_MAGIC_fm             vtbl_fm         Formline ('compiled' format)
     g  PERL_MAGIC_regex_global   vtbl_mglob      m//g target / study()ed string
-    H  PERL_MAGIC_hints          vtbl_sig        %^H hash
+    H  PERL_MAGIC_hints          vtbl_hints      %^H hash
     h  PERL_MAGIC_hintselem      vtbl_hintselem  %^H hash element
     I  PERL_MAGIC_isa            vtbl_isa        @ISA array
     i  PERL_MAGIC_isaelem        vtbl_isaelem    @ISA array element
diff -ur perl-5.10.1-RC2.orig/pod/perlintern.pod perl-5.10.1-RC2.mod0/pod/perlintern.pod
--- perl-5.10.1-RC2.orig/pod/perlintern.pod	2009-08-19 23:11:49.000000000 +0100
+++ perl-5.10.1-RC2.mod0/pod/perlintern.pod	2009-08-21 00:03:48.000000000 +0100
@@ -444,6 +444,16 @@
 =for hackers
 Found in file mg.c
 
+=item magic_clearhints
+X<magic_clearhints>
+
+Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
+
+	int	magic_clearhints(SV* sv, MAGIC* mg)
+
+=for hackers
+Found in file mg.c
+
 =item magic_sethint
 X<magic_sethint>
 
diff -ur perl-5.10.1-RC2.orig/pp_ctl.c perl-5.10.1-RC2.mod0/pp_ctl.c
--- perl-5.10.1-RC2.orig/pp_ctl.c	2009-07-03 13:22:58.000000000 +0100
+++ perl-5.10.1-RC2.mod0/pp_ctl.c	2009-08-21 00:03:11.000000000 +0100
@@ -3535,10 +3535,7 @@
 
     SAVEHINTS();
     PL_hints = 0;
-    if (PL_compiling.cop_hints_hash) {
-	Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
-	PL_compiling.cop_hints_hash = NULL;
-    }
+    hv_clear(GvHV(PL_hintgv));
 
     SAVECOMPILEWARNINGS();
     if (PL_dowarn & G_WARN_ALL_ON)
diff -ur perl-5.10.1-RC2.orig/proto.h perl-5.10.1-RC2.mod0/proto.h
--- perl-5.10.1-RC2.orig/proto.h	2009-08-15 17:36:34.000000000 +0100
+++ perl-5.10.1-RC2.mod0/proto.h	2009-08-20 23:13:16.000000000 +0100
@@ -1494,6 +1494,12 @@
 #define PERL_ARGS_ASSERT_MAGIC_CLEARHINT	\
 	assert(sv); assert(mg)
 
+PERL_CALLCONV int	Perl_magic_clearhints(pTHX_ SV* sv, MAGIC* mg)
+			__attribute__nonnull__(pTHX_1)
+			__attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_CLEARHINTS	\
+	assert(sv); assert(mg)
+
 PERL_CALLCONV int	Perl_magic_clearisa(pTHX_ SV* sv, MAGIC* mg)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2);
diff -ur perl-5.10.1-RC2.orig/sv.c perl-5.10.1-RC2.mod0/sv.c
--- perl-5.10.1-RC2.orig/sv.c	2009-08-05 15:48:19.000000000 +0100
+++ perl-5.10.1-RC2.mod0/sv.c	2009-08-20 22:57:37.000000000 +0100
@@ -4870,8 +4870,6 @@
     case PERL_MAGIC_qr:
 	vtable = &PL_vtbl_regexp;
 	break;
-    case PERL_MAGIC_hints:
-	/* As this vtable is all NULL, we can reuse it.  */
     case PERL_MAGIC_sig:
 	vtable = &PL_vtbl_sig;
 	break;
@@ -4914,6 +4912,9 @@
     case PERL_MAGIC_hintselem:
 	vtable = &PL_vtbl_hintselem;
 	break;
+    case PERL_MAGIC_hints:
+	vtable = &PL_vtbl_hints;
+	break;
     case PERL_MAGIC_ext:
 	/* Reserved for use by extensions not perl internals.	        */
 	/* Useful for attaching extension internal data to perl vars.	*/
diff -ur perl-5.10.1-RC2.orig/t/comp/hints.t perl-5.10.1-RC2.mod0/t/comp/hints.t
--- perl-5.10.1-RC2.orig/t/comp/hints.t	2009-02-12 22:58:20.000000000 +0000
+++ perl-5.10.1-RC2.mod0/t/comp/hints.t	2009-08-20 23:59:30.000000000 +0100
@@ -8,7 +8,7 @@
 }
 
 
-BEGIN { print "1..17\n"; }
+BEGIN { print "1..32\n"; }
 BEGIN {
     print "not " if exists $^H{foo};
     print "ok 1 - \$^H{foo} doesn't exist initially\n";
@@ -38,7 +38,7 @@
     }
     BEGIN {
 	print "not " if $^H{foo} ne "a";
-	print "ok 6 - \$H^{foo} restored to 'a'\n";
+	print "ok 6 - \$^H{foo} restored to 'a'\n";
     }
     # The pragma settings disappear after compilation
     # (test at CHECK-time and at run-time)
@@ -95,14 +95,52 @@
 
 {
     BEGIN{$^H{x}=1};
-    for(1..2) {
+    for my $tno (16..17) {
         eval q(
-            print $^H{x}==1 && !$^H{y} ? "ok\n" : "not ok\n";
+            print $^H{x}==1 && !$^H{y} ? "ok $tno\n" : "not ok $tno\n";
             $^H{y} = 1;
         );
         if ($@) {
             (my $str = $@)=~s/^/# /gm;
-            print "not ok\n$str\n";
+            print "not ok $tno\n$str\n";
         }
     }
 }
+
+{
+    $[ = 11;
+    print +($[ == 11 ? "" : "not "), "ok 18 - setting \$[ affects \$[\n";
+    our $t11; BEGIN { $t11 = $^H{'$['} }
+    print +($t11 == 11 ? "" : "not "), "ok 19 - setting \$[ affects \$^H{'\$['}\n";
+
+    BEGIN { $^H{'$['} = 22 }
+    print +($[ == 22 ? "" : "not "), "ok 20 - setting \$^H{'\$['} affects \$[\n";
+    our $t22; BEGIN { $t22 = $^H{'$['} }
+    print +($t22 == 22 ? "" : "not "), "ok 21 - setting \$^H{'\$['} affects \$^H{'\$['}\n";
+
+    BEGIN { %^H = () }
+    print +($[ == 0 ? "" : "not "), "ok 22 - clearing \%^H affects \$[\n";
+    our $t0; BEGIN { $t0 = $^H{'$['} }
+    print +($t0 == 0 ? "" : "not "), "ok 23 - clearing \%^H affects \$^H{'\$['}\n";
+}
+
+{
+    $[ = 13;
+    BEGIN { $^H |= 0x04000000; $^H{foo} = "z"; }
+
+    our($ri0, $rf0); BEGIN { $ri0 = $^H; $rf0 = $^H{foo}; }
+    print +($[ == 13 ? "" : "not "), "ok 24 - \$[ correct before require\n";
+    print +($ri0 & 0x04000000 ? "" : "not "), "ok 25 - \$^H correct before require\n";
+    print +($rf0 eq "z" ? "" : "not "), "ok 26 - \$^H{foo} correct before require\n";
+
+    our($ra1, $ri1, $rf1, $rfe1); 
+    BEGIN { require "comp/hints.aux"; }
+    print +($ra1 == 0 ? "" : "not "), "ok 27 - \$[ cleared for require\n";
+    print +(!($ri1 & 0x04000000) ? "" : "not "), "ok 28 - \$^H cleared for require\n";
+    print +(!defined($rf1) && !$rfe1 ? "" : "not "), "ok 29 - \$^H{foo} cleared for require\n";
+
+    our($ri2, $rf2); BEGIN { $ri2 = $^H; $rf2 = $^H{foo}; }
+    print +($[ == 13 ? "" : "not "), "ok 30 - \$[ correct after require\n";
+    print +($ri2 & 0x04000000 ? "" : "not "), "ok 31 - \$^H correct after require\n";
+    print +($rf2 eq "z" ? "" : "not "), "ok 32 - \$^H{foo} correct after require\n";
+}
diff -urN perl-5.10.1-RC2.orig/t/comp/hints.aux perl-5.10.1-RC2.mod0/t/comp/hints.aux
--- perl-5.10.1-RC2.orig/t/comp/hints.aux	1970-01-01 01:00:00.000000000 +0100
+++ perl-5.10.1-RC2.mod0/t/comp/hints.aux	2009-08-21 00:01:34.000000000 +0100
@@ -0,0 +1,5 @@
+our($ra1, $ri1, $rf1, $rfe1);
+$ra1 = $[;
+BEGIN { $ri1 = $^H; $rf1 = $^H{foo}; $rfe1 = exists($^H{foo}); }
+
+1;

p5pRT · 2009-08-21T00:13:59Z

From perl@profvince.com

Attached is a patch that implements what we've been talking about:

* clearing %^H writes through to clear current lexical hints
* pp_require clears %^H
* @^H{qw($[ open< open>)} are visible when set by internals
* tests for most of this

Thanks for this patch.

I ported it to blead in the attached patch. Please check if there were
no errors in the transfer and use it version from now, as all changes go
in blead first (except for maint specific fixes). If you can't or don't
want to work with git, you can rsync the blead tree or get a snapshot of
the last state of the art at
http://perl5.git.perl.org/perl.git/snapshot/HEAD.tar.gz

I've tested it and it breaks two tests :

$ ./perl harness io/layers.t
io/layers.t .. # Failed at io/layers.t line 117
# got 'encoding(cp1252)'
# expected 'open(UTF, "<:raw:encoding(utf8)", \''
io/layers.t .. 1/37 Attempt to free unreferenced scalar: SV 0x8406e18.
io/layers.t .. Failed 1/37 subtests

Test Summary Report

io/layers.t (Wstat: 0 Tests: 37 Failed: 1)
Failed test: 35
Files=1, Tests=37, 0 wallclock secs ( 0.04 usr 0.00 sys + 0.06 cusr
0.01 csys = 0.11 CPU)
Result: FAIL
Failed 1/1 test programs. 1/37 subtests failed.

$ ./perl harness ../lib/open.t
../lib/open.t .. semi-panic: attempt to dup freed string at
../lib/open.t line 190.
../lib/open.t .. Failed 23/23 subtests

Test Summary Report

../lib/open.t (Wstat: 11 Tests: 0 Failed: 0)
Non-zero wait status: 11
Parse errors: Bad plan. You planned 23 tests but ran 0.
Files=1, Tests=0, 0 wallclock secs ( 0.03 usr 0.01 sys + 0.03 cusr
0.00 csys = 0.07 CPU)
Result: FAIL
Failed 1/1 test programs. 0/0 subtests failed.

lib/open.t segfaults with backtrace :

#0 0x080d70a8 in Perl_sv_magic ()
#1 0x080c2744 in Perl_hv_copy_hints_hv ()
#2 0x080ef562 in Perl_save_hints ()
#3 0x0805f585 in Perl_block_start ()
#4 0x08095837 in Perl_yyparse ()
#5 0x08072740 in S_parse_body ()
#6 0x080732c1 in perl_parse ()
#7 0x0805e0d0 in main ()

Also, another test throws "unreferenced scalars" complaints :

$ ./perl harness ../lib/if.t
../lib/if.t .. Attempt to free unreferenced scalar: SV 0x9faf124 at
(eval 1) line 2.
Attempt to free unreferenced scalar: SV 0x9faf14c at (eval 1) line 2.
Attempt to free unreferenced scalar: SV 0x9fd302c at (eval 6) line 2.
Attempt to free unreferenced scalar: SV 0x9fd3004 at (eval 6) line 2.
../lib/if.t .. ok
All tests successful.
Files=1, Tests=5, 0 wallclock secs ( 0.02 usr + 0.01 sys = 0.03 CPU)
Result: PASS

Vincent.

p5pRT · 2009-08-21T00:13:59Z

From perl@profvince.com

0001-Add-clear-magic-to-H-so-that-the-HE-chain-is-reset.patch

From ca067fddb8db67943d5e1b468dd4383eaf577e22 Mon Sep 17 00:00:00 2001
From: Zefram <zefram@fysh.org>
Date: Fri, 21 Aug 2009 01:49:14 +0200
Subject: [PATCH] Add clear magic to %^H so that the HE chain is reset when you empty it.

This fixes [perl #68590] : %^H not lexical enough.
---
 MANIFEST         |    1 +
 cop.h            |   13 +++++++++----
 dump.c           |    1 +
 embed.fnc        |    1 +
 embed.h          |    2 ++
 mg.c             |   42 +++++++++++++++++++++++++++---------------
 perl.h           |   16 ++++++++++++++--
 pod/perlguts.pod |    2 +-
 pp_ctl.c         |    5 +----
 proto.h          |    6 ++++++
 sv.c             |    5 +++--
 t/comp/hints.aux |    5 +++++
 t/comp/hints.t   |   48 +++++++++++++++++++++++++++++++++++++++++++-----
 13 files changed, 114 insertions(+), 33 deletions(-)
 create mode 100644 t/comp/hints.aux

diff --git a/MANIFEST b/MANIFEST
index 2fb8ee0..a5daf74 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3929,6 +3929,7 @@ t/comp/cmdopt.t			See if command optimization works
 t/comp/colon.t			See if colons are parsed correctly
 t/comp/decl.t			See if declarations work
 t/comp/fold.t			See if constant folding works
+t/comp/hints.aux		Auxillary file for %^H test
 t/comp/hints.t			See if %^H works
 t/comp/multiline.t		See if multiline strings work
 t/comp/opsubs.t			See if q() etc. are not parsed as functions
diff --git a/cop.h b/cop.h
index fc19494..3633e9d 100644
--- a/cop.h
+++ b/cop.h
@@ -246,12 +246,17 @@ struct cop {
 #define CopARYBASE_set(c, b) STMT_START { \
 	if (b || ((c)->cop_hints & HINT_ARYBASE)) {			\
 	    (c)->cop_hints |= HINT_ARYBASE;				\
-	    if ((c) == &PL_compiling)					\
-		PL_hints |= HINT_LOCALIZE_HH | HINT_ARYBASE;		\
-	    (c)->cop_hints_hash						\
-	       = Perl_refcounted_he_new(aTHX_ (c)->cop_hints_hash,	\
+	    if ((c) == &PL_compiling) {					\
+		SV *val = newSViv(b);					\
+		(void)hv_stores(GvHV(PL_hintgv), "$[", val);		\
+		mg_set(val);						\
+		PL_hints |= HINT_ARYBASE;				\
+	    } else {							\
+		(c)->cop_hints_hash					\
+		   = Perl_refcounted_he_new(aTHX_ (c)->cop_hints_hash,	\
 					newSVpvs_flags("$[", SVs_TEMP),	\
 					sv_2mortal(newSViv(b)));	\
+	    }								\
 	}								\
     } STMT_END
 
diff --git a/dump.c b/dump.c
index e7f5a1d..c891b2f 100644
--- a/dump.c
+++ b/dump.c
@@ -1261,6 +1261,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32
 	    else if (v == &PL_vtbl_utf8)       s = "utf8";
             else if (v == &PL_vtbl_arylen_p)   s = "arylen_p";
             else if (v == &PL_vtbl_hintselem)  s = "hintselem";
+            else if (v == &PL_vtbl_hints)      s = "hints";
 	    else			       s = NULL;
 	    if (s)
 	        Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", s);
diff --git a/embed.fnc b/embed.fnc
index 67a79f5..33774c7 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -535,6 +535,7 @@ Apd	|UV	|grok_oct	|NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV
 p	|int	|magic_clearenv	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_clear_all_env|NN SV* sv|NN MAGIC* mg
 dp	|int	|magic_clearhint|NN SV* sv|NN MAGIC* mg
+dp	|int	|magic_clearhints|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_clearisa	|NULLOK SV* sv|NN MAGIC* mg
 p	|int	|magic_clearpack|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_clearsig	|NN SV* sv|NN MAGIC* mg
diff --git a/embed.h b/embed.h
index b042886..5968fb6 100644
--- a/embed.h
+++ b/embed.h
@@ -423,6 +423,7 @@
 #define magic_clearenv		Perl_magic_clearenv
 #define magic_clear_all_env	Perl_magic_clear_all_env
 #define magic_clearhint		Perl_magic_clearhint
+#define magic_clearhints	Perl_magic_clearhints
 #define magic_clearisa		Perl_magic_clearisa
 #define magic_clearpack		Perl_magic_clearpack
 #define magic_clearsig		Perl_magic_clearsig
@@ -2759,6 +2760,7 @@
 #define magic_clearenv(a,b)	Perl_magic_clearenv(aTHX_ a,b)
 #define magic_clear_all_env(a,b)	Perl_magic_clear_all_env(aTHX_ a,b)
 #define magic_clearhint(a,b)	Perl_magic_clearhint(aTHX_ a,b)
+#define magic_clearhints(a,b)	Perl_magic_clearhints(aTHX_ a,b)
 #define magic_clearisa(a,b)	Perl_magic_clearisa(aTHX_ a,b)
 #define magic_clearpack(a,b)	Perl_magic_clearpack(aTHX_ a,b)
 #define magic_clearsig(a,b)	Perl_magic_clearsig(aTHX_ a,b)
diff --git a/mg.c b/mg.c
index 5cfa8cb..3d95cf7 100644
--- a/mg.c
+++ b/mg.c
@@ -2391,31 +2391,23 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	    const char *const start = SvPV(sv, len);
 	    const char *out = (const char*)memchr(start, '\0', len);
 	    SV *tmp;
-	    struct refcounted_he *tmp_he;
 
 
 	    PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
-	    PL_hints
-		|= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
+	    PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
 
 	    /* Opening for input is more common than opening for output, so
 	       ensure that hints for input are sooner on linked list.  */
 	    tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
 				       SVs_TEMP | SvUTF8(sv))
 		: newSVpvs_flags("", SVs_TEMP | SvUTF8(sv));
+	    (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
+	    mg_set(tmp);
 
-	    tmp_he
-		= Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, 
-					 newSVpvs_flags("open>", SVs_TEMP),
-					 tmp);
-
-	    /* The UTF-8 setting is carried over  */
-	    sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len);
-
-	    PL_compiling.cop_hints_hash
-		= Perl_refcounted_he_new(aTHX_ tmp_he,
-					 newSVpvs_flags("open<", SVs_TEMP),
-					 tmp);
+	    tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
+				       SVs_TEMP | SvUTF8(sv));
+	    (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
+	    mg_set(tmp);
 	}
 	break;
     case '\020':	/* ^P */
@@ -3096,6 +3088,26 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
 }
 
 /*
+=for apidoc magic_clearhints
+
+Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
+
+=cut
+*/
+int
+Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
+{
+    PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
+    PERL_UNUSED_ARG(sv);
+    PERL_UNUSED_ARG(mg);
+    if (PL_compiling.cop_hints_hash) {
+	Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
+	PL_compiling.cop_hints_hash = NULL;
+    }
+    return 0;
+}
+
+/*
  * Local variables:
  * c-indentation-style: bsd
  * c-basic-offset: 4
diff --git a/perl.h b/perl.h
index 75c52e7..136bd53 100644
--- a/perl.h
+++ b/perl.h
@@ -4645,7 +4645,8 @@ enum {		/* pass one of these to get_vtbl */
     want_vtbl_utf8,
     want_vtbl_symtab,
     want_vtbl_arylen_p,
-    want_vtbl_hintselem
+    want_vtbl_hintselem,
+    want_vtbl_hints
 };
 
 
@@ -4950,7 +4951,6 @@ MGVTBL_SET(
     0
 );
 
-/* For now, hints magic will also use vtbl_sig, because it is all 0  */
 MGVTBL_SET(
     PL_vtbl_sig,
     0,
@@ -5315,6 +5315,18 @@ MGVTBL_SET(
     0
 );
 
+MGVTBL_SET(
+    PL_vtbl_hints,
+    0,
+    0,
+    0,
+    MEMBER_TO_FPTR(Perl_magic_clearhints),
+    0,
+    0,
+    0,
+    0
+);
+
 #include "overload.h"
 
 END_EXTERN_C
diff --git a/pod/perlguts.pod b/pod/perlguts.pod
index 2b6fd8c..afc69ae 100644
--- a/pod/perlguts.pod
+++ b/pod/perlguts.pod
@@ -1038,7 +1038,7 @@ The current kinds of Magic Virtual Tables are:
     e  PERL_MAGIC_envelem        vtbl_envelem    %ENV hash element
     f  PERL_MAGIC_fm             vtbl_fm         Formline ('compiled' format)
     g  PERL_MAGIC_regex_global   vtbl_mglob      m//g target / study()ed string
-    H  PERL_MAGIC_hints          vtbl_sig        %^H hash
+    H  PERL_MAGIC_hints          vtbl_hints      %^H hash
     h  PERL_MAGIC_hintselem      vtbl_hintselem  %^H hash element
     I  PERL_MAGIC_isa            vtbl_isa        @ISA array
     i  PERL_MAGIC_isaelem        vtbl_isaelem    @ISA array element
diff --git a/pp_ctl.c b/pp_ctl.c
index 35e3436..0eb513f 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3568,10 +3568,7 @@ PP(pp_require)
 
     SAVEHINTS();
     PL_hints = 0;
-    if (PL_compiling.cop_hints_hash) {
-	Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
-	PL_compiling.cop_hints_hash = NULL;
-    }
+    hv_clear(GvHV(PL_hintgv));
 
     SAVECOMPILEWARNINGS();
     if (PL_dowarn & G_WARN_ALL_ON)
diff --git a/proto.h b/proto.h
index 1b93673..5fe779a 100644
--- a/proto.h
+++ b/proto.h
@@ -1504,6 +1504,12 @@ PERL_CALLCONV int	Perl_magic_clearhint(pTHX_ SV* sv, MAGIC* mg)
 #define PERL_ARGS_ASSERT_MAGIC_CLEARHINT	\
 	assert(sv); assert(mg)
 
+PERL_CALLCONV int	Perl_magic_clearhints(pTHX_ SV* sv, MAGIC* mg)
+			__attribute__nonnull__(pTHX_1)
+			__attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_CLEARHINTS	\
+	assert(sv); assert(mg)
+
 PERL_CALLCONV int	Perl_magic_clearisa(pTHX_ SV* sv, MAGIC* mg)
 			__attribute__nonnull__(pTHX_2);
 #define PERL_ARGS_ASSERT_MAGIC_CLEARISA	\
diff --git a/sv.c b/sv.c
index b8daf81..b9f682c 100644
--- a/sv.c
+++ b/sv.c
@@ -5096,8 +5096,6 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
     case PERL_MAGIC_qr:
 	vtable = &PL_vtbl_regexp;
 	break;
-    case PERL_MAGIC_hints:
-	/* As this vtable is all NULL, we can reuse it.  */
     case PERL_MAGIC_sig:
 	vtable = &PL_vtbl_sig;
 	break;
@@ -5140,6 +5138,9 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
     case PERL_MAGIC_hintselem:
 	vtable = &PL_vtbl_hintselem;
 	break;
+    case PERL_MAGIC_hints:
+	vtable = &PL_vtbl_hints;
+	break;
     case PERL_MAGIC_ext:
 	/* Reserved for use by extensions not perl internals.	        */
 	/* Useful for attaching extension internal data to perl vars.	*/
diff --git a/t/comp/hints.aux b/t/comp/hints.aux
new file mode 100644
index 0000000..79b6dee
--- /dev/null
+++ b/t/comp/hints.aux
@@ -0,0 +1,5 @@
+our($ra1, $ri1, $rf1, $rfe1);
+$ra1 = $[;
+BEGIN { $ri1 = $^H; $rf1 = $^H{foo}; $rfe1 = exists($^H{foo}); }
+
+1;
diff --git a/t/comp/hints.t b/t/comp/hints.t
index 55aeb71..b19fc5f 100644
--- a/t/comp/hints.t
+++ b/t/comp/hints.t
@@ -8,7 +8,7 @@ BEGIN {
 }
 
 
-BEGIN { print "1..17\n"; }
+BEGIN { print "1..32\n"; }
 BEGIN {
     print "not " if exists $^H{foo};
     print "ok 1 - \$^H{foo} doesn't exist initially\n";
@@ -38,7 +38,7 @@ BEGIN {
     }
     BEGIN {
 	print "not " if $^H{foo} ne "a";
-	print "ok 6 - \$H^{foo} restored to 'a'\n";
+	print "ok 6 - \$^H{foo} restored to 'a'\n";
     }
     # The pragma settings disappear after compilation
     # (test at CHECK-time and at run-time)
@@ -95,14 +95,52 @@ print "# got: $result\n" if length $result;
 
 {
     BEGIN{$^H{x}=1};
-    for(1..2) {
+    for my $tno (16..17) {
         eval q(
-            print $^H{x}==1 && !$^H{y} ? "ok\n" : "not ok\n";
+            print $^H{x}==1 && !$^H{y} ? "ok $tno\n" : "not ok $tno\n";
             $^H{y} = 1;
         );
         if ($@) {
             (my $str = $@)=~s/^/# /gm;
-            print "not ok\n$str\n";
+            print "not ok $tno\n$str\n";
         }
     }
 }
+
+{
+    $[ = 11;
+    print +($[ == 11 ? "" : "not "), "ok 18 - setting \$[ affects \$[\n";
+    our $t11; BEGIN { $t11 = $^H{'$['} }
+    print +($t11 == 11 ? "" : "not "), "ok 19 - setting \$[ affects \$^H{'\$['}\n";
+
+    BEGIN { $^H{'$['} = 22 }
+    print +($[ == 22 ? "" : "not "), "ok 20 - setting \$^H{'\$['} affects \$[\n";
+    our $t22; BEGIN { $t22 = $^H{'$['} }
+    print +($t22 == 22 ? "" : "not "), "ok 21 - setting \$^H{'\$['} affects \$^H{'\$['}\n";
+
+    BEGIN { %^H = () }
+    print +($[ == 0 ? "" : "not "), "ok 22 - clearing \%^H affects \$[\n";
+    our $t0; BEGIN { $t0 = $^H{'$['} }
+    print +($t0 == 0 ? "" : "not "), "ok 23 - clearing \%^H affects \$^H{'\$['}\n";
+}
+
+{
+    $[ = 13;
+    BEGIN { $^H |= 0x04000000; $^H{foo} = "z"; }
+
+    our($ri0, $rf0); BEGIN { $ri0 = $^H; $rf0 = $^H{foo}; }
+    print +($[ == 13 ? "" : "not "), "ok 24 - \$[ correct before require\n";
+    print +($ri0 & 0x04000000 ? "" : "not "), "ok 25 - \$^H correct before require\n";
+    print +($rf0 eq "z" ? "" : "not "), "ok 26 - \$^H{foo} correct before require\n";
+
+    our($ra1, $ri1, $rf1, $rfe1);
+    BEGIN { require "comp/hints.aux"; }
+    print +($ra1 == 0 ? "" : "not "), "ok 27 - \$[ cleared for require\n";
+    print +(!($ri1 & 0x04000000) ? "" : "not "), "ok 28 - \$^H cleared for require\n";
+    print +(!defined($rf1) && !$rfe1 ? "" : "not "), "ok 29 - \$^H{foo} cleared for require\n";
+
+    our($ri2, $rf2); BEGIN { $ri2 = $^H; $rf2 = $^H{foo}; }
+    print +($[ == 13 ? "" : "not "), "ok 30 - \$[ correct after require\n";
+    print +($ri2 & 0x04000000 ? "" : "not "), "ok 31 - \$^H correct after require\n";
+    print +($rf2 eq "z" ? "" : "not "), "ok 32 - \$^H{foo} correct after require\n";
+}
-- 
1.6.0.4.724.ga0d3a

p5pRT · 2009-08-21T09:42:14Z

From zefram@fysh.org

Vincent Pit wrote:

I've tested it and it breaks two tests :
Also, another test throws "unreferenced scalars" complaints :

These are all using I/O layers. Pretty clear where the bug is, then.
I believe I should have removed the SVs_TEMP flags from the scalar
constructors in the qw(open< open>) code. That's what you (I) get for
not writing tests.

I also forgot to patch MANIFEST, but you spotted that.

I'll make a revised patch tonight, unless you're happy to work just from
my description above.

-zefram

p5pRT · 2009-08-21T11:48:29Z

From perl@profvince.com

These are all using I/O layers. Pretty clear where the bug is, then.
I believe I should have removed the SVs_TEMP flags from the scalar
constructors in the qw(open< open>) code.

This makes sense and does fix the failures.

I've pushed the updated changed as f747ebd.

Thank you.

Vincent.

p5pRT · 2009-08-21T11:50:28Z

bitcard@profvince.com - Status changed from 'open' to 'resolved'

p5pRT closed this as completed Aug 21, 2009

p5pRT added Severity Medium distro-Linux type-core labels Oct 18, 2019

Provide feedback

Saved searches

Use saved searches to filter your results more quickly

%^H not lexical enough #9832

%^H not lexical enough #9832

p5pRT commented Aug 17, 2009

p5pRT commented Aug 17, 2009

p5pRT commented Aug 17, 2009

p5pRT commented Aug 17, 2009

p5pRT commented Aug 17, 2009

p5pRT commented Aug 17, 2009

p5pRT commented Aug 17, 2009

p5pRT commented Aug 20, 2009

p5pRT commented Aug 20, 2009

p5pRT commented Aug 21, 2009

p5pRT commented Aug 21, 2009

p5pRT commented Aug 21, 2009

p5pRT commented Aug 21, 2009

p5pRT commented Aug 21, 2009

%^H not lexical enough #9832

%^H not lexical enough #9832

Comments

p5pRT commented Aug 17, 2009

p5pRT commented Aug 17, 2009

From zefram@fysh.org

Created by zefram@fysh.org

p5pRT commented Aug 17, 2009

From perl@profvince.com

p5pRT commented Aug 17, 2009

p5pRT commented Aug 17, 2009

From @nwc10

p5pRT commented Aug 17, 2009

From zefram@fysh.org

p5pRT commented Aug 17, 2009

From perl@profvince.com

p5pRT commented Aug 20, 2009

From zefram@fysh.org

p5pRT commented Aug 20, 2009

From zefram@fysh.org

p5pRT commented Aug 21, 2009

From perl@profvince.com

p5pRT commented Aug 21, 2009

From perl@profvince.com

p5pRT commented Aug 21, 2009

From zefram@fysh.org

p5pRT commented Aug 21, 2009

From perl@profvince.com

p5pRT commented Aug 21, 2009