File Coverage

blib/lib/Sub/Stubber.pm

Criterion	Covered	Total	%
statement	90	98	91.8
branch	27	40	67.5
condition	6	9	66.6
subroutine	17	17	100.0
pod	3	4	75.0
total	143	168	85.1

package Sub::Stubber::Stubs;
use strict;
use warnings;
use Class::Struct;

struct __PACKAGE__,
    ['names' => '%',
     'import_triggers' => '@',
     'env_triggers'     => '@',
     'triggered'        => '$',
     'imported_into'    => '@',
     ];

sub add_trigger {
    my ($self,$type,$name) = @_;
    if($type eq 'env') {
        push @{$self->env_triggers}, $name;
    } elsif ($type eq 'import') {
        push @{$self->import_triggers}, $name;
    } else {
        die("No such trigger type '$type'");
    }
}

sub add_specs {
    my ($self,@specs) = @_;
    foreach my $spec (@specs) {
        if(!ref $spec) {
            $self->names->{$spec} = undef;
        } elsif (ref $spec eq 'HASH') {
            while ( my ($name,$val) = each %$spec ) {
                $self->names->{$name} = $val;
            }
        } else {
            die ("Bad specifier '$spec'");
        }
    }
}

package Sub::Stubber;
use strict;


no strict 'refs';
no warnings 'redefine';

our %PkgCache;
our $VERSION = 0.04;


sub get_object {
    my $cls = shift;
    my $cpkg = $cls eq __PACKAGE__ ? caller : $cls;

    return $PkgCache{$cpkg} ||= Sub::Stubber::Stubs->new(triggered => 0);
}


sub _mk_sub_real {
    my ($cpkg,$subname,$value) = @_;
    if($subname !~ /::/) {
        $subname = $cpkg . '::' . $subname;
    }

    my $old_proto = prototype $subname;

    #Hope the prototype is right!
    if(defined $value && ref $value eq 'CODE') {
        *{$subname} = $value;
    }
    elsif(defined $old_proto) {
        eval "*$subname = sub ($old_proto) { \$value };";
    }
    else {
        *{$subname} = sub { $value };
    }
}

#The next two provide some sugary API at the expense of a bleh-like
#implementation. the functions are too simple to warrant an
#elaborate dispatch scheme, unfortunately

sub regstubs {
    my $cls = shift;
    my $cpkg = $cls eq __PACKAGE__ ? caller : $cls;
    get_object($cpkg)->add_specs(@_);
}

sub add_trigger {
    my $cls = shift;
    my $cpkg = $cls eq __PACKAGE__ ? caller : $cls;
    get_object($cpkg)->add_trigger(@_);
}

sub mkstubs {

    my $cls = shift;
    my $cpkg = $cls eq __PACKAGE__ ? caller : $cls;
    if(!exists $PkgCache{$cpkg} && @_ == 0) {
        die("No functions registered and non provided to mkstubs()");
    }
    my $obj = $PkgCache{$cpkg};
    return if $obj->triggered();

    $obj->add_specs(@_);
    while (my ($subname,$subval) = each %{$obj->names}) {
        _mk_sub_real($cpkg,$subname,$subval);
    }

    $obj->triggered(1);
}

sub _import_as_base {
    my ($cls,@options) = @_;

    my $user_pkg = caller();

    my $obj = $PkgCache{$cls};

    if(!$obj) {
        warn("$cls has inherited from " . __PACKAGE__ . " but has not defined " .
             "any functions for stubbing");
        print Dumper(\%PkgCache);
        goto GT_EXPORTER;
    }

    if($obj->triggered) {
        #No need to re-generate stubs
        goto GT_EXPORTER;
    }

    foreach my $env (@{$obj->env_triggers}) {
        if($ENV{$env}) {
            mkstubs($cls);
            goto GT_EXPORTER;
        }
    }

    my $found_import_trigger = 0;
    foreach my $import (@{$obj->import_triggers}) {
        my $i = 1;
        while ($i <= $#_) {
            if($_[$i] eq $import) {
                $found_import_trigger = 1;
                splice(@_, $i, 1);
            }
            $i++;
        }
    }

    if($found_import_trigger) {
        mkstubs($cls);
    }


    GT_EXPORTER:
    push @{$obj->imported_into}, $user_pkg;

    if($cls->isa('Exporter')) {
        goto &Exporter::import;
    }
    1;
}

sub import {
    my ($cls,@options) = @_;

    if($cls ne __PACKAGE__) {
        goto &_import_as_base;
    }
    1;
}
1;

__END__