File Coverage

blib/lib/No/Worries/Export.pm

Criterion	Covered	Total	%
statement	53	62	85.4
branch	13	20	65.0
condition			n/a
subroutine	10	10	100.0
pod	1	1	100.0
total	77	93	82.8

#+##############################################################################
#                                                                              #
# File: No/Worries/Export.pm                                                   #
#                                                                              #
# Description: symbol exporting without worries                                #
#                                                                              #
#-##############################################################################

#
# module definition
#

package No::Worries::Export;
use strict;
use warnings;
our $VERSION  = "1.7";
our $REVISION = sprintf("%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/);

#
# used modules
#

use Params::Validate qw(validate_with :types);

#
# simple yet powerful export control
#

sub export_control ($$$@) {
    my($callpkg, $pkg, $exported, @names) = @_;
    my($name, $regexp, $ref);

    validate_with(
        params => \@_,
        spec => [ { type => SCALAR }, { type => SCALAR }, { type => HASHREF } ],
        allow_extra => 1,
    );
    while (@names) {
        $name = shift(@names);
        # special case for * and /.../ and x.y
        if ($name eq "*") {
            unshift(@names, grep(!ref($exported->{$_}), keys(%{ $exported })));
            next;
        } elsif ($name =~ /^\/(.*)\/$/) {
            $regexp = $1;
            unshift(@names, grep(/$regexp/, grep(!ref($exported->{$_}),
                                                 keys(%{ $exported }))));
            next;
        } elsif ($name =~ /^\d/) {
            # version checking via UNIVERSAL
            $pkg->VERSION($name);
            next;
        }
        die("\"$name\" is not exported by the $pkg module\n")
            unless defined($exported->{$name});
        $ref = ref($exported->{$name});
        if ($ref eq "") {
            # normal symbol
            if ($name =~ /^(\w+)$/) {
                # function
                no strict qw(refs);
                no warnings qw(once prototype);
                *{"${callpkg}::${1}"} = \&{"${pkg}::${1}"};
            } elsif ($name =~ /^\$(\w+)$/) {
                # scalar
                no strict qw(refs);
                *{"${callpkg}::${1}"} = \${"${pkg}::${1}"};
            } elsif ($name =~ /^\@(\w+)$/) {
                # array
                no strict qw(refs);
                *{"${callpkg}::${1}"} = \@{"${pkg}::${1}"};
            } elsif ($name =~ /^\%(\w+)$/) {
                # hash
                no strict qw(refs);
                *{"${callpkg}::${1}"} = \%{"${pkg}::${1}"};
            } else {
                die("unsupported export by the $pkg module: $name\n");
            }
        } elsif ($ref eq "CODE") {
            # special symbol
            $exported->{$name}->($name);
        } else {
            die("unsupported export by the $pkg module: $name=$ref\n");
        }
    }
}

#
# export control
#

sub import : method {
    my($pkg, %exported);

    $pkg = shift(@_);
    grep($exported{$_}++, qw(export_control));
    export_control(scalar(caller()), $pkg, \%exported, @_);
}

1;

__DATA__