Make it possible to get exports without symbol table munging

3 files changed, 277 insertions, 18 deletions

diff --git a/Changes b/Changes
index ac69670..af306e1 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,8 @@
 {{$NEXT}}
 
+    - New Feature: Custom export asignments
+    - New Feature: Get exports as hash/list/ref
+
 0.007     2016-01-23 21:22:00-08:00 America/Los_Angeles
 
     - Less warnings/strict pragmas scattered everywhere
diff --git a/lib/Importer.pm b/lib/Importer.pm
index 50a8e50..3cacc6e 100644
--- a/lib/Importer.pm
+++ b/lib/Importer.pm
@@ -69,7 +69,6 @@ sub unimport {
     $self->do_unimport(@_);
 }
 
-
 sub import_into {
     my $class = shift;
     my ($from, $into, @args) = @_;
@@ -145,13 +144,60 @@ sub new {
 
 ###########################################################################
 #
+# Shortcuts for getting symbols without any namespace modifications
+#
+
+sub get {
+    my $proto = shift;
+    my @caller = caller(1);
+
+    my $self = ref($proto) ? $proto : $proto->new(
+        from   => shift(@_),
+        caller => \@caller,
+    );
+
+    my %result;
+    $self->do_import($caller[0], @_, sub { $result{$_[0]} = $_[1] });
+    return \%result;
+}
+
+sub get_list {
+    my $proto = shift;
+    my @caller = caller(1);
+
+    my $self = ref($proto) ? $proto : $proto->new(
+        from   => shift(@_),
+        caller => \@caller,
+    );
+
+    my @result;
+    $self->do_import($caller[0], @_, sub { push @result => $_[1] });
+    return @result;
+}
+
+sub get_one {
+    my $proto = shift;
+    my @caller = caller(1);
+
+    my $self = ref($proto) ? $proto : $proto->new(
+        from   => shift(@_),
+        caller => \@caller,
+    );
+
+    my $result;
+    $self->do_import($caller[0], @_, sub { $result = $_[1] });
+    return $result;
+}
+
+###########################################################################
+#
 # Object methods
 #
 
 sub do_import {
     my $self = shift;
 
-    my ($into, $versions, $exclude, $import) = $self->parse_args(@_);
+    my ($into, $versions, $exclude, $import, $set) = $self->parse_args(@_);
 
     # Exporter supported multiple version numbers being listed...
     _version_check($self->from, $self->get_caller, @$versions) if @$versions;
@@ -159,7 +205,7 @@ sub do_import {
     return unless @$import;
 
     $self->_handle_fail($into, $import) if $self->menu($into)->{fail};
-    $self->_set_symbols($into, $exclude, $import);
+    $self->_set_symbols($into, $exclude, $import, $set);
 }
 
 sub do_unimport {
@@ -375,6 +421,7 @@ sub parse_args {
     my %exclude;
     my @import;
     my @versions;
+    my $set;
 
     while(my $full_arg = shift @args) {
         my $arg = $full_arg;
@@ -386,6 +433,12 @@ sub parse_args {
             push @versions => $arg;
             next;
         }
+        elsif(ref($arg) eq 'CODE') {
+            $self->carp("Multiple setters specified, only 1 will be used") if $set;
+            $set = $arg;
+            unshift @args => ':DEFAULT' unless @args || @import || keys %exclude || @versions;
+            next;
+        }
 
         if ($lead eq '!') {
             $exc = $lead;
@@ -409,7 +462,7 @@ sub parse_args {
         else {
             # If the item is followed by a reference then they are asking us to
             # do something special...
-            $spec = ref($args[0]) ? shift @args : {};
+            $spec = ref($args[0]) eq 'HASH' ? shift @args : {};
         }
 
         # Process the item to figure out what symbols are being touched, if it
@@ -447,7 +500,7 @@ sub parse_args {
         }
     }
 
-    return ($into, \@versions, \%exclude, \@import);
+    return ($into, \@versions, \%exclude, \@import, $set);
 }
 
 sub _handle_fail {
@@ -475,7 +528,7 @@ sub _handle_fail {
 
 sub _set_symbols {
     my $self = shift;
-    my ($into, $exclude, $import) = @_;
+    my ($into, $exclude, $import, $custom_set) = @_;
 
     my $from   = $self->from;
     my $menu   = $self->menu($into);
@@ -483,7 +536,7 @@ sub _set_symbols {
 
     # Turn of strict 'refs' for the sub we generate. Doing this here instead of
     # in the eval is faster since it only runs once.
-    my $set_symbol = eval <<"    EOT" || die $@;
+    my $set_symbol = $custom_set || eval <<"    EOT" || die $@;
 # Inherit the callers warning settings. If they have warnings and we
 # redefine their subs they will hear about it. If they do not have warnings
 # on they will not.
@@ -519,7 +572,7 @@ sub { *{"$into\\::\$_[0]"} = \$_[1] }
 
         my $new_name = join '' => ($spec->{'-prefix'} || '', $spec->{'-as'} || $name, $spec->{'-postfix'} || '');
 
-        push @{$IMPORTED{$into}} => $new_name if $sig eq '&';
+        push @{$IMPORTED{$into}} => $new_name if $sig eq '&' && !$custom_set;
 
         # Set the symbol (finally!)
         $set_symbol->($new_name, $ref);
@@ -688,7 +741,7 @@ feature (like import renaming).
 
 =head1 IMPORT PARAMETERS
 
-    use Importer $IMPORTER_VERSION, $FROM_MODULE, $FROM_MODULE_VERSION, @SYMBOLS;
+    use Importer $IMPORTER_VERSION, $FROM_MODULE, $FROM_MODULE_VERSION, \&SET_SYMBOL, @SYMBOLS;
 
 =over 4
 
@@ -708,6 +761,25 @@ symbols from.
 Any numeric argument following the C<$FROM_MODULE> will be treated as a version
 check against C<$FROM_MODULE>.
 
+=item \&SET_SYMBOL (optional)
+
+Normally Importer will put the exports into your namespace. This is usually
+done via a more complex form of C<*name = $ref>. If you do NOT want this to
+happen then you can provide a custom sub to handle the assignment.
+
+This is an example that uses this feature to put all the exports into a lexical
+hash instead of modifying the namespace (This is how the C<get()> method is
+implemented).
+
+    my %CARP;
+    use Importer Carp => sub {
+        my ($name, $ref) = @_;
+        $CARP{$name} = $ref;
+    };
+
+    $CARP{cluck}->("This will cluck");
+    $CARP{croak}->("This will croak");
+
 =item @SYMBOLS (optional)
 
 Symbols you wish to import. If no symbols are specified then the defaults will
@@ -763,6 +835,11 @@ Using this syntax to set prefix and/or postfix also works on tags and patterns
 that are specified for import, in which case the prefix/postfix is applied to
 all symbols from the tag/patterm.
 
+=head2 CUSTOM EXPORT ASSIGNMENT
+
+This lets you provide an alternative to the C<*name = $ref> export assingment.
+See the list of L<parameters|/"IMPORT PARAMETERS"> to C<import()>
+
 =head2 UNIMPORTING
 
 See L</UNIMPORT PARAMETERS>.
@@ -896,6 +973,26 @@ This is the magic behind C<no Importer ...>.
 This lets you remove imported symbols from C<$from>. C<$from> my be a package
 name, or a caller level.
 
+=item my $exports = Importer->get($from, @imports)
+
+This returns hashref of C<< { $name => $ref } >> for all the specified imports.
+
+C<$from> should be the package from which to get the exports.
+
+=item my @export_refs = Importer->get_list($from, @imports)
+
+This returns a list of references for each import specified. Only the export
+references are returned, the names are not.
+
+C<$from> should be the package from which to get the exports.
+
+=item $export_ref = Importer->get_one($from, $import)
+
+This returns a single reference to a single export. If you provide multiple
+imports then only the LAST one will be used.
+
+C<$from> should be the package from which to get the exports.
+
 =back
 
 =head1 USING WITH OTHER EXPORTER IMPLEMENTATIONS
@@ -1003,9 +1100,9 @@ C<do_unimport()>. For import 'from' us used as the origin, in unimport it is
 used as the target. This means you cannot re-use an instance to import and then
 unimport.
 
-=item ($into, $versions, $exclude, $symbols) = $imp->parse_args('Dest::Package')
+=item ($into, $versions, $exclude, $symbols, $set) = $imp->parse_args('Dest::Package')
 
-=item ($into, $versions, $exclude, $symbols) = $imp->parse_args('Dest::Package', @symbols)
+=item ($into, $versions, $exclude, $symbols, $set) = $imp->parse_args('Dest::Package', @symbols)
 
 This parses arguments. The first argument must be the destination package.
 Other arguments can be a mix of symbol names, tags, patterns, version numbers,
@@ -1077,6 +1174,20 @@ The menu structure looks like this:
 
 This will reload the export menu from the C<from> package.
 
+=item my $exports = $imp->get(@imports)
+
+This returns hashref of C<< { $name => $ref } >> for all the specified imports.
+
+=item my @export_refs = $imp->get_list(@imports)
+
+This returns a list of references for each import specified. Only the export
+references are returned, the names are not.
+
+=item $export_ref = $imp->get_one($import)
+
+This returns a single reference to a single export. If you provide multiple
+imports then only the LAST one will be used.
+
 =back
 
 =head1 SOURCE
diff --git a/t/units.t b/t/units.t
index f56bb57..0519d9a 100644
--- a/t/units.t
+++ b/t/units.t
@@ -32,6 +32,25 @@ sub warns(&) {
     return $warn || $warned;
 }
 
+
+###
+# These cannot be inside a subtest because of the lexical scopeing
+{
+    my %CARP;
+    use Importer Carp => qw/croak confess/, sub {
+        my ($name, $ref) = @_;
+        $CARP{$name} = $ref;
+    };
+    is_deeply(
+        \%CARP,
+        {
+            croak => \&Carp::croak,
+            confess => \&Carp::confess,
+        },
+        "Exports went into the hash."
+    );
+}
+
 subtest _version_check => sub {
     my $version_check = $CLASS->can('_version_check');
 
@@ -514,11 +533,45 @@ subtest parse_args => sub {
                 ['$ZAP', {}],
                 ['%ZAP', {}],
                 ['@ZAP', {}],
-            ]
+            ],
+            undef,
         ],
         "Got defaults with empty list"
     );
 
+    my $set = sub { 1 };
+    is_deeply(
+        [$one->parse_args('Dest', $set)],
+        [
+            'Dest',
+            [],
+            {},
+            [
+                ['&foo', {}],
+                ['&bar', {}],
+                ['$ZAP', {}],
+                ['%ZAP', {}],
+                ['@ZAP', {}],
+            ],
+            $set,
+        ],
+        "Got defaults with empty list + custom setter"
+    );
+
+    is_deeply(
+        [$one->parse_args('Dest', 'foo', $set)],
+        [
+            'Dest',
+            [],
+            {},
+            [
+                ['&foo', {}],
+            ],
+            $set,
+        ],
+        "Got defaults with 1 item + custom setter"
+    );
+
     is_deeply(
         [$one->parse_args('Dest', '!bar')],
         [
@@ -531,7 +584,8 @@ subtest parse_args => sub {
                 ['$ZAP', {}],
                 ['%ZAP', {}],
                 ['@ZAP', {}],
-            ]
+            ],
+            undef,
         ],
         "Got defaults, exclude bar"
     );
@@ -548,7 +602,8 @@ subtest parse_args => sub {
                 ['$ZAP', {}],
                 ['%ZAP', {}],
                 ['@ZAP', {}],
-            ]
+            ],
+            undef,
         ],
         "Got defaults, exclude bar"
     );
@@ -565,7 +620,8 @@ subtest parse_args => sub {
                 ['$ZAP', {}],
                 ['%ZAP', {}],
                 ['@ZAP', {}],
-            ]
+            ],
+            undef,
         ],
         "Got defaults, exclude :b"
     );
@@ -581,7 +637,8 @@ subtest parse_args => sub {
                 ['&baz', {-prefix => 'foo_'}],
                 ['&x', {}],
                 ['&y', {}],
-            ]
+            ],
+            undef,
         ],
         "Spec for tag"
     );
@@ -596,7 +653,8 @@ subtest parse_args => sub {
                 ['$ZAP', {-postfix => '_foo'}],
                 ['%ZAP', {-postfix => '_foo'}],
                 ['@ZAP', {-postfix => '_foo'}],
-            ]
+            ],
+            undef,
         ],
         "Spec for pattern"
     );
@@ -611,7 +669,8 @@ subtest parse_args => sub {
                 ['$ZAP', {-postfix => '_foo'}],
                 ['%ZAP', {-postfix => '_foo'}],
                 ['@ZAP', {-postfix => '_foo'}],
-            ]
+            ],
+            undef,
         ],
         "Spec for qr// (also test version)"
     );
@@ -914,4 +973,90 @@ subtest _optimal_import => sub {
     ok(!FDestD->can('foo'), "Removed 'foo'");
 };
 
+subtest get => sub {
+    is_deeply(
+        Importer->get(Carp => qw/croak confess/),
+        {
+            croak => \&Carp::croak,
+            confess => \&Carp::confess,
+        },
+        "Exports went into the hash (class)."
+    );
+
+    is_deeply(
+        Importer->new(from => 'Carp')->get(qw/croak confess/),
+        {
+            croak => \&Carp::croak,
+            confess => \&Carp::confess,
+        },
+        "Exports went into the hash (instance)."
+    );
+};
+
+subtest get_list => sub {
+    is_deeply(
+        [Importer->get_list(Carp => qw/croak confess/)],
+        [ \&Carp::croak, \&Carp::confess ],
+        "list of refs (class)."
+    );
+
+    is_deeply(
+        [Importer->new(from => 'Carp')->get_list(qw/croak confess/)],
+        [ \&Carp::croak, \&Carp::confess ],
+        "list of refs (instance)."
+    );
+};
+
+subtest get_one => sub {
+    is_deeply(
+        Importer->get_one(Carp => qw/confess/),
+        \&Carp::confess,
+        "one ref (class)."
+    );
+
+    is_deeply(
+        Importer->new(from => 'Carp')->get_one(qw/croak/),
+        \&Carp::croak,
+        "one ref (instance)."
+    );
+
+    is_deeply(
+        Importer->get_one(Carp => qw/confess croak/),
+        \&Carp::croak,
+        "one ref (last)."
+    );
+};
+
 done_testing;
+
+__END__
+
+sub get_list {
+    my $proto = shift;
+    my @caller = caller(1);
+
+    my $self = ref($proto) ? $proto : $proto->new(
+        from   => shift(@_),
+        caller => \@caller,
+    );
+
+    my @result;
+    $self->do_import($caller[0], @_, sub { push @result => $_[1] });
+    return @result;
+}
+
+sub get_one {
+    my $proto = shift;
+    my @caller = caller(1);
+
+    my $self = ref($proto) ? $proto : $proto->new(
+        from   => shift(@_),
+        caller => \@caller,
+    );
+
+    my $result;
+    $self->do_import($caller[0], @_, sub { $result = $_[1] });
+    return $result;
+}
+
+