File Coverage

lib/Badger/Exporter.pm

Criterion	Covered	Total	%
statement	228	239	95.4
branch	120	150	80.0
condition	36	59	61.0
subroutine	28	31	90.3
pod	12	13	92.3
total	424	492	86.1

#========================================================================
#
# Badger::Exporter
#
# DESCRIPTION
#   This module is an OO version of the Exporter module.  It
#   does the same kind of thing but with an OO interface that means
#   you don't have to go messing around with package variables.  It
#   correctly handles inheritance, exporting not only those symbols
#   defined by a subclass, but also those of its base classes.
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Exporter;

use Carp;
use strict;
use warnings;
use constant {
    ALL             => 'all',           # Alas, we can't pull these in from
    NONE            => 'none',          # Badger::Constants because it's a
    DEFAULT         => 'default',       # subclass of Badger::Exporter which
    IMPORT          => 'import',        # gives us a chicken-and-egg dependency
    IMPORTS         => 'imports',       # problem.We could pull them into
    HOOKS           => 'hooks',         # Badger::Constants though because
    ARRAY           => 'ARRAY',         # that's a subclass... hmmm....
    HASH            => 'HASH',
    CODE            => 'CODE',
    EXPORT_ALL      => 'EXPORT_ALL',
    EXPORT_ANY      => 'EXPORT_ANY',
    EXPORT_TAGS     => 'EXPORT_TAGS',
    EXPORT_FAIL     => 'EXPORT_FAIL',
    EXPORT_HOOKS    => 'EXPORT_HOOKS',
    EXPORT_BEFORE   => 'EXPORT_BEFORE',
    EXPORT_AFTER    => 'EXPORT_AFTER',
    EXPORTABLES     => 'EXPORTABLES',
    ISA             => 'ISA',
    REFS            => 'refs',
    ONCE            => 'once',
    PKG             => '::',
    DELIMITER       => qr/(?:,\s*)|\s+/,  # match a comma or whitespace
    MISSING         => "Missing value for the '%s' option%s",
    BAD_HANDLER     => "Invalid export %s handler specified: %s",
    BAD_HOOK        => "Invalid export hook handler specified for the '%s' option: %s",
    WANTED          => " (%s wanted, %s specified)",
    UNDEFINED       => " (argument %s of %s is undefined)",
};

our $VERSION   = 0.01;
our $DEBUG     = 0 unless defined $DEBUG;
our $HANDLERS  = {
    all     => \&export_all,
    any     => \&export_any,
    tags    => \&export_tags,
    hooks   => \&export_hooks,
    fail    => \&export_fail,
    before  => \&export_before,
    after   => \&export_after,
};


#-----------------------------------------------------------------------
# export declaration methods:
#   exports( all => [...], any => [...], ...etc... )
#   export_all('foo bar baz')
#   export_any('foo bar baz')
#   export_before( sub { ... } )
#   export_after( sub { ... } )
#   export_tags( set1 => 'foo bar baz', set2 => 'wam bam' )
#   export_hooks( foo => sub { ... }, bar => sub { ... } )
#   export_fail( sub { ... } )
#-----------------------------------------------------------------------

sub exports {
    my $self = shift;
    my $data = @_ == 1 && ref $_[0] eq HASH ? shift : { @_ };
    my $handler;

    # delegate each key in $data to a handler in $HANDLERS
    while (my ($key, $value) = each %$data) {
        $handler = $HANDLERS->{ $key }
            || croak "Invalid exports key: $key\n";
        $handler->($self, $value);
    }
}

sub export_all {
    my $self = shift;
    my $args = @_ == 1 ? shift : [ @_ ];
    my $list = $self->export_variable( EXPORT_ALL => [ ] );
    push( @$list, ref $args eq ARRAY ? @$args : split(DELIMITER, $args) );
}

sub export_any {
    my $self = shift;
    my $args = @_ == 1 ? shift : [ @_ ];
    my $list = $self->export_variable( EXPORT_ANY => [ ] );
    push( @$list, ref $args eq ARRAY ? @$args : split(DELIMITER, $args) );
}

sub export_before {
    my $self = shift;
    my $args = @_ == 1 ? shift : [ @_ ];
    my $list = $self->export_variable( EXPORT_BEFORE => [ ] );
    push( @$list, ref $args eq ARRAY ? @$args : $args );
}

sub export_after {
    my $self = shift;
    my $args = @_ == 1 ? shift : [ @_ ];
    my $list = $self->export_variable( EXPORT_AFTER => [ ] );
    push( @$list, ref $args eq ARRAY ? @$args : $args );
}

sub export_tags {
    my $self = shift;
    my $args = (@_ == 1) && (ref $_[0] eq HASH) ? shift : { @_ };
    my $tags = $self->export_variable( EXPORT_TAGS => { } );

    # Add new tags into $EXPORT_TAGS hash ref
    @$tags{ keys %$args } = map {
        # Tags can be defined as hash arrays containing (key => '=value')
        # declarataions.  We upgrade each '=value' to a constant subroutine.
        if (ref && ref eq HASH) {
            while (my ($key, $value) = each %$_) {
                if ($value =~ s/^=//) {
                    _debug("export_tags() constructing constant: $key => $value\n") if $DEBUG;
                    $_->{ $key } = sub() { $value };
                }
            }
        }
        $_;
    }
    values %$args;

    # all symbols referenced in tagsets (except other tag sets) must be
    # flagged as exportable
    $self->export_any(
        grep {
            # ignore references to code or other tag sets
            not (ref || /^(:|=)/);
        }
        map {
            # symbols in tagset can be a list ref, hash ref or string
            ref $_ eq ARRAY ? @$_ :
            ref $_ eq HASH  ? %$_ :
            split DELIMITER
        }
        values %$args
    );

    return $tags;
}

sub export_hooks {
    my $self  = shift;
    my $args  = (@_ == 1) && (ref $_[0] eq HASH) ? shift : { @_ };
    my $hooks = $self->export_variable( EXPORT_HOOKS => { } );
    @$hooks{ keys %$args } = values %$args;
    return $hooks;
}

sub export_fail {
    my $self  = shift;
    my $class = ref $self || $self;
    no strict REFS;

    # get/set $EXPORT_FAIL
    return @_
        ? (${$class.PKG.EXPORT_FAIL} = shift)
        :  ${$class.PKG.EXPORT_FAIL};
}


#------------------------------------------------------------------------
# import/export methods:
#   import(@imports)
#   export($target, @exports)
#------------------------------------------------------------------------

sub import {
    my $class  = shift;
    my $target = (caller())[0];

    # enable strict and warnings in the caller - this ensures that every
    # Badger module (that calls this method - which is pretty much all of
    # them) has strict/warnings enabled, without having to explicitly write
    # it.  Thx Moose!
    strict->import;
    warnings->import;

    # call in the heavy guns
    $class->export($target, @_);
}

sub export {
    my $class     = shift;
    my $target    = shift;
    my $imports   = @_ == 1 ? shift : [ @_ ];
    my ($all, $any, $tags, $hooks, $fails, $before, $after)
                  = $class->exportables;
    my $can_hook  = (%$hooks ? 1 : 0);
    my $added_all = 0;
    my $count     = 0;
    my ($symbol, $symbols, $source, $hook, $pkg, $nargs,
        %done, @args, @errors);

    no strict   REFS;
    no warnings ONCE;

    # imports can be a single whitespace delimited string of symbols
    $imports = [ split(DELIMITER, $imports) ]
        unless ref $imports eq ARRAY;

    # default to export_all if list of exports not specified
    # TODO: what about: use Badger::Example qw();    ?  perhaps we should
    # return unless @_ up above?
    @$imports = @$all unless @$imports;

    foreach $hook (@$before) {
        $hook->($class, $target, $imports);
    }

    SYMBOL: while (@$imports) {
        next unless ($symbol = shift @$imports);
        next if $done{ $symbol }++;

        # look for :tagset symbols and expand their contents onto @$imports
        if ($symbol =~ s/^://) {
            if ($symbols = $tags->{ $symbol }) {
                if (ref $symbols eq ARRAY) {
                    # expand list of symbols onto @$imports list
                    unshift(@$imports, @$symbols);
                }
                elsif (ref $symbols eq HASH) {
                    # map hash into [name => $symbol] pairs
                    unshift(@$imports, map { [$_ => $symbols->{ $_ }] } keys %$symbols);
                }
                else {
                    # string of space-delimited symbols
                    unshift(@$imports, split(DELIMITER, $symbols));
                }
            }
            elsif ($symbol eq DEFAULT) {
                unshift(@$imports, @$all);
            }
            elsif ($symbol eq ALL) {
                unshift(@$imports, keys %$any);
                $added_all = 1;
            }
            else {
                push(@errors, "Invalid import tag: $symbol\n");
            }
            next SYMBOL;
        }

        if (ref $symbol eq ARRAY) {
            # a pair of [name, $symbol] expanded from a :tag hash set
            ($symbol, $source) = @$symbol;
#           _debug("expanded export pair: $symbol => $source\n") if $DEBUG;
        }
        elsif ($can_hook && ($hook = $hooks->{ $symbol })) {
            # a hook can be specified as [$code,$nargs] in which case we
            # generate a closure around the $code which shifts $nargs off
            # the symbols list and passes them as arguments to $code
            $hook = $hooks->{ $symbol } = $class->export_hook_generator($symbol, $hook)
                unless ref $hook eq CODE;

            # fire off handler hooked to this import item
            &$hook($class, $target, $symbol, $imports);

            # hooks can be repeated so pretend we haven't done it
            $done{ $symbol }--;
            next SYMBOL;
        }
        elsif ($symbol eq IMPORTS) {
            # special 'imports' hook disables any more hooks causing
            # all remaining arguments to be imported as symbols
            $can_hook = 0;
            next SYMBOL;
        }
        elsif ($symbol eq IMPORT) {
            # 'import' hook accepts the next item as an import list/string
            # and unpacks it onto the front of the imports list.  We disable
            # hooks for the duration of the import and insert a dummy HOOKS
            # symbol at the end to re-enable hooks
            $can_hook = 0;
            if ($symbols = shift @$imports) {
                $symbols = [ split(DELIMITER, $symbols) ]
                    unless ref $symbols eq ARRAY;
                unshift(@$imports, @$symbols, HOOKS);
            }
            else {
                push(@errors, "Missing argument for $symbol hook\n");
            }
            next SYMBOL;
        }
        elsif ($symbol eq HOOKS) {
            # special 'hooks' item turns hooks back on
            $can_hook = 1;
            next SYMBOL;
        }
        else {
            # otherwise the symbol exported is the one requested
            $source = $symbol;
        }

        # check we're allowed to export the symbol requested
        if ($pkg = $any->{ $symbol }) {
#           _debug("exporting $symbol from $pkg to $target\n") if $DEBUG;
        }
        else {
            foreach $hook (@$fails) {
                if (&$hook($class, $target, $symbol, $imports)) {
                    # hooks can be repeated so pretend we haven't done it
                    $done{ $symbol }--;
                    next SYMBOL;
                }
            }
            push(@errors, "$symbol is not exported by $class\n");
            next SYMBOL;
        }

        if (ref $source eq CODE) {
            # patch directly into the code ref
#           _debug("exporting $symbol from code reference\n") if $DEBUG;
            *{ $target.PKG.$symbol } = $source;
        }
        else {
            my $type = "&";
            $symbol =~ s/^(\W)//;
            $source =~ s/^(\W)// and $type = $1;
            # NOTE: '=value' should *probably* never be found at this point
            # because we're now upgrading them to constant subroutines in
            # the import_tags() method.  However, I'm leaving this in here
            # until I've had a chance to properly review the code and convince
            # myself that this assumption is correct.
            _debug("export() constructing constant: $symbol => $source\n")
                if $DEBUG && $type eq '=';
            $source = $pkg.PKG.$source unless $source =~ /::/ or $type eq '=';
            _debug("exporting $type$symbol from $source into $target\n") if $DEBUG;
            *{ $target.PKG.$symbol } =
                $type eq '&' ?    \&{$source} :
                $type eq '$' ?    \${$source} :
                $type eq '@' ?    \@{$source} :
                $type eq '%' ?    \%{$source} :
                $type eq '*' ?     *{$source} :
                $type eq '=' ? sub(){$source} :
                do { push(@errors, "Can't export symbol: $type$symbol\n"); next; };
        }
        $count++;
    }
    continue {
        # if we're on the last item and we've only processed hooks
        # (i.e. no real symbols were specified then we export the
        # default set of symbols instead
        unless (@$imports or $count or $added_all) {
            unshift(@$imports, @$all);
            $added_all = 1;
        }
    }

    if (@errors) {
        require Carp;
        Carp::croak("@{errors}Can't continue after import errors");
    }

    foreach $hook (@$after) {
        $hook->($class, $target);
    }

    return 1;
}

sub exportables {
    my $class = shift;
    no strict REFS;
    no warnings ONCE;

    my $cache = ${ $class.PKG.EXPORTABLES } ||= do {
        my ($pkg, $symbols, %done, @all, %any, %tags, %hooks, @fails, @before, @after);
        my @pending = ($class);
        no strict REFS;

        # walk up inheritance tree collecting values from the @$EXPORT_ALL,
        # @$EXPORT_ANY, %$EXPORT_TAGS, %$EXPORT_HOOKS and $EXPORT_FAIL pkg
        # variables, then cache them in $EXPORT_CACHE for subsequent use

        while ($pkg = shift @pending) {
            next if $done{ $pkg }++;

            # TODO: we could optimise here by looking for a previously
            # computed EXPORTABLES in the base class and merging it in...

            # $EXPORT_ANY package vars are list references containing symbols,
            # which we use to populate the %any hash which maps symbols to
            # their source packages.  e.g. { foo => 'My::Package' }
            # The presence of an entry in this table indicates that the symbol
            # key can be exported.  The corresponding value indicates the
            # package that it must be exported from.  We don't replace any
            # existing entries in the %any hash because we're working from
            # sub-class upwards to super-class, .  This ensures that the
            # entries put in first by more specialised sub-classes are used
            # in preference to those defined by more general super-classes.
            if ($symbols = ${ $pkg.PKG.EXPORT_ANY }) {
                $symbols = [ split(DELIMITER, $symbols) ]
                    unless ref $symbols eq ARRAY;
                $any{ $_ } ||= $pkg
                    for @$symbols;
            }

            # $EXPORT_ALL is merged into @all and all symbols are mapped
            # to their packages in %any
            if ($symbols = ${ $pkg.PKG.EXPORT_ALL }) {
                $symbols = [ split(DELIMITER, $symbols) ]
                    unless ref $symbols eq ARRAY;
                push(
                    @all,
                    map { $any{ $_ } ||= $pkg; $_ }
                    @$symbols
                );
            }

            # $EXPORT_TAGS are copied into %tags unless already defined
            if ($symbols = ${ $pkg.PKG.EXPORT_TAGS }) {
                $tags{ $_ } ||= $symbols->{ $_ }
                    for keys %$symbols;
            }

            # $EXPORT_HOOKS are copied into %hooks unless already defined
            # (by a more specific subclass) either as hooks or any/all items
            if ($symbols = ${ $pkg.PKG.EXPORT_HOOKS }) {
                $any{ $_ } or $hooks{ $_ } ||= $symbols->{ $_ }
                    for keys %$symbols;
            }

            # $EXPORT_FAIL has only one value per package, but we can have
            # several packages in the class ancestry
            if ($symbols = ${ $pkg.PKG.EXPORT_FAIL }) {
                push(@fails, $symbols);
            }

            # $EXPORT_BEFORE and $EXPORT_AFTER are references to CODE or
            # ARRAY refs (of CODE refs, we assume).  As we travel up from
            # subclass to superclass, we unshift() the handlers onto the
            # start of the @before/@after arrays.  This ensures that the base
            # class handlers get called before subclass handlers.
            if ($symbols = ${ $pkg.PKG.EXPORT_BEFORE }) {
                unshift(
                    @before,
                    ref $symbols eq CODE  ?  $symbols :
                    ref $symbols eq ARRAY ? @$symbols :
                    croak sprintf(BAD_HANDLER, before => $symbols)
                );
            }

            if ($symbols = ${ $pkg.PKG.EXPORT_AFTER }) {
                unshift(
                    @after,
                    ref $symbols eq CODE  ?  $symbols :
                    ref $symbols eq ARRAY ? @$symbols :
                    croak sprintf(BAD_HANDLER, after => $symbols)
                );
            }

            # This is the same depth-first inheritance resolution algorithm
            # that Perl uses.  We can't use the fancy heritage() method in
            # Badger::Class because of the Chicken-and-Egg dependency problem
            # between Badger::Exporter and Badger::Class
            push(@pending, @{$pkg.PKG.ISA});
        }

        [\@all, \%any, \%tags, \%hooks, \@fails, \@before, \@after];
    };

    return wantarray
        ? @$cache
        :  $cache;
}

sub export_symbol {
    my ($self, $target, $symbol, $ref) = @_;
    no strict   REFS;
    no warnings ONCE;
    *{ $target.PKG.$symbol } = $ref;
}

sub export_variable {
    my ($self, $name, $default) = @_;
    my $class = ref $self || $self;
    my $var   = $class.PKG.$name;
    my $item;
    no strict REFS;

    unless (defined ($item = ${$var})) {
        # install the default value ref into the SCALAR $EXPORT_XXXX var
        ${$var} = $item = $default;
        # then poke the symbol table to make Perl notice it's defined
        *{$var} = \${$var};
    }

    return $item;
}

sub export_hook_generator {
    my $self = shift;
    my $name = shift;
    my $hook = @_ == 1 ? shift : [ @_ ];

    # do nothing if we've already got a code ref that doesn't require args
    return $hook
        if ref $hook eq CODE;

    # anything else must be a list ref containing [$code_ref, $n_args]
    croak sprintf(BAD_HOOK, $name, $hook)
        unless ref $hook eq ARRAY;

    my ($code, $nargs) = @$hook;

    # user is trying to confuse us with [$non_code_ref, ...]
    croak sprintf(BAD_HOOK, $name, $code)
        unless ref $code eq CODE;

    # [$code, 0] or [$code] is fine as just $code, also reject $nargs < 0
    return $code
        unless $nargs && $nargs > 0;

    # OK it's safe to proceed
    return sub {
        my ($this, $target, $symbol, $symbols) = @_;
        my $n = 1;
        # check we've got enough arguments
        croak sprintf(MISSING, $symbol, sprintf(WANTED, $nargs, scalar @$symbols))
            if @$symbols < $nargs;

        # call the code ref with the first $nargs arguments, making sure
        # they all have defined values
        $code->(
            $this, $target, $symbol,
            ( map {
                croak sprintf(MISSING, $symbol, sprintf(UNDEFINED, $n, $nargs))
                    unless defined $_;
                $n++;
                $_
              }
              splice(@$symbols, 0, $nargs)
            ),
            $symbols,
        );
    }
}

sub _debug {
    print STDERR @_;
}


1;

__END__