File Coverage

blib/lib/Module/Stubber.pm

Criterion	Covered	Total	%
statement	77	83	92.7
branch	14	22	63.6
condition	3	6	50.0
subroutine	14	14	100.0
pod			n/a
total	108	125	86.4

package Module::Stubber::Stub;
use strict;
use warnings;
use base qw(Exporter);

our $AUTOLOAD;
our %Retvals;
our @EXPORT;

our $MSG_FMT = <
*** '%s' requested at %s:%d
*** This symbol does not really exist, and has been
*** implemented as a stub by Module::Stubber.
*** Depending on how important
*** this function is, this program may not function
*** correctly. This message will only display once.
EOS

our %Warncache;
sub _can_warn($) {
    my $key = shift;
    (my $cls = $key) =~ s/::[^:]+$//g;
    return !(exists $Warncache{$cls} || exists $Warncache{$key});
}

sub AUTOLOAD {
    my $arg = shift;
    my $fn  = $AUTOLOAD;
    my @callinfo = caller(0);
    my ($pkg,$fname,$line,$subname) = @callinfo[0..3];
    if(_can_warn($fn)) {
        printf STDERR ($MSG_FMT, $fn, $fname, $line);
        $Warncache{$fn} = 1;
    }

    if(!exists $Retvals{$fn}) {
        return $arg if ref $arg;
        return 1;
    }

    return $Retvals{$fn};
}

sub new {
    my $cls = shift;
    my $s = "Dummy Object";
    my ($pkg,$file,$line) = caller();
    printf STDERR $MSG_FMT, $cls . "::new", $file, $line if _can_warn($cls . "::new");
    bless \$s, $cls;
}

sub import {
    my ($cls,@options) = @_;
    my @esyms = grep { !ref $_ && $_ =~ m/^[a-zA-Z_\$\@\%\&]/ } @options;
    no strict 'refs';

    @{$cls.'::EXPORT'} = @esyms;
    *{$cls.'::AUTOLOAD'} = \&AUTOLOAD;
    @_ = ($cls,@esyms);
    goto &Exporter::import;
}

package Module::Stubber;
use strict;
use warnings;
our %Status;
our $VERSION = '0.03';

my $USAGE_ERR = sprintf("Usage: use %s ".
    "Pkg::Name => [ 'import', 'options' ], extra => 'options'",
    __PACKAGE__);

sub import {
    my ($cls,$wanted_pkg,$import_params,%options) = @_;
    my ($caller,$ifname,$ifline) = caller();
    if(!$wanted_pkg) {
        die $USAGE_ERR;
    }

    my $pkg_s = $wanted_pkg;
    $pkg_s =~ s,::,/,g;
    $pkg_s .= ".pm";

    @_ = ($wanted_pkg, @$import_params);
    if(eval { require $pkg_s }
       && !$wanted_pkg->isa('Module::Stubber::Stub') ) {
        $Status{$wanted_pkg} = 1;
        goto &{$wanted_pkg->can('import') || sub () { } };
    } else {
        warn(__PACKAGE__ . ": ".$@);
        $Status{$wanted_pkg} = 0;
        $INC{$pkg_s} = 1;
        no strict 'refs';
        @{$wanted_pkg . '::ISA'} = 'Module::Stubber::Stub';
        my $more_syms = $options{will_use};
        if(ref $more_syms eq 'ARRAY') {
            push @_, @$more_syms;
        } else {
            no strict 'refs';
            while (my ($sym,$symspec) = each %$more_syms) {
                if(ref $symspec eq 'CODE') {
                    *{$wanted_pkg."::$sym"} = $symspec;
                } else {
                    $Module::Stubber::Stub::Retvals{$wanted_pkg."::$sym"} = $symspec;
                }
                push @_, $sym;
            }
        }
        if($options{silent}) {
            $Module::Stubber::Stub::Warncache{$wanted_pkg} = 1;
        }

        goto &Module::Stubber::Stub::import;
    }
}

1;

__END__