Finish testing, version bump

4 files changed, 670 insertions, 313 deletions

diff --git a/Changes b/Changes
index 92f9628..443aa19 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,9 @@
 {{$NEXT}}
 
+    - Finish testing
+    - Bug fixes
+    - documentation
+
 0.003     2016-01-17 23:19:45-08:00 America/Los_Angeles
 
     - Optimized path for most-common import condition
diff --git a/lib/Importer.pm b/lib/Importer.pm
index 5069696..b353cfe 100644
--- a/lib/Importer.pm
+++ b/lib/Importer.pm
@@ -2,9 +2,7 @@ package Importer;
 use strict;
 use warnings;
 
-our $VERSION = 0.003;
-
-our @EXPORT_OK = qw/exporter_import/;
+our $VERSION = 0.004;
 
 my %SIG_TO_SLOT = (
     '&' => 'CODE',
@@ -20,11 +18,18 @@ my %IMPORTED;
 my %NUMERIC = map { $_ => 1 } 0 .. 9;
 
 # If a consumer just wants subs then we can optimize the import. This is used
-# as a lookup table to find non-optimal sigils. Can;t just look for '&' since a
+# as a lookup table to find non-optimal sigils. Can't just look for '&' since a
 # sub can be listed without a sigil, so alpha-numerics may also be checked
 # against thi stable, and we want those to be considered optimal.
 my %NON_OPTIMAL = ( '$' => 1, '@' => 1, '%' => 1, '*' => 1 );
 
+###########################################################################
+#
+# This is a method intended to be used as 'import' by packages that want to
+# export on use.
+#
+
+our @EXPORT_OK = qw/exporter_import/;
 sub exporter_import {
     my $from = shift;
 
@@ -35,7 +40,7 @@ sub exporter_import {
     my $file = _mod_to_file($from);
     _load_file(\@caller, $file) unless $INC{$file};
 
-    return if _optimal_import($from, $caller[0], @_);
+    return if _optimal_import($from, $caller[0], \@caller, @_);
 
     my $self = __PACKAGE__->new(
         from   => $from,
@@ -45,6 +50,17 @@ sub exporter_import {
     $self->do_import($caller[0], @_);
 }
 
+###########################################################################
+#
+# These are class methods
+# import and unimport are what you would expect.
+# import_into and unimport_from are the indirect forms you can use in other
+# package import() methods.
+#
+# These all attempt to do a fast optimal-import if possible, then fallback to
+# the full-featured import that constructs an object when needed.
+#
+
 sub import {
     my $class = shift;
 
@@ -59,7 +75,7 @@ sub import {
     my $file = _mod_to_file($from);
     _load_file(\@caller, $file) unless $INC{$file};
 
-    return if _optimal_import($from, $caller[0], @args);
+    return if _optimal_import($from, $caller[0], \@caller, @args);
 
     my $self = $class->new(
         from   => $from,
@@ -69,6 +85,19 @@ sub import {
     $self->do_import($caller[0], @args);
 }
 
+sub unimport {
+    my $class = shift;
+    my @caller = caller(0);
+
+    my $self = $class->new(
+        from   => $caller[0],
+        caller => \@caller,
+    );
+
+    $self->do_unimport(@_);
+}
+
+
 sub import_into {
     my $class = shift;
     my ($from, $into, @args) = @_;
@@ -86,7 +115,7 @@ sub import_into {
     my $file = _mod_to_file($from);
     _load_file(\@caller, $file) unless $INC{$file};
 
-    return if _optimal_import($from, $into, @args);
+    return if _optimal_import($from, $into, \@caller, @args);
 
     my $self = $class->new(
         from   => $from,
@@ -96,32 +125,6 @@ sub import_into {
     $self->do_import($into, @args);
 }
 
-sub do_import {
-    my $self = shift;
-
-    my ($into, $versions, $exclude, $import) = $self->parse_args(@_);
-
-    # Exporter supported multiple version numbers being listed...
-    _version_check($self->from, $self->get_caller, @$versions) if @$versions;
-
-    return unless @$import;
-
-    $self->_handle_fail($into, $import) if $self->menu($into)->{fail};
-    $self->_set_symbols($into, $exclude, $import);
-}
-
-sub unimport {
-    my $class = shift;
-    my @caller = caller(0);
-
-    my $self = $class->new(
-        from   => $caller[0],
-        caller => \@caller,
-    );
-
-    $self->do_unimport(@_);
-}
-
 sub unimport_from {
     my $class = shift;
     my ($from, @args) = @_;
@@ -143,11 +146,50 @@ sub unimport_from {
     $self->do_unimport(@args);
 }
 
+###########################################################################
+#
+# Constructors
+#
+
+sub new {
+    my $class = shift;
+    my %params = @_;
+
+    my $caller = $params{caller} || [caller()];
+
+    die "You must specify a package to import from at $caller->[1] line $caller->[2].\n"
+        unless $params{from};
+
+    return bless {
+        from   => $params{from},
+        caller => $params{caller},    # Do not use our caller.
+    }, $class;
+}
+
+###########################################################################
+#
+# Object methods
+#
+
+sub do_import {
+    my $self = shift;
+
+    my ($into, $versions, $exclude, $import) = $self->parse_args(@_);
+
+    # Exporter supported multiple version numbers being listed...
+    _version_check($self->from, $self->get_caller, @$versions) if @$versions;
+
+    return unless @$import;
+
+    $self->_handle_fail($into, $import) if $self->menu($into)->{fail};
+    $self->_set_symbols($into, $exclude, $import);
+}
+
 sub do_unimport {
     my $self = shift;
 
     my $from = $self->from;
-    my $imported = $IMPORTED{$from} || $self->croak("'$from' does not have any imports to remove");
+    my $imported = $IMPORTED{$from} or $self->croak("'$from' does not have any imports to remove");
 
     my %allowed = map { $_ => 1 } @$imported;
 
@@ -174,21 +216,6 @@ sub do_unimport {
     }
 }
 
-sub new {
-    my $class = shift;
-    my %params = @_;
-
-    my $caller = $params{caller} || [caller()];
-
-    die "You must specify a package to import from at $caller->[1] line $caller->[2].\n"
-        unless $params{from};
-
-    return bless {
-        from   => $params{from},
-        caller => $params{caller},    # Do not use our caller.
-    }, $class;
-}
-
 sub from { $_[0]->{from} }
 
 sub from_file {
@@ -380,21 +407,21 @@ sub parse_args {
         }
 
         if ($lead eq '!') {
-            my $exc = $lead;
+            $exc = $lead;
 
             if ($arg eq '!') {
                 # If the current arg is just '!' then we are negating the next item.
-                $arg = shift;
+                $arg = shift @args;
             }
             else {
                 # Strip off the '!'
                 substr($arg, 0, 1, '');
-
-                # Exporter.pm legacy behavior
-                # negated first item implies starting with default set:
-                unshift @args => ':DEFAULT' unless @import || keys %exclude || @versions;
             }
 
+            # Exporter.pm legacy behavior
+            # negated first item implies starting with default set:
+            unshift @args => ':DEFAULT' unless @import || keys %exclude || @versions;
+
             # Now we have a new lead character
             $lead = substr($arg, 0, 1);
         }
@@ -408,16 +435,16 @@ sub parse_args {
         # is a tag or regex than it can be multiple.
         my @list;
         if(ref($arg) eq 'Regexp') {
-            @list = grep /$arg/, keys %{$menu->{lookup}};
+            @list = sort grep /$arg/, keys %{$menu->{lookup}};
         }
-        if($lead eq ':') {
+        elsif($lead eq ':') {
             substr($arg, 0, 1, '');
-            my $tag = $menu->{tags}->{$arg} or croak "$from does not export the :$arg tag";
+            my $tag = $menu->{tags}->{$arg} or $self->croak("$from does not export the :$arg tag");
             @list = @$tag;
         }
         elsif($lead eq '/' && $arg =~ m{^/(.*)/$}) {
             my $pattern = $1;
-            @list = grep /$1/, keys %{$menu->{lookup}};
+            @list = sort grep /$1/, keys %{$menu->{lookup}};
         }
         else {
             @list = ($arg);
@@ -427,6 +454,7 @@ sub parse_args {
         my %seen;
         @list = grep !$seen{$_}++, map {m/^\W/ ? $_ : "\&$_" } @list;
 
+
         if ($exc) {
             $exclude{$_} = 1 for @list;
         }
@@ -448,9 +476,9 @@ sub _handle_fail {
     my $from = $self->from;
     my $menu = $self->menu($into);
 
-    my @fail = grep { $menu->{fail}->{$_->[0]} } @$import or return;
+    my @fail = grep $menu->{fail}->{$_->[0]}, @$import or return;
 
-    my @real_fail = $from->export_fail(map {$_->[0]} @fail) if $from->can('export_fail');
+    my @real_fail = $from->can('export_fail') ? $from->export_fail(map $_->[0], @fail) : map $_->[0], @fail;
 
     if (@real_fail) {
         $self->carp(qq["$_" is not implemented by the $from module on this architecture])
@@ -471,29 +499,23 @@ sub _set_symbols {
     my $menu   = $self->menu($into);
     my $caller = $self->get_caller();
 
+    # Turn of strict 'refs' for the sub we generate. Doing this here instead of
+    # in the eval is faster since it only runs once.
+    no strict 'refs';
     my $set_symbol = eval <<"    EOT" || die $@;
-#line ${ \__LINE__ } "${ \__FILE__ }"
-        sub {
-            my (\$name, \$ref) = \@_;
-
-            # 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.
-            BEGIN { \${^WARNING_BITS} = \$caller->[9] if \$caller->[9] };
-
-            # For our sub here we want to keep most strictures on, but we need to turn
-            # off strict ref checking.
-            no strict 'refs';
-
+# 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.
+BEGIN { \${^WARNING_BITS} = \$caller->[9] if defined \$caller->[9] }
 #line $caller->[2] "$caller->[1]"
-            *{"$into\::\$name"} = \$ref;
-        }
+sub { *{"$into\::\$_[0]"} = \$_[1] }
     EOT
+    use strict 'refs';
 
     for my $set (@$import) {
         my ($symbol, $spec) = @$set;
 
-        my ($sig, $name) = ($symbol =~ m/^(\W)(.*)$/);
+        my ($sig, $name) = ($symbol =~ m/^(\W)(.*)$/) or die "Invalid symbol: $symbol";
 
         # Find the thing we are actually shoving in a new namespace
         my $ref = $menu->{exports}->{$symbol};
@@ -502,26 +524,30 @@ sub _set_symbols {
         # Exporter.pm supported listing items in @EXPORT that are not actually
         # available for export. So if it is listed (lookup) but nothing is
         # there (!$ref) we simply skip it.
-        croak "$from does not export $symbol" unless $ref || $menu->{lookup}->{"${sig}${name}"};
+        $self->croak("$from does not export $symbol") unless $ref || $menu->{lookup}->{"${sig}${name}"};
         next unless $ref;
 
-        # Figure out the name they actually want it under
-        $name = $spec->{'-as'} || join '' => ($spec->{'-prefix'} || '', $name, $spec->{'-postfix'} || '');
+        $self->croak("Symbol '$sig$name' requested, but reference (" . ref($ref) . ") does not match sigil ($sig)")
+            if $ref && ref($ref) ne $SIG_TO_SLOT{$sig};
 
-        # Skip it if it has been excluded. We check only the new name, if they
-        # exclude an old name, and then ask for it with a new name we assume it
-        # is just a rename with precautions.
-        next if $exclude->{"${sig}${name}"};
+        # If they directly renamed it then we assume they want it under the new
+        # name, otherwise excludes get kicked. It is useful to be able to
+        # exclude an item in a tag/match where the group has a prefix/postfix.
+        next if $exclude->{"${sig}${name}"} && !$spec->{'-as'};
 
-        push @{$IMPORTED{$into}} => $name if $sig eq '&';
+        my $new_name = join '' => ($spec->{'-prefix'} || '', $spec->{'-as'} || $name, $spec->{'-postfix'} || '');
+
+        push @{$IMPORTED{$into}} => $new_name if $sig eq '&';
 
         # Set the symbol (finally!)
-        $set_symbol->($name, $ref);
+        $set_symbol->($new_name, $ref);
     }
 }
 
-#########################################################
-## The rest of these are utility functions, not methods!
+###########################################################################
+#
+# The rest of these are utility functions, not methods!
+#
 
 sub _version_check {
     my ($mod, $caller, @versions) = @_;
@@ -550,13 +576,15 @@ require \$file;
 }
 
 sub _optimal_import {
-    my ($from, $into, @args) = @_;
+    my ($from, $into, $caller, @args) = @_;
+
+    my %new_style = $from->can('IMPORTER_MENU') ? $from->IMPORTER_MENU : ();
 
     my %final;
     no strict 'refs';
-    return 0 if @{"$from\::EXPORT_FAIL"};
-    @args = @{"$from\::EXPORT"} unless @args;
-    my %allowed = map +($_ => 1), @{"$from\::EXPORT"}, @{"$from\::EXPORT_OK"};
+    return 0 if $new_style{export_fail} || @{"$from\::EXPORT_FAIL"};
+    @args = @{$new_style{export} || "$from\::EXPORT"} unless @args;
+    my %allowed = map +($_ => 1), @{$new_style{export} || "$from\::EXPORT"}, @{$new_style{export_ok} || "$from\::EXPORT_OK"};
     use strict 'refs';
 
     for my $arg (@args) {
@@ -577,10 +605,21 @@ sub _optimal_import {
         $final{$name} = \&{"$from\::$name"};
     }
 
-    no strict 'refs';
-    (*{"$into\::$_"} = $final{$_}, push @{$IMPORTED{$into}} => $_) for keys %final;
+    # This is necessary for the eval.
+    my $IMPORTED = \%IMPORTED;
 
-    return 1;
+    # This effects the eval, which is what we want. Putting this here means it
+    # runs once, at build time. Putting it inside the eval means it runs each
+    # time _optimal_import is called, which is costly.
+    no strict 'refs';
+    eval <<"    EOT" || die $@;
+# If the caller has redefine warnings enabled then we want to warn them if
+# their import redefines things.
+BEGIN { \${^WARNING_BITS} = \$caller->[9] if defined \$caller->[9] };
+#line $caller->[2] "$caller->[1]"
+(*{"\$into\::\$_"} = \$final{\$_}, push \@{\$IMPORTED->{\$into}} => \$_) for keys %final;
+1;
+    EOT
 }
 
 1;
@@ -711,6 +750,31 @@ be used.
 
 =head1 SUPPORTED FEATURES
 
+=head2 TAGS
+
+You can define/import subsets of symbols using predefined tags.
+
+    use Importer 'Some::Thing' => ':tag';
+
+=head2 /PATTERN/ or qr/PATTERN/
+
+You can import all symbols that match a pattern. The pattern can be supplied a
+string starting and ending with '/', or you can provide a C<qr/../> reference.
+
+    use Importer 'Some::Thing' => '/oo/';
+
+    use Importer 'Some::Thing' => qr/oo/;
+
+=head2 EXLUDING SYMBOLS
+
+You can exclude symbols by prefixing them with '!'.
+
+    use Importer 'Some::Thing'
+        '!foo',         # Exclude one specific symbol
+        '!/pattern/',   # Exclude all matching symbols
+        '!' => qr/oo/,  # Exclude all that match the following arg
+        '!:tag';        # Exclude all in tag
+
 =head2 RENAMING SYMBOLS AT IMPORT
 
 I<This is a new feature,> L<Exporter> I<does not support this on its own.>
@@ -732,12 +796,44 @@ 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 @EXPORT_FAIL
+=head2 UNIMPORTING
 
-Use this to list subs that are not available on all platforms. If someone tries
-to import one of these, Importer will hit your C<< $from->export_fail(@items) >>
-callback to try to resolve the issue. See L<Exporter.pm> for documentation of
-this feature.
+See L</UNIMPORT PARAMETERS>.
+
+=head2 ANONYMOUS EXPORTS
+
+See L</%EXPORT_ANON>.
+
+=head2 GENERATED EXPORTS
+
+See L</%EXPORT_GEN>.
+
+=head1 UNIMPORT PARAMETERS
+
+    no Importer;    # Remove all subs brought in with Importer
+
+    no Importer qw/foo bar/;    # Remove only the specified subs
+
+B<Only subs can be unimported>.
+
+B<You can only unimport subs imported using Importer>.
+
+=head1 SUPPORTED VARIABLES
+
+=head2 @EXPORT
+
+This is used exactly the way L<Exporter> uses it.
+
+List of symbols to export. Sigil is optional for subs. Symbols listed here are
+exported by default. If possible you should put symbols in C<@EXPORT_OK>
+instead.
+
+=head2 @EXPORT_OK
+
+This is used exactly the way L<Exporter> uses it.
+
+List of symbols that can be imported. Sigil is optional for subs. Symbols
+listed here are not exported by default. This is preferred over C<@EXPORT>.
 
 =head2 %EXPORT_TAGS
 
@@ -747,34 +843,49 @@ This module supports tags exactly the way L<Exporter> does.
 
     use Importer 'Other::Thing' => ':some_tag';
 
-=head2 /PATTERN/ or qr/PATTERN/
+=head2 @EXPORT_FAIL
 
-You can import all symbols that match a pattern. The pattern can be supplied a
-string starting and ending with '/', or you can provide a C<qr/../> reference.
+This is used exactly the way L<Exporter> uses it.
 
-    use Importer 'Some::Thing' => '/oo/';
+Use this to list subs that are not available on all platforms. If someone tries
+to import one of these, Importer will hit your C<< $from->export_fail(@items) >>
+callback to try to resolve the issue. See L<Exporter.pm> for documentation of
+this feature.
 
-    use Importer 'Some::Thing' => qr/oo/;
+=head2 %EXPORT_ANON
 
-=head2 EXLUDING SYMBOLS
+This is new to this module, L<Exporter> does not support it.
 
-You can exclude symbols by prefixing them with '!'.
+This allows you to export symbols that are not actually in your package symbol
+table. The keys should be the symbol names, the values are the references for
+the symbols.
 
-    use Importer 'Some::Thing'
-        '!foo',         # Exclude one specific symbol
-        '!/pattern/',   # Exclude all matching symbols
-        '!' => qr/oo/,  # Exclude all that match the following arg
-        '!:tag';        # Exclude all in tag
+    our %EXPORT_ANON = (
+        '&foo' => sub { 'foo' }
+        '$foo' => \$foo,
+        ...
+    );
 
-=head1 UNIMPORT PARAMETERS
+=head2 %EXPORT_GEN
 
-    no Importer;    # Remove all subs brought in with Importer
+This is new to this module, L<Exporter> does not support it.
 
-    no Importer qw/foo bar/;    # Remove only the specified subs
+This allows you to export symbols that are generated on export. The key should
+be the name of a symbol. The value should be a coderef that produces a
+reference that will be exported.
 
-B<Only subs can be unimported>.
+When the generators are called they will recieve 2 arguments, the package the
+symbol is being exported into, and the symbol being imported (name may or may
+not include sigil for subs).
 
-B<You can only unimport subs imported using Importer>.
+    our %EXPORT_GEN = (
+        '&foo' => sub {
+            my ($into_package, $symbol_name) = @_;
+            ...
+            return sub { ... };
+        },
+        ...
+    );
 
 =head1 CLASS METHODS
 
@@ -814,6 +925,13 @@ name, or a caller level.
 
 =back
 
+=head1 GIVING YOUR PACKAGE AN OLD-SCHOOL IMPORT METHOD
+
+    package My::Exporter;
+    use Importer Importer => ('exporter_import' => {-as => 'import'});
+
+    ...
+
 =head1 USING WITH OTHER EXPORTER IMPLEMENTATIONS
 
 If you want your module to work with Importer, but you use something other than
@@ -830,7 +948,13 @@ to support Importer by putting this sub in your package:
             export_ok   => \@EXPORT_OK,   # Other allowed exports
             export_tags => \%EXPORT_TAGS, # Define tags
             export_fail => \@EXPORT_FAIL, # For subs that may not always be available
+            export_anon => \%EXPORT_ANON, # Anonymous symbols to export
+
             generate    => \&GENERATE,    # Sub to generate dynamic exports
+            # OR
+            export_gen  => \%EXPORT_GEN,  # Hash of builders, key is symbol
+                                          # name, value is sub that generates
+                                          # the symbol ref.
         );
     }
 
diff --git a/lib/Importer/Exporter.pm b/lib/Importer/Exporter.pm
index db1cb2a..1a1df7a 100644
--- a/lib/Importer/Exporter.pm
+++ b/lib/Importer/Exporter.pm
@@ -13,8 +13,8 @@ sub export_fail { shift; @_ }
 
 sub export_to_level {
     my $from = shift;
-    my ($level) = @_;
-    Importer->import_into($from, $level + 1, @_);
+    my ($level, $ignore, @args) = @_;
+    Importer->import_into($from, $level + 1, @args);
 }
 
 sub require_version {
diff --git a/t/units.t b/t/units.t
index 5e48109..16855b4 100644
--- a/t/units.t
+++ b/t/units.t
@@ -310,12 +310,12 @@ subtest reload_menu => sub {
             sub __z { 'z' }
 
             # These are here to insure 'exports' does not pull them in, they are listed as generate
-            sub gena { sub { 'oops, should not see this' } }
-            sub genb { sub { 'oops, should not see this' } }
+            sub gena { die 'oops, should not see this' }
+            sub genb { die 'oops, should not see this' }
 
             # These are here to insure 'exports' does not pull them in, refs were provided by anon
-            sub x { sub { 'oops, should not see this' } }
-            sub y { sub { 'oops, should not see this' } }
+            sub x { die 'oops, should not see this' }
+            sub y { die 'oops, should not see this' }
 
             package Fake::ExporterI2;
 
@@ -405,12 +405,12 @@ subtest reload_menu => sub {
             sub __z { 'z' }
 
             # These are here to insure 'exports' does not pull them in, they are listed as generate
-            sub gena { sub { 'oops, should not see this' } }
-            sub genb { sub { 'oops, should not see this' } }
+            sub gena { die 'oops, should not see this' }
+            sub genb { die 'oops, should not see this' }
 
             # These are here to insure 'exports' does not pull them in, refs were provided by anon
-            sub x { sub { 'oops, should not see this' } }
-            sub y { sub { 'oops, should not see this' } }
+            sub x { die 'oops, should not see this' }
+            sub y { die 'oops, should not see this' }
         }
 
         my $one = $CLASS->new(from => 'Fake::ExporterE', caller => ['fake', 'fake.pl', 42]);
@@ -460,259 +460,488 @@ subtest reload_menu => sub {
         is($gen->('gena')->(), 'a', "generated a");
         is($gen->('genb')->(), 'b', "generated b");
     };
-
 };
 
-done_testing;
+subtest parse_args => sub {
+    {
+        package Fake::Exporter::ForArgs;
+
+        sub IMPORTER_MENU {
+            return (
+                export      => [qw/foo &bar $ZAP %ZAP @ZAP/],
+                export_ok   => [qw/baz ick missing/],
+                export_tags => {b => [qw/bar baz/]},
+                export_fail => [qw/ick/],
+                export_anon => { x => \&__x, z => \&__z },
+                export_gen  => {
+                    'gena' => sub {
+                        sub { 'a' }
+                    },
+                    '&genb' => sub {
+                        sub { 'b' }
+                    },
+                },
+            );
+        }
 
-__END__
+        sub foo { 'foo' }
+        sub bar { 'bar' }
+        sub baz { 'baz' }
+        sub ick { 'ick' }
+        sub __x { 'x' }
+        sub __z { 'z' }
 
+        # These are here to insure 'exports' does not pull them in, they are listed as generate
+        sub gena { die 'oops, should not see this' }
+        sub genb { die 'oops, should not see this' }
 
-sub parse_args {
-    my $self = shift;
-    my ($into, @args) = @_;
+        # These are here to insure 'exports' does not pull them in, refs were provided by anon
+        sub x { die 'oops, should not see this' }
+        sub y { die 'oops, should not see this' }
+    }
 
-    @args = (':DEFAULT') unless @args;
+    my $one = $CLASS->new(from => 'Fake::Exporter::ForArgs', caller => ['Foo', 'foo.pl', 42]);
+
+    is_deeply(
+        [$one->parse_args('Dest')],
+        [
+            'Dest',
+            [],
+            {},
+            [
+                ['&foo', {}],
+                ['&bar', {}],
+                ['$ZAP', {}],
+                ['%ZAP', {}],
+                ['@ZAP', {}],
+            ]
+        ],
+        "Got defaults with empty list"
+    );
 
-    my $from = $self->from;
-    my $menu = $self->menu($into);
+    is_deeply(
+        [$one->parse_args('Dest', '!bar')],
+        [
+            'Dest',
+            [],
+            { '&bar' => 1 },
+            [
+                ['&foo', {}],
+                ['&bar', {}],
+                ['$ZAP', {}],
+                ['%ZAP', {}],
+                ['@ZAP', {}],
+            ]
+        ],
+        "Got defaults, exclude bar"
+    );
 
-    my %exclude;
-    my @import;
-    my @versions;
+    is_deeply(
+        [$one->parse_args('Dest', '!' => 'bar')],
+        [
+            'Dest',
+            [],
+            { '&bar' => 1 },
+            [
+                ['&foo', {}],
+                ['&bar', {}],
+                ['$ZAP', {}],
+                ['%ZAP', {}],
+                ['@ZAP', {}],
+            ]
+        ],
+        "Got defaults, exclude bar"
+    );
 
-    while(my $full_arg = shift @args) {
-        my $arg = $full_arg;
-        my $lead = substr($arg, 0, 1);
-        my ($spec, $exc);
+    is_deeply(
+        [$one->parse_args('Dest', ':DEFAULT', '!:b')],
+        [
+            'Dest',
+            [],
+            { '&bar' => 1, '&baz' => 1 },
+            [
+                ['&foo', {}],
+                ['&bar', {}],
+                ['$ZAP', {}],
+                ['%ZAP', {}],
+                ['@ZAP', {}],
+            ]
+        ],
+        "Got defaults, exclude :b"
+    );
 
-        # If the first character is an ASCII numeric then it is a version number
-        if ($NUMERIC{$lead}) {
-            push @versions => $arg;
-            next;
-        }
+    is_deeply(
+        [$one->parse_args('Dest', ':b' => {-prefix => 'foo_'}, qw/x &y/)],
+        [
+            'Dest',
+            [],
+            {},
+            [
+                ['&bar', {-prefix => 'foo_'}],
+                ['&baz', {-prefix => 'foo_'}],
+                ['&x', {}],
+                ['&y', {}],
+            ]
+        ],
+        "Spec for tag"
+    );
 
-        if ($lead eq '!') {
-            my $exc = $lead;
+    is_deeply(
+        [$one->parse_args('Dest', '/A/' => { -postfix => '_foo' }, '!$ZAP')],
+        [
+            'Dest',
+            [],
+            { '$ZAP' => 1 },
+            [
+                ['$ZAP', {-postfix => '_foo'}],
+                ['%ZAP', {-postfix => '_foo'}],
+                ['@ZAP', {-postfix => '_foo'}],
+            ]
+        ],
+        "Spec for pattern"
+    );
 
-            if ($arg eq '!') {
-                # If the current arg is just '!' then we are negating the next item.
-                $arg = shift;
-            }
-            else {
-                # Strip off the '!'
-                substr($arg, 0, 1, '');
+    is_deeply(
+        [$one->parse_args('Dest', 22, qr/A/, { -postfix => '_foo' }, '!$ZAP', 45)],
+        [
+            'Dest',
+            [ 22, 45 ],
+            { '$ZAP' => 1 },
+            [
+                ['$ZAP', {-postfix => '_foo'}],
+                ['%ZAP', {-postfix => '_foo'}],
+                ['@ZAP', {-postfix => '_foo'}],
+            ]
+        ],
+        "Spec for qr// (also test version)"
+    );
 
-                # Exporter.pm legacy behavior
-                # negated first item implies starting with default set:
-                unshift @args => ':DEFAULT' unless @import || keys %exclude || @versions;
-            }
+    like(
+        dies { $one->parse_args('Dest', '/A/' => { -as => 'foo' }) },
+        qr{Cannot use '-as' to rename multiple symbols included by: /A/},
+        "-as does not work with multiple imports"
+    );
 
-            # Now we have a new lead character
-            $lead = substr($arg, 0, 1);
-        }
-        else {
-            # If the item is followed by a reference then they are asking us to
-            # do something special...
-            $spec = ref($args[0]) ? shift @args : {};
-        }
+    like(
+        dies { $one->parse_args('Dest', ':b' => { -as => 'foo' }) },
+        qr{Cannot use '-as' to rename multiple symbols included by: :b},
+        "-as does not work with multiple imports"
+    );
 
-        # Process the item to figure out what symbols are being touched, if it
-        # is a tag or regex than it can be multiple.
-        my @list;
-        if(ref($arg) eq 'Regexp') {
-            @list = grep /$arg/, keys %{$menu->{lookup}};
-        }
-        if($lead eq ':') {
-            substr($arg, 0, 1, '');
-            my $tag = $menu->{tags}->{$arg} or croak "$from does not export the :$arg tag";
-            @list = @$tag;
-        }
-        elsif($lead eq '/' && $arg =~ m{^/(.*)/$}) {
-            my $pattern = $1;
-            @list = grep /$1/, keys %{$menu->{lookup}};
-        }
-        else {
-            @list = ($arg);
+    like(
+        dies { $one->parse_args('Dest', ':bad') },
+        qr{Fake::Exporter::ForArgs does not export the :bad tag},
+        "-as does not work with multiple imports"
+    );
+};
+
+subtest _handle_fail => sub {
+    {
+        package Fake::Exporter::ForFail;
+
+        sub IMPORTER_MENU {
+            return (
+                export      => [qw/foo &bar $ZAP %ZAP @ZAP/],
+                export_ok   => [qw/baz ick missing/],
+                export_tags => {b => [qw/bar baz/]},
+                export_fail => [qw/ick foo/],
+                export_anon => { x => \&__x, z => \&__z },
+                export_gen  => {
+                    'gena' => sub {
+                        sub { 'a' }
+                    },
+                    '&genb' => sub {
+                        sub { 'b' }
+                    },
+                },
+            );
         }
 
-        # Normalize list, always have a sigil
-        @list = map {m/^\W/ ? $_ : "\&$_" } @list;
+        sub foo { 'foo' }
+        sub bar { 'bar' }
+        sub baz { 'baz' }
+        sub ick { 'ick' }
+        sub __x { 'x' }
+        sub __z { 'z' }
 
-        if ($exc) {
-            $exclude{$_} = 1 for @list;
-        }
-        else {
-            $self->croak("Cannot use '-as' to rename multiple symbols included by: $full_arg")
-                if $spec->{'-as'} && @list > 1;
+        # These are here to insure 'exports' does not pull them in, they are listed as generate
+        sub gena { die 'oops, should not see this' }
+        sub genb { die 'oops, should not see this' }
+
+        # These are here to insure 'exports' does not pull them in, refs were provided by anon
+        sub x { die 'oops, should not see this' }
+        sub y { die 'oops, should not see this' }
 
-            push @import => [$_, $spec] for @list;
+        sub export_fail {
+            my $from = shift;
+            return grep !/foo/, @_;
         }
     }
 
-    return ($into, \@versions, \%exclude, \@import);
-}
+    my $one = $CLASS->new(from => 'Fake::Exporter::ForFail', caller => ['Foo', 'foo.pl', 42]);
+
+    ok(!dies { $one->_handle_fail('dest', [['bar'], ['baz']]) }, "no failures") || diag $@;
+    ok(!dies { $one->_handle_fail('dest', [['bar'], ['foo']]) }, "no failures, but 'foo' was on list") || diag $@;
 
-sub _handle_fail {
-    my $self = shift;
-    my ($into, $import) = @_;
+    like(
+        warns {
+            like(
+                dies { $one->_handle_fail('dest', [['bar'], ['ick']]) },
+                qr/Can't continue after import errors/,
+                "True failure"
+            )
+        },
+        qr/"ick" is not implemented by the Fake::Exporter::ForFail module on this architecture/,
+        "Got expected warning"
+    );
+};
 
-    my $from = $self->from;
-    my $menu = $self->menu($into);
+subtest _set_symbols => sub {
+    {
+        package Fake::ForSetSymbols;
+        our @EXPORT      = qw/foo &bar $ZAP %ZAP @ZAP/;
+        our @EXPORT_OK   = qw/baz ick missing/;
+        our %EXPORT_TAGS = (b => [qw/bar baz/]);
+        our @EXPORT_FAIL = qw/ick/;
+        our %EXPORT_ANON = (x => \&__x, z => \&__z);
+        our %EXPORT_GEN  = (
+            'gena' => sub {
+                sub { 'a' }
+            },
+            '&genb' => sub {
+                my $bad = 'bad';
+                return \$bad; # To test sigil mismatch
+            },
+        );
 
-    my @fail = grep { $menu->{fail}->{$_->[0]} } @$import or return;
+        our @ZAP = (qw/Z A P/);
+        our $ZAP = 'ZAP';
+        our %ZAP = (ZAP => 1);
 
-    my @real_fail = $from->export_fail(map {$_->[0]} @fail) if $from->can('export_fail');
+        sub foo { 'foo' }
+        sub bar { 'bar' }
+        sub baz { 'baz' }
+        sub ick { 'ick' }
+        sub __x { 'x' }
+        sub __z { 'z' }
 
-    if (@real_fail) {
-        $self->carp(qq["$_" is not implemented by the $from module on this architecture])
-            for @real_fail;
+        # These are here to insure 'exports' does not pull them in, they are listed as generate
+        sub gena { die 'oops, should not see this' }
+        sub genb { die 'oops, should not see this' }
 
-        $self->croak("Can't continue after import errors");
+        # These are here to insure 'exports' does not pull them in, refs were provided by anon
+        sub x { die 'oops, should not see this' }
+        sub y { die 'oops, should not see this' }
     }
 
-    $self->reload_menu($menu);
-    return;
-}
+    my $one = $CLASS->new(from => 'Fake::ForSetSymbols', caller => ['Foo', 'foo.pl', 42]);
 
-sub _set_symbols {
-    my $self = shift;
-    my ($into, $exclude, $import) = @_;
+    $one->_set_symbols(
+        'Fake::Dest::A',
+        {'&bar' => 1, '@ZAP' => 1},
+        [
+            # These first 2 should both be excluded
+            ['&bar' => {}],
+            ['&bar' => {-prefix => 'pre_', -postfix => '_post'}],
 
-    my $from   = $self->from;
-    my $menu   = $self->menu($into);
-    my $caller = $self->get_caller();
+            # Replicate use of ':b', this one is not excluded though
+            ['&baz' => {-prefix => 'pre_', -postfix => '_post'}],
 
-    my $set_symbol = eval <<"    EOT" || die $@;
-#line ${ \__LINE__ } "${ \__FILE__ }"
-        sub {
-            my (\$name, \$ref) = \@_;
+            # Exclude
+            ['@ZAP' => {}],
 
-            # 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.
-            BEGIN { \${^WARNING_BITS} = \$caller->[9] if \$caller->[9] };
+            # Should import, specific name requested, ignore exclude
+            ['&bar' => {-as => 'boo'}],
 
-            # For our sub here we want to keep most strictures on, but we need to turn
-            # off strict ref checking.
-            no strict 'refs';
+            # Should work fine
+            ['&foo'  => {}],
+            ['&gena' => {}],
+            ['&x'    => {}],
+            ['$ZAP'  => {-prefix => 'pre_', -postfix => '_post'}],
+        ],
+    );
 
-#line $caller->[2] "$caller->[1]"
-            *{"$into\::\$name"} = \$ref;
-        }
-    EOT
+    is(\&Fake::Dest::A::pre_baz_post, \&Fake::ForSetSymbols::baz, 'Exported &baz as pre_baz_post');
+    is(\&Fake::Dest::A::boo,          \&Fake::ForSetSymbols::bar, 'Exported &bar as &boo');
+    is(\&Fake::Dest::A::foo,          \&Fake::ForSetSymbols::foo, 'Exported &foo');
+    is(\&Fake::Dest::A::x,            \&Fake::ForSetSymbols::__x, 'Exported anon &x');
+    is(\$Fake::Dest::A::pre_ZAP_post, \$Fake::ForSetSymbols::ZAP, 'Exported $ZAP as $pre_ZAP_post');
+    is(Fake::Dest::A::gena(),         'a',                        'Generated &gena');
 
-    for my $set (@$import) {
-        my ($symbol, $spec) = @$set;
+    {
+        no warnings 'once';
+        ok(\@Fake::Dest::A::ZAP != \@Fake::ForSetSymbols::ZAP,          'Excluded @ZAP');
+        ok(\&Fake::Dest::A::bar != \&Fake::ForSetSymbols::bar,          'Excluded &bar');
+        ok(\&Fake::Dest::A::pre_bar_post != \&Fake::ForSetSymbols::bar, 'Excluded &bar with prefix/postfix');
+    }
 
-        my ($sig, $name) = ($symbol =~ m/^(\W)(.*)$/);
+    ok(!dies { $one->_set_symbols('Fake::Dest::A', {}, [['&missing' => {}]]) }, "Can fake-import missing symbol if it is listed");
 
-        # Find the thing we are actually shoving in a new namespace
-        my $ref = $menu->{exports}->{$symbol};
-        $ref ||= $menu->{generate}->($symbol) if $menu->{generate};
+    like(
+        dies { $one->_set_symbols('Fake::Dest::A', {}, [['&nope' => {}]]) },
+        qr/Fake::ForSetSymbols does not export \&nope/,
+        "unlisted symbol cannot be imported"
+    );
 
-        # Exporter.pm supported listing items in @EXPORT that are not actually
-        # available for export. So if it is listed (lookup) but nothing is
-        # there (!$ref) we simply skip it.
-        croak "$from does not export $symbol" unless $ref || $menu->{lookup}->{$name} || $menu->{lookup}->{$symbol};
-        next unless $ref;
+    like(
+        dies { $one->_set_symbols('Fake::Dest::A', {}, [['&genb' => {}]]) },
+        qr/Symbol '\&genb' requested, but reference \(SCALAR\) does not match sigil \(\&\)/,
+        "sigil mismatch"
+    );
 
-        # Figure out the name they actually want it under
-        $name = $spec->{'-as'} || join '' => ($spec->{'-prefix'} || '', $name, $spec->{'-postfix'} || '');
+    # Make sure it finds the correct caller, not our fake one
+    delete $one->{caller};
 
-        # Skip it if it has been excluded. We check only the new name, if they
-        # exclude an old name, and then ask for it with a new name we assume it
-        # is just a rename with precautions.
-        next if $exclude->{"${sig}${name}"};
+    {
+        no warnings 'redefine';
+        *Fake::Dest::A::foo = sub { 1 };
+    }
 
-        push @{$IMPORTED{$into}} => $name if $sig eq '&';
+    ok(
+        !warns {
+            no warnings 'redefine';
+            $one->_set_symbols('Fake::Dest::A', {}, [['&foo' => {}]])
+        },
+        "no redefine warnings"
+    );
 
-        # Set the symbol (finally!)
-        $set_symbol->($name, $ref);
+    {
+        no warnings 'redefine';
+        *Fake::Dest::A::foo = sub { 1 };
     }
-}
 
-#########################################################
-## The rest of these are utility functions, not methods!
+    like(
+        warns {
+            use warnings 'redefine';
+            $one->_set_symbols('Fake::Dest::A', {}, [['&foo' => {}]])
+        },
+        qr/Subroutine Fake::Dest::A::foo redefined/,
+        "redefine warnings"
+    );
 
-sub _version_check {
-    my ($mod, $caller, @versions) = @_;
+    $one = $CLASS->new(from => 'Fake::Dest::A');
 
-    eval <<"    EOT" or die $@;
-#line $caller->[2] "$caller->[1]"
-\$mod->VERSION(\$_) for \@versions;
-1;
-    EOT
-}
+    can_ok('Fake::Dest::A', 'foo');
+    $one->do_unimport(qw/foo/);
+    ok(!'Fake::Dest::A'->can('foo'), "removed &foo");
 
-sub _mod_to_file {
-    my $file = shift;
-    $file =~ s{::}{/}g;
-    $file .= '.pm';
-    return $file;
-}
+    is(\&Fake::Dest::A::pre_baz_post, \&Fake::ForSetSymbols::baz, 'Kept &baz as pre_baz_post');
+    is(\&Fake::Dest::A::boo,          \&Fake::ForSetSymbols::bar, 'Kept &bar as &boo');
+    is(\&Fake::Dest::A::x,            \&Fake::ForSetSymbols::__x, 'Kept anon &x');
+    is(\$Fake::Dest::A::pre_ZAP_post, \$Fake::ForSetSymbols::ZAP, 'Kept $ZAP as $pre_ZAP_post');
+    is(Fake::Dest::A::gena(),         'a',                        'Kept &gena');
 
-sub _load_file {
-    my ($caller, $file) = @_;
+    $one->do_unimport();
+    is(\$Fake::Dest::A::pre_ZAP_post, \$Fake::ForSetSymbols::ZAP, 'Kept $ZAP as $pre_ZAP_post');
+    ok(!'Fake::Dest::A'->can($_), "removed \&$_") for qw/pre_baz_post boo x gena/;
+};
 
-    eval <<"    EOT" || die $@;
-#line $caller->[2] "$caller->[1]"
-require \$file;
-    EOT
-}
+subtest version_check => sub {
+    local *version_check = $CLASS->can('_version_check') or die "where did _version_check go?";
+    ok(version_check($CLASS, ['foo', 'foo.pl', 42], '0.001'), "version check pass");
+    like(
+        dies { version_check($CLASS, ['foo', 'foo.pl', 42], '9999') },
+        qr/version 9999 required.*foo\.pl line 42/,
+        "Version Check fails"
+    );
+};
 
-sub _optimal_import {
-    my ($from, $into, @args) = @_;
+subtest mod_to_file => sub {
+    local *mod_to_file = $CLASS->can('_mod_to_file') or die "where did _mod_to_file go?";
+    is(mod_to_file('Foo::Bar::Baz'), 'Foo/Bar/Baz.pm', "Converted module to filename");
+};
 
-    my %final;
-    no strict 'refs';
-    return 0 if @{"$from\::EXPORT_FAIL"};
-    @args = @{"$from\::EXPORT"} unless @args;
-    my %allowed = map +($_ => 1), @{"$from\::EXPORT"}, @{"$from\::EXPORT_OK"};
-    use strict 'refs';
+subtest load_file => sub {
+    local *load_file = $CLASS->can('_load_file') or die "where did _load_file go?";
+    ok(load_file(['foo', 'foo.pl', 42], 'Data/Dumper.pm'), "Load file pass");
+    eval <<"    EOT" && die "Ooops, wtf?";
+#line 42 "foo.pl"
+require Fake::File::That::Better::Not::Exist::SAGSDGDS;
+1;
+    EOT
+    my $error = $@;
+    like($error, qr/locate.*\@INC/ms, "predicted error message is somewhat sane");
+    is(
+        dies { load_file(['foo', 'foo.pl', 42], 'Fake/File/That/Better/Not/Exist/SAGSDGDS.pm') },
+        $error,
+        "Load file fails"
+    );
+};
 
-    for my $arg (@args) {
-        # Get sigil, or first letter of name
-        my $sig = substr($arg, 0, 1);
+subtest _optimal_import => sub {
+    {
+        package Fake::ForOptimal::A;
+        our @EXPORT = qw/foo &bar $ZAP %ZAP @ZAP/;
+        sub foo { 'foo' }
+        sub bar { 'bar' }
+    }
+    my $optimal = $CLASS->can('_optimal_import');
 
-        # Return if non-sub sigil
-        return 0 if $NON_OPTIMAL{$sig};
+    ok($optimal->('Fake::ForOptimal::A', 'FDestA', ['F', 'F.pm', 4], qw/foo/), "Success");
+    can_ok('FDestA', 'foo');
 
-        # Strip sigil (if sub)
-        my $name = $arg;
-        substr($name, 0, 1, '') if $sig eq '&';
+    ok(!$optimal->('Fake::ForOptimal::A', 'FDestA', ['F', 'F.pm', 4], qw/bar @ZAP/), "Failure");
+    ok(!'FDestA'->can('bar'), 'Did not export anything');
 
-        # Check if the name is allowed (with or without sigil)
-        return 0 unless $allowed{$name} || $allowed{$arg};
+    ok(!$optimal->('Fake::ForOptimal::A', 'FDestA', ['F', 'F.pm', 4], qw/bloop/), "Failure, not a valid export");
 
-        no strict 'refs';
-        $final{$name} = \&{"$from\::$name"};
+    {
+        package Fake::ForOptimal::B;
+        our @EXPORT = qw/foo &bar/;
+        sub foo { 'foo' }
+        sub bar { 'bar' }
     }
+    ok($optimal->('Fake::ForOptimal::B', 'FDestB', ['F', 'F.pm', 4]), "Success with defaults");
+    can_ok('FDestB', 'foo', 'bar');
 
-    no strict 'refs';
-    (*{"$into\::$_"} = $final{$_}, push @{$IMPORTED{$into}} => $_) for keys %final;
+    {
+        package Fake::ForOptimal::C;
+        our @EXPORT = qw/foo &bar/;
+        our @EXPORT_FAIL = qw/bar/;
+        sub foo { 'foo' }
+        sub bar { 'bar' }
+    }
+    ok(!$optimal->('Fake::ForOptimal::C', 'FDestC', ['F', 'F.pm', 4], 'foo'), "Failure die to EXPORT_FAIL");
+    ok(!'FDestC'->can('foo'), 'Did not export anything');
 
-    return 1;
-}
 
-sub exporter_import {
-    my $from = shift;
 
-    my @caller = caller(0);
+    no warnings 'once';
+    *FDestD::foo = sub { 'xyz' };
+    like(
+        warns { $optimal->('Fake::ForOptimal::A', 'FDestD', ['F', 'F.pm', 4], 'foo') },
+        qr/Subroutine FDestD::foo redefined at F\.pm line 4/,
+        "Got redefine warning"
+    );
 
-    return unless @_;
+    {
+        package FDestD;
+        Importer->unimport;
+    }
 
-    my $file = _mod_to_file($from);
-    _load_file(\@caller, $file) unless $INC{$file};
+    ok(!FDestD->can('foo'), "Removed 'foo'");
+};
 
-    return if _optimal_import($from, $caller[0], @_);
+subtest exporter_import => sub {
+    BEGIN {
+        $INC{'Fake/Exporter.pm'} = 1;
+        package Fake::Exporter;
+        use Importer Importer => 'exporter_import' => { -as => 'import' };
+        our @EXPORT = qw/foo $ZAP/;
+        sub foo { 'foo' }
+        our $ZAP = 1;
+    }
 
-    my $self = __PACKAGE__->new(
-        from   => $from,
-        caller => \@caller,
-    );
+    {
+        package Fake::XXX::A;
+        use Fake::Exporter qw/foo/;
 
-    $self->do_import($caller[0], @_);
-}
+        package Fake::XXX::B;
+        use Fake::Exporter qw/foo $ZAP/;
+    }
 
+    can_ok('Fake::XXX::A', 'foo'); # Optimal case
+    can_ok('Fake::XXX::B', 'foo'); # Non-optimal
+};
 
+done_testing;