From b26e031310a958c1c0107db046cd7720c5e38a6e Mon Sep 17 00:00:00 2001 From: Chad Granum Date: Sun, 28 Aug 2016 16:43:47 -0700 Subject: Fixes for parsing/specifying pins and tags * 'pins' allow multiple inheritence * 'pins' allow +pin => [...] * Allow nesting tags * Allow specs in tags * Saner arg parsing all around --- Changes | 6 ++ lib/Importer.pm | 249 ++++++++++++++++++++++++++++++++++++++------------------ t/pins.t | 2 +- t/units.t | 49 ++++++++--- 4 files changed, 216 insertions(+), 90 deletions(-) diff --git a/Changes b/Changes index fb45850..b1a3471 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,11 @@ {{$NEXT}} + - 'pins' allow multiple inheritence + - 'pins' allow +pin => [...] + - Allow nesting tags + - Allow specs in tags + - Saner arg parsing all around + 0.020 2016-08-27 15:32:16-07:00 America/Los_Angeles (TRIAL RELEASE) - Make 'pins' feature more sane diff --git a/lib/Importer.pm b/lib/Importer.pm index 138e72b..994b158 100644 --- a/lib/Importer.pm +++ b/lib/Importer.pm @@ -453,8 +453,6 @@ sub _build_menu { } @$export_fail } : undef; - my $root_pin = delete $export_pins->{'root_name'} || 'v0'; - my $inherit = delete $export_pins->{inherit}; my $pins = {}; my $menu = { @@ -468,15 +466,22 @@ sub _build_menu { on_use => $export_on_use, }; + my $root_pin = delete $export_pins->{'root_name'} || 'v0'; + my $inherit = delete $export_pins->{inherit}; + my %seen; my @todo = grep {defined($_) && length($_)} ($inherit, $root_pin, keys %$export_pins); while (my $p = shift @todo) { my $root = $p eq $root_pin ? 1 : 0; - my $parent = $root ? $inherit : $export_pins->{$p}->{inherit}; + my $parents = $root ? $inherit : $export_pins->{$p}->{inherit}; + + my $need_parent = 0; + for my $parent (ref $parents ? (@$parents) : ($parents)) { + next unless $parent; + next if $seen{$parent}; - if ($parent && !$seen{$parent}) { $self->croak("Cycle detected between pins '$p' and '$parent'") if defined $seen{$parent}; @@ -485,53 +490,47 @@ sub _build_menu { $seen{$parent} = 0; - unshift @todo => ($parent, $p); - next; + unshift @todo => $p unless $need_parent++; + unshift @todo => $parent; } - + next if $need_parent; next if $seen{$p}++; $self->croak("Cannot use 'export_pins' inside a pin!") if $export_pins->{$p}->{export_pins}; - $self->croak("Cannot use 'export_tags' inside a pin!") - if $export_pins->{$p}->{export_tags}; - my $submenu = $root ? $menu : $self->_build_menu($into, $export_pins->{$p}, $new_style); + $pins->{$p} = $submenu; - $tags->{$p} ||= [ "+$p", @{$submenu->{tags}->{DEFAULT}} ]; - $pins->{$p} ||= $submenu; + for my $parent (ref $parents ? (@$parents) : ($parents)) { + next unless $parent; + my $pmenu = $pins->{$parent}; - next unless $parent; - my $pmenu = $pins->{$parent}; + # Tags + unshift @{$submenu->{tags}->{$_}} => @{$pmenu->{tags}->{$_}} for keys %{$pmenu->{tags}}; - push @{$tags->{$p}} => @{$pmenu->{tags}->{DEFAULT}}; - - if ($root) { - push @{$submenu->{tags}->{DEFAULT}} => @{$pmenu->{tags}->{DEFAULT}}; - push @{$submenu->{tags}->{ALL}} => @{$pmenu->{tags}->{ALL}}; - } - - # Hashes, easy to mix - for my $simple (qw/lookup exports magic fail/) { - my $mix = $pmenu->{$simple} || next; - my $it = $submenu->{$simple} ||= {}; - %$it = (%$mix, %$it); - } - - # generate is a sub that returns undef on no match, first use the pin one, fallback to parent one - if (my $pgen = $pmenu->{generate}) { - if (my $gen = $submenu->{generate}) { - $submenu->{generate} = sub { $gen->(@_) or $pgen->(@_) }; + # Hashes, easy to mix + for my $simple (qw/lookup exports magic fail/) { + my $mix = $pmenu->{$simple} || next; + my $it = $submenu->{$simple} ||= {}; + %$it = (%$mix, %$it); } - else { - $submenu->{generate} = $pgen; + + # generate is a sub that returns undef on no match, first use the pin one, fallback to parent one + if (my $pgen = $pmenu->{generate}) { + if (my $gen = $submenu->{generate}) { + $submenu->{generate} = sub { $gen->(@_) or $pgen->(@_) }; + } + else { + $submenu->{generate} = $pgen; + } } - } - $submenu->{on_use} ||= $pmenu->{on_use} if $pmenu->{on_use}; + $submenu->{on_use} ||= $pmenu->{on_use} if $pmenu->{on_use}; + } - %$exports = ( %{$pmenu->{exports}}, %$exports ); + $tags->{$p} ||= [ "+$p", $submenu->{tags}->{DEFAULT} ]; + $tags->{"$p\:$_"} ||= [ "+$p", $submenu->{tags}->{$_} ] for grep {$_ ne $root_pin} keys %{$submenu->{tags}} } # Remove Noise @@ -544,39 +543,82 @@ sub parse_args { my $self = shift; my ($into, @args) = @_; - @args = (':DEFAULT') unless @args; + my $menu = $self->menu($into); + + my @out = $self->_parse_args($into, $menu, \@args); + pop @out; + return @out; +} + +sub _parse_args { + my $self = shift; + my ($into, $menu, $args) = @_; my $from = $self->from; - my $menu = $self->menu($into); + my $main_menu = $self->menu($into); + $menu ||= $main_menu; + + # First we strip out versions numbers and setters, this simplifies the logic late. + my @sets; + my @versions; + my @leftover; + for my $arg (@$args) { + no warnings 'void'; + + # Code refs are custom setters + # If the first character is an ASCII numeric then it is a version number + push @sets => $arg and next if ref($arg) eq 'CODE'; + push @versions => $arg xor next if $NUMERIC{substr($arg, 0, 1)}; + push @leftover => $arg; + } + + $self->carp("Multiple setters specified, only 1 will be used") if @sets > 1; + my $set = pop @sets; + + $args = \@leftover; + @$args = (':DEFAULT') unless @$args || @versions; my %exclude; my @import; - my @versions; - my $set; - while(my $full_arg = shift @args) { + while(my $full_arg = shift @$args) { my $arg = $full_arg; my $lead = substr($arg, 0, 1); - my ($spec, $exc); - # If the first character is an ASCII numeric then it is a version number - if ($NUMERIC{$lead}) { - 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; + # Handle pin selection + if ($lead eq '+') { + substr($arg, 0, 1, ""); + + my $submenu = $main_menu->{pins}->{$arg} + or $self->croak("$from does not export the +$arg pin"); + + if (ref($args->[0])) { + my $subargs = shift @$args; + my (undef, $cvers, $cexc, $cimp, $cset) = $self->_parse_args($into, $submenu, $subargs); + + $self->croak("Cannot specify version numbers (" . join(', ', @$cvers) . ") in list given to +$arg pin.") + if @$cvers; + + $self->croak("Cannot specify a custom symbol setter in list given to +$arg pin.") + if $cset; + + push @import => [$full_arg, [$cexc, $cimp]]; + } + else { + push @import => [$full_arg, undef]; + $menu = $submenu; + } + next; } + my ($spec, $exc); if ($lead eq '!') { $exc = $lead; if ($arg eq '!') { # If the current arg is just '!' then we are negating the next item. - $arg = shift @args; + $arg = shift @$args; } else { # Strip off the '!' @@ -585,7 +627,7 @@ sub parse_args { # Exporter.pm legacy behavior # negated first item implies starting with default set: - unshift @args => ':DEFAULT' unless @import || keys %exclude || @versions; + unshift @$args => ':DEFAULT' unless @import || keys %exclude || @versions; # Now we have a new lead character $lead = substr($arg, 0, 1); @@ -593,7 +635,51 @@ 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]) eq 'HASH' ? shift @args : {}; + $spec = ref($args->[0]) eq 'HASH' ? shift @$args : {}; + } + + if($lead eq ':') { + substr($arg, 0, 1, ''); + my $tag = $menu->{tags}->{$arg} or $self->croak("$from does not export the :$arg tag"); + + my (undef, $cvers, $cexc, $cimp, $cset, $newmenu) = $self->_parse_args($into, $menu, $tag); + + $self->croak("Exporter specified version numbers (" . join(', ', @$cvers) . ") in the :$arg tag!") + if @$cvers; + + $self->croak("Exporter specified a custom symbol setter in the :$arg tag!") + if $cset; + + # Merge excludes + %exclude = (%exclude, %$cexc); + + if ($exc) { + $exclude{$_} = 1 for grep {!ref($_) && substr($_, 0, 1) ne '+'} map {$_->[0]} @$cimp; + } + elsif ($spec && keys %$spec) { + $self->croak("Cannot use '-as' to rename multiple symbols included by: $full_arg") + if $spec->{'-as'} && @$cimp > 1; + + for my $set (@$cimp) { + my ($sym, $cspec) = @$set; + + # Start with a blind squash, spec from tag overrides the ones inside. + my $nspec = {%$cspec, %$spec}; + + $nspec->{'-prefix'} = "$spec->{'-prefix'}$cspec->{'-prefix'}" if $spec->{'-prefix'} && $cspec->{'-prefix'}; + $nspec->{'-postfix'} = "$cspec->{'-postfix'}$spec->{'-postfix'}" if $spec->{'-postfix'} && $cspec->{'-postfix'}; + + push @import => [$sym, $nspec]; + } + } + else { + push @import => @$cimp; + } + + # New menu + $menu = $newmenu; + + next; } # Process the item to figure out what symbols are being touched, if it @@ -602,24 +688,10 @@ sub parse_args { if(ref($arg) eq 'Regexp') { @list = sort grep /$arg/, keys %{$menu->{lookup}}; } - elsif($lead eq ':') { - substr($arg, 0, 1, ''); - 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 = sort grep /$1/, keys %{$menu->{lookup}}; } - elsif($lead eq '+') { - my $pname = $arg; - substr($pname, 0, 1, ''); - - $self->croak("$from does not export the +$pname pin") - unless $menu->{pins}->{$pname}; - - @list = ($arg); - } else { @list = ($arg); } @@ -638,7 +710,7 @@ sub parse_args { } } - return ($into, \@versions, \%exclude, \@import, $set); + return ($into, \@versions, \%exclude, \@import, $set, $menu); } sub _handle_fail { @@ -666,7 +738,7 @@ sub _handle_fail { sub _set_symbols { my $self = shift; - my ($into, $exclude, $import, $custom_set) = @_; + my ($into, $exclude, $import, $custom_set, $pin, $pin_str, $used, $menu) = @_; my $from = $self->from; my $main_menu = $self->menu($into); @@ -681,22 +753,41 @@ BEGIN { \${^WARNING_BITS} = \$caller->[9] if defined \$caller->[9] } sub { *{"$into\\::\$_[0]"} = \$_[1] } EOT - my $menu = $main_menu; - my $pin = undef; - my $pin_str = ""; - my %used; + $menu ||= $main_menu; + $pin_str ||= ""; + $used ||= {}; + for my $set (@$import) { my ($symbol, $spec) = @$set; my ($sig, $name) = ($symbol =~ m/^(\W)(.*)$/) or die "Invalid symbol: $symbol"; + if ($sig eq '+') { - $pin = $name; - $pin_str = "pin $name "; - $menu = $main_menu->{pins}->{$name}; + $self->croak("$from does not export the +$name pin") + unless $main_menu->{pins}->{$name}; + + if ($spec) { + $self->_set_symbols( + $into, + {%$exclude, %{$spec->[0]}}, # %exclude + $spec->[1], # @import + $set_symbol, + $name, + "pin $name ", + $used, + $main_menu->{pins}->{$name}, + ); + } + else { + $pin = $name; + $pin_str = "pin $name "; + $menu = $main_menu->{pins}->{$name}; + } + next; } - $menu->{on_use}->($pin) if $menu->{on_use} && !$used{$pin || ''}++; + $menu->{on_use}->($pin) if $menu->{on_use} && !$used->{$pin || ''}++; # Find the thing we are actually shoving in a new namespace my $ref = $menu->{exports}->{$symbol}; diff --git a/t/pins.t b/t/pins.t index 6c9feb1..981453b 100644 --- a/t/pins.t +++ b/t/pins.t @@ -120,7 +120,7 @@ BEGIN { { package My::Importer::C; - use Importer 'My::Exporter' => qw/:v1 g1 g2/; + use Importer 'My::Exporter' => qw/:v1 +v1 g1 g2/; ::is(a(), 'a1', "got v1 a()"); ::is(b(), 'b1', "got v1 b()"); diff --git a/t/units.t b/t/units.t index be88c84..5e123db 100644 --- a/t/units.t +++ b/t/units.t @@ -288,7 +288,7 @@ subtest reload_menu => sub { { lookup => {}, exports => {}, - tags => { DEFAULT => [], ALL => [], 'v0' => ['+v0'] }, + tags => { DEFAULT => [], ALL => [], 'v0' => ['+v0' => []], 'v0:DEFAULT' => ['+v0' => []], 'v0:ALL' => ['+v0' => []] }, fail => undef, generate => undef, magic => {}, @@ -387,10 +387,13 @@ subtest reload_menu => sub { '%ZAP' => \%Fake::ExporterI::ZAP, }, tags => { - b => [qw/bar baz/], - DEFAULT => [qw/foo &bar $ZAP %ZAP @ZAP/], - ALL => [sort qw/&foo &bar &baz &ick &missing &x &z &gena &genb %ZAP $ZAP @ZAP/], - 'v0' => [ '+v0', qw/foo &bar $ZAP %ZAP @ZAP/ ], + 'b' => [qw/bar baz/], + 'DEFAULT' => [qw/foo &bar $ZAP %ZAP @ZAP/], + 'ALL' => [sort qw/&foo &bar &baz &ick &missing &x &z &gena &genb %ZAP $ZAP @ZAP/], + 'v0' => [ '+v0' => [qw/foo &bar $ZAP %ZAP @ZAP/] ], + 'v0:DEFAULT' => [ '+v0' => [qw/foo &bar $ZAP %ZAP @ZAP/]], + 'v0:ALL' => [ '+v0' => [sort qw/&foo &bar &baz &ick &missing &x &z &gena &genb %ZAP $ZAP @ZAP/] ], + 'v0:b' => [ '+v0' => [qw/bar baz/]], }, fail => { '&ick' => 1, ick => 1 }, magic => {}, @@ -477,10 +480,13 @@ subtest reload_menu => sub { '%ZAP' => \%Fake::ExporterE::ZAP, }, tags => { - b => [qw/bar baz/], - DEFAULT => [qw/foo &bar $ZAP %ZAP @ZAP/], - ALL => [sort qw/&foo &bar &baz &ick &missing &x &z &gena &genb %ZAP $ZAP @ZAP/], - v0 => ['+v0', qw/foo &bar $ZAP %ZAP @ZAP/], + 'b' => [qw/bar baz/], + 'DEFAULT' => [qw/foo &bar $ZAP %ZAP @ZAP/], + 'ALL' => [sort qw/&foo &bar &baz &ick &missing &x &z &gena &genb %ZAP $ZAP @ZAP/], + 'v0' => ['+v0' => [qw/foo &bar $ZAP %ZAP @ZAP/]], + 'v0:DEFAULT' => ['+v0' => [qw/foo &bar $ZAP %ZAP @ZAP/]], + 'v0:b' => ['+v0' => [qw/bar baz/]], + 'v0:ALL' => ['+v0' => [sort qw/&foo &bar &baz &ick &missing &x &z &gena &genb %ZAP $ZAP @ZAP/]], }, fail => { '&ick' => 1, ick => 1 }, magic => {}, @@ -502,7 +508,13 @@ subtest parse_args => sub { return ( export => [qw/foo &bar $ZAP %ZAP @ZAP/], export_ok => [qw/baz ick missing/], - export_tags => {b => [qw/bar baz/]}, + export_tags => { + b => [qw/bar baz/], + c => [ + boo => {'-as' => 'buz', '-prefix' => 'a_', '-postfix' => '_a'}, + ':b' + ], + }, export_fail => [qw/ick/], export_anon => { x => \&__x, z => \&__z }, export_gen => { @@ -516,6 +528,7 @@ subtest parse_args => sub { ); } + sub boo { 'boo' } sub foo { 'foo' } sub bar { 'bar' } sub baz { 'baz' } @@ -672,6 +685,22 @@ subtest parse_args => sub { "Spec for pattern" ); + is_deeply( + [$one->parse_args('Dest', ':c' => {-prefix => 'b_', -postfix => '_b'})], + [ + 'Dest', + [], + {}, + [ + ['&boo', {-as => 'buz', -prefix => 'b_a_', -postfix => '_a_b'}], + ['&bar', {-prefix => 'b_', -postfix => '_b'}], + ['&baz', {-prefix => 'b_', -postfix => '_b'}], + ], + undef, + ], + "Spec for tag with embedded and added specs" + ); + is_deeply( [$one->parse_args('Dest', 22, qr/A/, { -postfix => '_foo' }, '!$ZAP', 45)], [ -- cgit v1.2.3