File Coverage

blib/lib/Exporter/VA.pm

Criterion	Covered	Total	%
statement	285	299	95.3
branch	121	158	76.5
condition	25	36	69.4
subroutine	54	55	98.1
pod	7	21	33.3
total	492	569	86.4

=head1 NAME

Exporter::VA - Improved Exporter featuring Versioning and Aliasing.

=cut

### see the main POD at the end of this file.

package Exporter::VA;
use strict;
use warnings;
use Carp qw/croak carp/;
use utf8;
our $VERSION= v1.3.0.1;  # major.minor.update.docsonly
*VERBOSE= *STDERR{IO};   # can be redirected

my %EXPORT= (
   '&VERSION' => \&export_VERSION,
   '&import' => \&export_import,
   '&AUTOLOAD' => \&export_AUTOLOAD,
   '.default_VERSION'=> v0.1,
   ':normal' => [qw/ &VERSION &import &AUTOLOAD/ ],
   '.&begin' => \&begin,
   '&normalize_vstring' => \\&normalize_vstring,
   '&autoload_symbol' => \\&autoload_symbol,
   );

sub Err
 {
 # improve this to give proper level information to Croak.
 croak @_;
 }

sub Warn
 {
 carp @_;
 }

sub dump
 {
 # Currently implemented to use Data::Dumper, but might change to be more custom some day.
 eval {  require Data::Dumper };
 if ($@) {
    print VERBOSE "**(Exporter::VA::dump) ERROR: cannot load Data::Dumper module to support the dump() method or --dump pragma\n";
    return;
    }
 my $self= shift;
 print VERBOSE (Data::Dumper->Dump ( [ $self ], ["*EXPORT"]), $/);
 }

sub is_vstring($)
 {
 my $s= shift;
 my $count= $s =~ tr/\0-\1F//;
 return $count > 0;
 # to disambiguate a v-string like v65.66.67, add a trailing .0 becoming v.65.66.67.0 with same meaning.
 }

sub normalize_vstring ($)
 {
 my $v= shift;
 # for now, doesn't do much.
 return v0 if length ($v) eq 0;
 $v= pack ("U*", split (/\./,$v))
    unless is_vstring ($v);
 # remove trailing redundant zeros (but keep it at least 2 digits, so v1.0 is right, v1.0.0.0 is truncated)
 $v =~ s/(?<=..)\0+$//;
 return $v;
 }


sub _calling_client()
 {
 my $n= 1;
 for (;;) {
    my $caller= caller($n);
    return $caller  if $caller ne __PACKAGE__;  # I want the first caller of this module
    ++$n;
    }
 }

sub _check_allowed_versions
 {
 my ($version, $list)= @_;
 return unless defined $list;  # if .allowed_VERSIONS is not specified, anything is allowed.
 foreach (@$list) {
    return  if $version eq $_;  # normalized earlier.
    }
 # compose error message
 my $vs= join( ', ', map { _format_vstring($_)} (@$list) );
 Err "(Exporter::VA) you asked for ", _format_vstring($version), ", but the only allowed versions are $vs";
 }

sub generate_VERSION
 {
 my $export_def= shift;  # might not have been blessed yet.
 return sub {  # this becomes the VERSION function in the exporting module.
    my ($home, $version, $client)= @_;
    $client= _calling_client() unless defined $client;  # allow as optional argument
    if (defined $version) {
       # assure correct version / set desired version
       $version= normalize_vstring($version);
       Err "The version for this module has already been specified for module $client as ", _format_vstring ($export_def->{'..client_default_version'}{$client})
          if exists $export_def->{'..client_default_version'}{$client};
       my $max_version= $export_def->{'..max_VERSION'} || _get_VERSION ($home);  # first time, called before setup.
       Err "$client requested version ", _format_vstring ($version), " but module $home is only version ", _format_vstring ($max_version)
          if $version gt $max_version;
       _check_allowed_versions ($version, $export_def->{'.allowed_VERSIONS'});
       $export_def->{'..client_default_version'}{$client}= $version;
       }
    else {
       # fetch version
       return $export_def->{'..client_default_version'}{$client}  if exists $export_def->{'..client_default_version'}{$client};
       # never explicitly specified, so use the module's actual current version.
       $version= $export_def->{'..max_VERSION'} || _get_VERSION ($home);
       $export_def->{'..client_default_version'}{$client}= $version;  # once I decide, must always use the same result.
       return $version;
       }
    }
 }

sub get_import_version
 {
 my ($self, $client)= @_;
 unless (exists ($self->{'..client_default_version'}{$client})) {
 Err "(Exporter::VA) you must specify a version to import, since the module has no default."
    unless exists $$self{'.default_VERSION'};
    $self->{'..client_default_version'}{$client}= $$self{'.default_VERSION'};
    print VERBOSE "(Exporter::VA) import version not specified, using .default_VERSION\n"
       if $$self{'.verbose_import'};
    }
 return $$self{'..client_default_version'}{$client};
 }

sub _format_vstring($)
 {
 return sprintf ("v%vd", shift);
 }


sub _normalize_vstring_list
 {
 my $list= shift;
 for (my $loop= 0; $loop < @$list; $loop+=2) {
    normalize_vstring ($$list[$loop]);
    }
 bless $list, "ARRAY-seen";
 }

sub _match_vstring_list
 {
 my ($list, $desired_version)= @_;
 # list is [ v1, item1, v2, item2, v3, item3, ... , vn, itemn ]
 # match $desired_version between two v's, and return (v,item).
 for (my $index=0;  $index < scalar(@$list);  $index+=2) {
    my $ver_at_index= $$list[$index];  # >> might need to normalize it.
    next unless ($ver_at_index ge $desired_version);
    # I get here when I found or passed my spot.
    return @$list[$index, $index+1]  if ($ver_at_index eq $desired_version);  # found it exactly
    # otherwise I passed it.
    return (undef, undef, "desired version not found")  if $index == 0;  # before the first, is not present.
    return @$list[$index-2, $index-1];
    }
 # after the last, take the last.  Should cap at Module's version, but that was checked earlier when VERSION was called.
 return @$list[-2,-1];
 }

sub generate_import
 {
 my $export_def= shift;
 return sub {
    my $home= shift;
    $export_def->setup ($home);  # happens first time used.
    my $client= _calling_client();
    my $version= $export_def->get_import_version ($client);
    $export_def->callback ('.&begin', $client, $version, '.&begin', \@_);
    @_ = ':DEFAULT'  if (!@_ && defined $export_def->{':DEFAULT'});
    $export_def -> export ($client, $version, \@_);
    $export_def->callback ('.&end', $client, $version, '.&begin', \@_);
    $export_def->_process_worklist();
    --$$export_def{'.verbose_import'}  if $$export_def{'.verbose_import'};
    }
 }

sub export
 {
 my ($self, $module, $version, $items)= @_;
 $items= [$items]  unless ref $items eq 'ARRAY';  # allow single item
 while (my $item= shift @$items) {
    my $verbose= $$self{'.verbose_import'};  # must check object each time, not cache it.
    print VERBOSE "(Exporter::VA) ===processing import parameter ($item)===\n"    if $verbose;
    if (ref $item) {
       print VERBOSE "(Exporter::VA) It's not a scalar, so invoking .&unknown_type callback.  It's out of my hands.\n"  if $verbose;
       $self->callback ('.&unknown_type', $module, $version, $item, $items);
       }
    else {
       if ($item =~ /^[\$\@\%\*\&]?\w+$/ or $item =~ /^-/ or $item =~s /^(<\w+)>$/$1/) { $self->export_one_symbol ($module,$version,$item,$items) }
       elsif ($item =~ /^:\w+$/) { $self->export_one_tag ($module,$version,$item, $items) }
       else {
          print VERBOSE "(Exporter::VA) It's not syntactically correct, so invoking .&unknown_feature callback.  It's out of my hands.\n"  if $verbose;
          $self->callback ('.&unknown_feature', $module, $version, $item, $items);
          }
       }
    }
 }


{
my %thing= reverse (SCALAR=>'$', ARRAY=>'@', HASH=>'%',CODE=>'&',IO=>'<',GLOB=>'*');
sub _resolve_by_name
 {
 my ($item, $home, $name)= @_;
 $name= $item  if $name eq '';  # blank string means "same".
 my $sigil= ($name =~ s/^([\$\@\%\&\<\*])//) ? $1  : '&';
 my $thing= $thing{$sigil};
 Err "(Exporter::VA) Improper export definition for item $item: invalid symbol name syntax: $name"  unless defined $thing;
 no strict 'refs';
 my $globref= ${"$home\::"}{$name};
 Err "(Exporter::VA) Symbol to export does not exist: *$home\::$name"  unless defined $globref;
 return *{$globref}{$thing};
 } # _resolve_by_name
} # private vars scope

sub _resolve_by_versionlist
 {
 my ($self, $module, $desired_version, $item, $param_tail)= @_;
 my $versionlist= $$self{$item};  # I still have the $item name for callbacks and error messages
 my ($got_version, $result)= _match_vstring_list ($versionlist, $desired_version);
 print VERBOSE "(Exporter::VA) wanted $item version ", _format_vstring($desired_version), ", choose ", _format_vstring($got_version), "\n"
   if $$self{'.verbose_import'};
 return resolve (@_[0..4], $result);
 }

sub _resolve_by_hardlink
 {
 my ($item, $hardlink)= @_;
 # This function just provides error checking.  Returning wrong kind of ref can cause problems!
 Err "(Exporter::VA) Improper export definition for item $item: ref to scalar must contain \\\\&code"  unless ref($hardlink) eq 'CODE';
 return $hardlink;
 }

sub resolve
 {
 my ($self, $module, $version, $item, $param_tail, $value)= @_;
 $value= $$self{$item}  unless defined ($value);  # normally lookup, can supply ahead of time for recursive call.
 if (!defined $value && $item =~ /^&(.+)$/) {
    # it might be entered in the export def without the sigil.
    my $base= $1;
    $value= delete $$self{$base};
    if (defined $value) {
       $$self{$item}= $value;
       print VERBOSE "(Exporter::VA) adding leading & to ($base) entry in export definition\n"  if $$self{'.verbose_import'};
       }
    }
 return $self->callback ('.&unknown_import', $module, $version, $item, $param_tail)
    unless defined $value;  # not listed in export def.
 my $type= ref $value;  # what is it?  Lots of different ways to list it.
 return _resolve_by_name ($item, $$self{'..home'}, $value)  unless $type;  # scalar is a name in the home package.
 return &_resolve_by_versionlist  if $type eq 'ARRAY-seen';
 if ($type eq 'ARRAY') {
    _normalize_vstring_list ($value);
    return &_resolve_by_versionlist;
    }
 return $value->(@_)  if $type eq 'CODE';
 return _resolve_by_hardlink ($item, $$value);
 Err "(Exporter::VA) Invalid export definition for item $item";
 }

sub export_one_symbol # or pragma
 {
 my ($self, $module, $version, $item, $param_tail)= @_;
 my $sigil= ($item =~ s /^([\$\@\%\*\&\-\<])//) ? $1 : '&';
 Warn qq((Exporter::VA) warning: importing symbol "$sigil$item" which begins with an underscore)
    if substr($item,0,1) eq '_';
 my $X= $self->resolve ($module, $version, "$sigil$item", $param_tail);
 if (defined $X && $sigil ne '-') {  # skip the import if it's callback-only
    my $worklist= $self->worklist();
    my $name= "${module}::$item";
    $$worklist{$name}= $X;  # duplicates take last resolution with no errors.
    print VERBOSE qq(Got It:  *{"${module}::$item"}= $X\n)  if $$self{'.verbose_import'};
    }
 }

sub worklist
 {
 my $self= shift;
 return $$self{'..worklist'};
 }

sub _process_worklist
 {
 my $self= shift;
 my $worklist= $self->worklist();
 no strict 'refs';
 while (my ($left, $right)= each (%$worklist)) {
    eval { *{$left}= $right; }; # this better be the right kind of thing!
    if ($@) {
       Err "(Exporter::VA) Could not process import for item '$left' = $right.";
       }
    }
 }

sub export_one_tag
 {
 my ($self, $module, $desired_version, $item, $param_tail)= @_;
 Warn qq((Exporter::VA) warning: importing tag "$item" which begins with an underscore)
    if substr($item,1,1) eq '_';
# my $home= $$self{'..home'};  # package I'm exporting =from=
 RESTART:
 my $list= $$self{$item};
 Err "(Exporter::VA) no such export tag '$item'"  unless defined $list;
 my $type= ref $list;
 if ($type eq 'ARRAY') {
    # identify it, and change $type.
    return  if @$list == 0;  # empty list is OK.
    if (is_vstring($$list[0])) {
       _normalize_vstring_list ($list);
       $type= 'ARRAY-seen';
       }
    else {
       $type= 'ARRAY-tags';
       bless $list, $type;
       }
    }
 if ($type eq 'ARRAY-seen') {
    my ($got_version, $result)= _match_vstring_list ($list, $desired_version);
    print VERBOSE "(Exporter::VA) wanted $item version ", _format_vstring($desired_version), ", choose ", _format_vstring($got_version), "\n"
       if $$self{'.verbose_import'};
    $item= $result;
    goto RESTART;
    }
 elsif ($type eq 'ARRAY-tags') {
 my @copy= @$list;
    $self->export ($module, $desired_version, \@copy);
    }
 ## would add support for other types here, e.g. callbacks.
 else { Err "(Exporter::VA) export tag '$item' is not a list ref" }
 }

sub callback
 {
 my $self= shift;
 my $cb_name= shift;
 my $func= $$self{$cb_name};
 # they should be fully populated, putting in default behavior if it doesn't exist.
 # this is not "try to callback..." so if not found it is an error.
 $func-> ($self, @_);
 }

{
my %defaults= (
   '.&unknown_type' => sub { Err "(Exporter::VA) import parameter is not a string" },
   '.&unknown_feature' => sub { Err "(Exporter::VA) import parameter \"$_[3]\" is not syntactically correct" },
   '.&unknown_import' => sub { Err "(Exporter::VA) import parameter \"$_[3]\" is not listed as an export" },
   '.check_user_option' => sub { return "unknown option"},
   '.warnings' => 1,
   '.&begin' => sub {},
   '.&end' => sub {},
   '--verbose_import' => sub {  ++$_[0]->{'.verbose_import'} },
   '--dump' => sub { $_[0]->dump() }
   );


sub _populate_defaults
 { # helper for setup.
 # populate callbacks and settings that were not specified
 my $self= shift;
 while (my ($key,$value)= each %defaults) {
    $$self{$key}= $value  unless exists $$self{$key};
    }
 no strict 'refs';
 $$self{'.default_VERSION'}= normalize_vstring (${"$self->{'..home'}::VERSION"})  unless exists $$self{'.default_VERSION'};
 }

} # end scope for populate_defaults


sub _expand_plain
 {
 my $self= shift;
 my $plainspec= delete $$self{'.plain'};
 return unless defined $plainspec;
 while (my $value = shift @$plainspec) {
    $value =~ /^([\$\@\&\%:<])?(\w+)>?$/  or Err "(Exporter::VA) item '$value' in .plain list is not a legal symbol or tag name";
    my ($sigil, $body)= ($1,$2);
    $sigil= '&'  unless defined $sigil;
    if ($sigil eq ":") {
       # this one is different
       push @$plainspec, @{$$self{$value}};
       # could do more error checking: make sure tag exists, and doesn't contain v-string list.
       }
    $value= "$sigil$body";
    next  if exists $$self{$value};
    next  if $sigil eq '&' && exists $$self{$body};  # present without the leading & for a function
    next  if $sigil eq '<' && exists $$self{"$body>"};  # present with trailing > for a handle
    # not already present, so add it.
    $$self{$value}=$value;
    }
 }

sub _get_VERSION
 {
 my $home= shift;
 no strict 'refs';
 my $v= ${"${home}::VERSION"};
 Err "(Exporter::VA) module $home does not contain a package global \$VERSION"
    unless defined $v;
 return normalize_vstring ($v);
 }

{ # extra scope for variable local to function

my %check_code= (
  # could point to more detailed checking function, or just 1 for OK/allowed with no additional testing.
   '.allowed_VERSIONS' => 1,
   '.&begin' => 1,
   '.check_user_option' => 1,
   '.default_VERSION' => 1,
    '.&end' => 1,
    '.plain' => 1,
    '.&unknown_feature' => 1,
    '.&unknown_import' => 1,
    '.&unknown_type' => 1,
    '.verbose_import' => 1,
    '.warnings' => 1
    );

 sub _check_warning_option($$$)
 {
 my ($self, $item, $value)= @_;
 if ($item =~ /^\.&?\p{IsUpper}/) {
   # a user-defined option.
   $self->check_user_option ($item);
   }
 return if $item =~ /^\.\./;  # internal state information
 # check for known options.
 my $checker= $check_code{$item};
 if (!defined $checker)  { Warn qq{(Exporter::VA) unknown option present: "$item"} }
 elsif (ref $checker) { $checker->($item,$value) }
 # else it exists but doesn't have special checking code, so no messages.
 }

} # scope for _check_warning_option

sub _check_warning_tag($$)
 {
 my ($item, $value)= @_;
 }

sub _check_warning_pragma($$)
 {
 my ($item, $value)= @_;
 }

sub _check_warning_identifier($$)
 {
 my ($item, $value)= @_;
 }

sub _check_for_warnings
 {
 my $self= shift;
 while (my($key, $value)= each %$self) {
    my $firstchar= substr($key,0,1);
    if ($firstchar eq '.')  { _check_warning_option ($self, $key, $value) }
    elsif ($firstchar eq ':')  {_check_warning_tag ($key, $value) }
    elsif ($firstchar eq '-')	{_check_warning_pragma ($key, $value) }
    else  {_check_warning_identifier ($key, $value) }
    }
 }

sub setup
 {
 my ($self, $home)= @_;
 my $existing_home= $$self{'..home'};
 if (defined $existing_home && $existing_home ne $home) {
    Err "(Exporter::VA) reuse of \%EXPORT in module $home is not allowed.";
    }
 $$self{'..home'}= $home;
 $$self{'..worklist'}= {};
 $$self{'..max_VERSION'}= _get_VERSION ($home);
 $self->_expand_plain();
 $self->_populate_defaults();
 if (exists $$self{'.allowed_VERSIONS'}) {
    $_= normalize_vstring($_)  foreach (@{$$self{'.allowed_VERSIONS'}});
    }
 $self->_check_for_warnings()  if $$self{'.warnings'};
 }

{
my $client_export_def;

sub begin
 {
 my ($blessed_export_def, $caller, $version, $symbol, $param_list_tail)= @_;
 $client_export_def= find_export_def ($caller, $param_list_tail);
 }

sub find_export_def
 {
 my ($caller, $params)= @_;
 # first, try to locate hash ref in parameter list.
 foreach my $index (0..scalar(@$params)-1) {
    my $val= $$params[$index];
    if (ref ($val) eq 'HASH') {
       splice @$params, $index, 1;  # remove it
       splice @$params, $index-1, 1
          if $index>0 && $$params[$index-1] eq '-def';  # remove optional explicit switch
       return $val;  # return it
       }
    }
 # look for package variable in caller.
 no strict 'refs';
 return \%{"$caller\::EXPORT"};
 }

sub export_import
  # called to export a custom import function to *my* client, when Export::VA is used.
 {
 my ($VA_export_def, $caller, $version, $symbol, $param_list_tail)= @_;
 $client_export_def= bless $client_export_def, "Exporter::VA";
 return generate_import ($client_export_def);
 }


sub export_VERSION
  # called to export a custom VERSION function to *my* client, when Export::VA is used.
 {
 # my ($VA_export_def, $caller, $version, $symbol, $param_list_tail)= @_;
 # the above line documents the parameters, but I don't need any of them so it's commented out.
 return generate_VERSION ($client_export_def);
 }


sub export_AUTOLOAD
  # called to export a custom AUTOLOAD function to *my* client, when Export::VA is used.
 {
 # my ($VA_export_def, $caller, $version, $symbol, $param_list_tail)= @_;
 # the above line documents the parameters, but I don't need any of them so it's commented out.
 return _generate_AUTOLOAD ($client_export_def);
 }


}  # end scope around $client_export_def

sub autoload_symbol
 {
 my ($self, $symbol, @extra)= @_;
 my %memory;
 my $home= $self->{'..home'};
 my $thunk= sub {
    my $retval= eval {
       my $caller= _calling_client();  # so I don't have to figure it out multiple times
       my $f= $memory{$caller};
       unless (defined $f) {
          $f= $memory{$caller}= $self->resolve ($caller, $home->VERSION(undef,$caller), '&'.$symbol, [@extra]);
          }
       goto &$f;
       };
    if ($@) {
       carp "(Exporter::VA) Cannot redirect to versioned function ($@)";
       }
    return $retval;
    };
 no strict 'refs';
 *{"${home}::$symbol"}= $thunk;
 }

sub _generate_AUTOLOAD
 {
 my $client_export_def= shift;
 return sub {  # the generated AUTOLOAD
    my $AUTOLOAD= $Exporter::VA::AUTOLOAD;  # save the global in case of recursion.
    my $func= $AUTOLOAD;
    $func =~ s/.*:://;  # not checking the actual module name.  Might be inherited or re-routed or something.  I shouldn't care, right?
    Err "(Exporter::VA) Generated $client_export_def->{'..home'}::AUTOLOAD can't find export definition for $func."
       unless exists $client_export_def->{$func} || exists $client_export_def->{'&' . $func};
    $client_export_def->autoload_symbol ($func);
    goto &$AUTOLOAD;  # try it again.
    }
 }

## main code.
{

my $export_def= bless (\%EXPORT, __PACKAGE__);
use vars qw/*import *VERSION/;  # silence a warning when syntax checking the .pm by itself
*import= generate_import ($export_def);
*VERSION= generate_VERSION ($export_def);
}


1;
__END__