vars.pm to support qualified variables (was Re: [ID 20010521.001])

Sender: "M.J.T. Guy" <mjtg@cus.cam.ac.uk>

p4raw-id: //depot/perl@10178

diff --git a/MANIFEST b/MANIFEST
index 21792ab..e2a1fdc 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1812,6 +1812,7 @@ t/pragma/strict.t See if strictures work
 t/pragma/sub_lval.t    See if lvalue subroutines work
 t/pragma/subs.t                See if subroutine pseudo-importation works
 t/pragma/utf8.t                See if utf8 operations work
+t/pragma/vars.t                See if "use vars" work
 t/pragma/warn/1global  Tests of global warnings for warnings.t
 t/pragma/warn/2use     Tests for "use warnings" for warnings.t
 t/pragma/warn/3both    Tests for interaction of $^W and "use warnings"

diff --git a/lib/vars.pm b/lib/vars.pm
index d39f197..4f3bddf 100644 (file)
--- a/lib/vars.pm
+++ b/lib/vars.pm
@@ -17,31 +17,29 @@ require strict;
 sub import {
     my $callpack = caller;
     my ($pack, @imports, $sym, $ch) = @_;
-    foreach $sym (@imports) {
-        ($ch, $sym) = unpack('a1a*', $sym);
+    foreach (@imports) {
+        ($ch, $sym) = unpack('a1a*', $_);
        if ($sym =~ tr/A-Za-z_0-9//c) {
            # time for a more-detailed check-up
-           if ($sym =~ /::/) {
-               require Carp;
-               Carp::croak("Can't declare another package's variables");
-           } elsif ($sym =~ /^\w+[[{].*[]}]$/) {
+           if ($sym =~ /^\w+[[{].*[]}]$/) {
                require Carp;
                Carp::croak("Can't declare individual elements of hash or array");
            } elsif (warnings::enabled() and length($sym) == 1 and $sym !~ tr/a-zA-Z//) {
                warnings::warn("No need to declare built-in vars");
             } elsif  ( $^H &= strict::bits('vars') ) {
-              Carp::croak("'$ch$sym' is not a valid variable name under strict vars");
+              Carp::croak("'$_' is not a valid variable name under strict vars");
            }
        }
-        *{"${callpack}::$sym"} =
-          (  $ch eq "\$" ? \$   {"${callpack}::$sym"}
-           : $ch eq "\@" ? \@   {"${callpack}::$sym"}
-           : $ch eq "\%" ? \%   {"${callpack}::$sym"}
-           : $ch eq "\*" ? \*   {"${callpack}::$sym"}
-           : $ch eq "\&" ? \&   {"${callpack}::$sym"}
+       $sym = "${callpack}::$sym" unless $sym =~ /::/;
+        *$sym =
+          (  $ch eq "\$" ? \$$sym
+           : $ch eq "\@" ? \@$sym
+           : $ch eq "\%" ? \%$sym
+           : $ch eq "\*" ? \*$sym
+           : $ch eq "\&" ? \&$sym
            : do {
                require Carp;
-               Carp::croak("'$ch$sym' is not a valid variable name");
+               Carp::croak("'$_' is not a valid variable name");
             });
     }
 };
@@ -59,9 +57,9 @@ vars - Perl pragma to predeclare global variable names (obsolete)
 
 =head1 DESCRIPTION
 
-NOTE: The functionality provided by this pragma has been superseded
-by C<our> declarations, available in Perl v5.6.0 or later.  See
-L<perlfunc/our>.
+NOTE: For variables in the current package, the functionality provided
+by this pragma has been superseded by C<our> declarations, available
+in Perl v5.6.0 or later.  See L<perlfunc/our>.
 
 This will predeclare all the variables whose names are 
 in the list, allowing you to use them under "use strict", and

diff --git a/t/lib/1_compile.t b/t/lib/1_compile.t
index f1196f4..2190e35 100644 (file)
--- a/t/lib/1_compile.t
+++ b/t/lib/1_compile.t
@@ -241,6 +241,5 @@ overload
 strict
 subs
 utf8
-vars
 warnings
 warnings::register

diff --git a/t/pragma/vars.t b/t/pragma/vars.t
new file mode 100644 (file)
index 0000000..3075f8e
--- /dev/null
+++ b/t/pragma/vars.t
@@ -0,0 +1,105 @@
+#!./perl 
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    $ENV{PERL5LIB} = '../lib';
+}
+
+$| = 1;
+
+print "1..27\n";
+
+# catch "used once" warnings
+my @warns;
+BEGIN { $SIG{__WARN__} = sub { push @warns, @_ }; $^W = 1 };
+
+%x = ();
+$y = 3;
+@z = ();
+$X::x = 13;
+
+use vars qw($p @q %r *s &t $X::p);
+
+my $e = !(grep /^Name "X::x" used only once: possible typo/, @warns) && 'not ';
+print "${e}ok 1\n";
+$e = !(grep /^Name "main::x" used only once: possible typo/, @warns) && 'not ';
+print "${e}ok 2\n";
+$e = !(grep /^Name "main::y" used only once: possible typo/, @warns) && 'not ';
+print "${e}ok 3\n";
+$e = !(grep /^Name "main::z" used only once: possible typo/, @warns) && 'not ';
+print "${e}ok 4\n";
+($e, @warns) = @warns != 4 && 'not ';
+print "${e}ok 5\n";
+
+# this is inside eval() to avoid creation of symbol table entries and
+# to avoid "used once" warnings
+eval <<'EOE';
+$e = ! $main::{p} && 'not ';
+print "${e}ok 6\n";
+$e = ! *q{ARRAY} && 'not ';
+print "${e}ok 7\n";
+$e = ! *r{HASH} && 'not ';
+print "${e}ok 8\n";
+$e = ! $main::{s} && 'not ';
+print "${e}ok 9\n";
+$e = ! *t{CODE} && 'not ';
+print "${e}ok 10\n";
+$e = defined $X::{q} && 'not ';
+print "${e}ok 11\n";
+$e = ! $X::{p} && 'not ';
+print "${e}ok 12\n";
+EOE
+$e = $@ && 'not ';
+print "${e}ok 13\n";
+
+eval q{use vars qw(@X::y !abc); $e = ! *X::y{ARRAY} && 'not '};
+print "${e}ok 14\n";
+$e = $@ !~ /^'!abc' is not a valid variable name/ && 'not ';
+print "${e}ok 15\n";
+
+eval 'use vars qw($x[3])';
+$e = $@ !~ /^Can't declare individual elements of hash or array/ && 'not ';
+print "${e}ok 16\n";
+
+{ local $^W;
+  eval 'use vars qw($!)';
+  ($e, @warns) = ($@ || @warns) ? 'not ' : '';
+  print "${e}ok 17\n";
+};
+
+# NB the next test only works because vars.pm has already been loaded
+eval 'use warnings "vars"; use vars qw($!)';
+$e = ($@ || (shift(@warns)||'') !~ /^No need to declare built-in vars/)
+                       && 'not ';
+print "${e}ok 18\n";
+
+no strict 'vars';
+eval 'use vars qw(@x%%)';
+$e = $@ && 'not ';
+print "${e}ok 19\n";
+$e = ! *{'x%%'}{ARRAY} && 'not ';
+print "${e}ok 20\n";
+eval '$u = 3; @v = (); %w = ()';
+$e = $@ && 'not ';
+print "${e}ok 21\n";
+
+use strict 'vars';
+eval 'use vars qw(@y%%)';
+$e = $@ !~ /^'\@y%%' is not a valid variable name under strict vars/ && 'not ';
+print "${e}ok 22\n";
+$e = *{'y%%'}{ARRAY} && 'not ';
+print "${e}ok 23\n";
+eval '$u = 3; @v = (); %w = ()';
+my @errs = split /\n/, $@;
+$e = @errs != 3 && 'not ';
+print "${e}ok 24\n";
+$e = !(grep(/^Global symbol "\$u" requires explicit package name/, @errs))
+                       && 'not ';
+print "${e}ok 25\n";
+$e = !(grep(/^Global symbol "\@v" requires explicit package name/, @errs))
+                       && 'not ';
+print "${e}ok 26\n";
+$e = !(grep(/^Global symbol "\%w" requires explicit package name/, @errs))
+                       && 'not ';
+print "${e}ok 27\n";