Allow package name in ‘use constant’ constants

See the thread that includes
<20140821044934.29399.qmail@lists-nntp.develooper.com>.

This provides a way for a package to define constants in another pack-
age, without having to resort to *other::const = sub () { $value }.
Now one can write constant->import("other::const" => $value).

Documentation will be added in an upcoming commit.

diff --git a/dist/constant/lib/constant.pm b/dist/constant/lib/constant.pm
index 5d0d547..91a1451 100644 (file)
--- a/dist/constant/lib/constant.pm
+++ b/dist/constant/lib/constant.pm
@@ -56,13 +56,13 @@ sub import {
     return unless @_;                  # Ignore 'use constant;'
     my $constants;
     my $multiple  = ref $_[0];
-    my $pkg = caller;
+    my $caller = caller;
     my $flush_mro;
     my $symtab;
 
     if (_CAN_PCS) {
        no strict 'refs';
-       $symtab = \%{$pkg . '::'};
+       $symtab = \%{$caller . '::'};
     };
 
     if ( $multiple ) {
@@ -80,6 +80,20 @@ sub import {
     }
 
     foreach my $name ( keys %$constants ) {
+       my $pkg;
+       my $symtab = $symtab;
+       my $orig_name = $name;
+       if ($name =~ s/(.*)(?:::|')(?=.)//s) {
+           $pkg = $1;
+           if (_CAN_PCS && $pkg ne $caller) {
+               no strict 'refs';
+               $symtab = \%{$pkg . '::'};
+           }
+       }
+       else {
+           $pkg = $caller;
+       }
+
        # Normal constant name
        if ($name =~ $normal_constant_name and !$forbidden{$name}) {
            # Everything is okay
@@ -127,7 +141,7 @@ sub import {
            my $full_name = "${pkg}::$name";
            $declared{$full_name}++;
            if ($multiple || @_ == 1) {
-               my $scalar = $multiple ? $constants->{$name} : $_[0];
+               my $scalar = $multiple ? $constants->{$orig_name} : $_[0];
 
                if (_DOWNGRADE) { # for 5.8 to 5.14
                    # Work around perl bug #31991: Sub names (actually glob
@@ -149,7 +163,7 @@ sub import {
                    Internals::SvREADONLY($scalar, 1);
                    if ($symtab && !exists $symtab->{$name}) {
                        $symtab->{$name} = \$scalar;
-                       ++$flush_mro;
+                       ++$flush_mro->{$pkg};
                    }
                    else {
                        local $constant::{_dummy} = \$scalar;
@@ -165,7 +179,7 @@ sub import {
                    _make_const(@list);
                    if ($symtab && !exists $symtab->{$name}) {
                        $symtab->{$name} = \@list;
-                       $flush_mro++;
+                       $flush_mro->{$pkg}++;
                    }
                    else {
                        local $constant::{_dummy} = \@list;
@@ -179,7 +193,9 @@ sub import {
        }
     }
     # Flush the cache exactly once if we make any direct symbol table changes.
-    mro::method_changed_in($pkg) if _CAN_PCS && $flush_mro;
+    if (_CAN_PCS && $flush_mro) {
+       mro::method_changed_in($_) for keys %$flush_mro;
+    }
 }
 
 1;

diff --git a/dist/constant/t/constant.t b/dist/constant/t/constant.t
index 159e217..00eddfb 100644 (file)
--- a/dist/constant/t/constant.t
+++ b/dist/constant/t/constant.t
@@ -9,7 +9,7 @@ END { @warnings && print STDERR join "\n- ", "accumulated warnings:", @warnings
 
 
 use strict;
-use Test::More tests => 105;
+use Test::More tests => 109;
 my $TB = Test::More->builder;
 
 BEGIN { use_ok('constant'); }
@@ -414,3 +414,10 @@ SKIP: {
     is $values[1], $values[0],
        'modifying list const elements does not affect future retavls';
 }
+
+use constant { "tahi" => 1, "rua::rua" => 2, "toru'toru" => 3 };
+use constant "wha::wha" => 4;
+is tahi, 1, 'unqualified constant declared with constants in other pkgs';
+is rua::rua, 2, 'constant declared with ::';
+is toru::toru, 3, "constant declared with '";
+is wha::wha, 4, 'constant declared by itself with ::';