File Coverage

blib/lib/Class/LazyLoad.pm

Criterion	Covered	Total	%
statement	99	99	100.0
branch	34	34	100.0
condition	3	3	100.0
subroutine	22	22	100.0
pod	6	6	100.0
total	164	164	100.0

package Class::LazyLoad;

use strict 'vars';

use vars qw(
    $AUTOLOAD
    $VERSION
);

$VERSION = 0.04;

{
    my @todo;
    sub import
    {
        shift;
        return if (caller)[0] eq 'Class::LazyLoad::Functions';

        unless ( @_ ) {
            push @todo, [ (caller)[0], 'new' ];
            return;
        }

        foreach ( @_ ) {
            if (ref($_) eq 'ARRAY') {
                push @todo, $_;
            } else {
                push @todo, [ $_, 'new' ];
            }
        }
    }

    sub init_lazyloads { lazyload( @$_ ) for @todo }
    INIT { init_lazyloads() }
}

use overload
    '${}' => sub { _build($_[0]); $_[0] },
    '%{}' => sub { _build($_[0]); $_[0] },
    '&{}' => sub { _build($_[0]); $_[0] },
    '@{}' => sub {
        # C::LL does array access, so make sure it's not us before building.
        return $_[0] if (caller)[0] eq __PACKAGE__;
        _build($_[0]); $_[0]
    },
    nomethod => sub {
        my $realclass = $_[0][1];
        if ($_[3] eq '""') {
            if (my $func = overload::Method($realclass, $_[3])) {
                _build($_[0]);
                return $_[0]->$func();
            }
            else {
                return overload::StrVal($_[0]);
            }
        }
        die "LazyLoaded object '$realclass' is not overloaded, cannot perform '$_[3]'\n"
            unless overload::Overloaded($realclass);
        my $func = overload::Method($realclass, $_[3]);
        die "LazyLoaded object '$realclass' does not overloaded '$_[3]'\n"
            unless defined $func;
        _build($_[0]);
        $_[0]->$func($_[1], $_[2]);
    };

sub can
{
    _build( $_[0] );
    $_[0]->can($_[1]);
}

sub isa { $_[0][1]->isa($_[1]) }

sub AUTOLOAD
{
    my ($subname) = $AUTOLOAD =~ /([^:]+)$/;

    my $realclass = $_[0][1];
    _build( $_[0] );

    my $func = $_[0]->can( $subname );
    die "Cannot call '$subname' on an instance of '$realclass'\n"
        unless ref( $func ) eq 'CODE';

    goto &$func;
}

sub _compile
{
    my $pkg = shift;
    (my $filename = $pkg) =~ s!::!/!g;
#    print "$pkg => " . $INC{"$filename.pm"} . "\n";
    return if exists $INC{"$filename.pm"};

    eval "use $pkg;";
    die "Could not load '$pkg' because : $@" if $@;
}

{
    my %lazyloads;

    sub lazyload
    {
        my $pkg = shift;

        _compile( $pkg );

        my @functions = @_;
        @functions = qw( new ) unless @functions;

        foreach my $name (@functions)
        {
            my $subname = __PACKAGE__ . '::' . $pkg . '::' . $name;

            # Don't override a function we've already overridden;
            next if defined &{$subname};

            my $func = \&{ $pkg . '::' . $name };
            *$subname = sub { unshift @_, $func; bless \@_, __PACKAGE__ };

            local $^W = 0;
            *{ $pkg . '::' . $name }  = \&$subname;

            $lazyloads{ $pkg }{ $name } = $func;
        }

        return ~~1;
    }

    sub unlazyload
    {
        my $pkg = shift;

        foreach my $name ( keys %{ $lazyloads{ $pkg } } )
        {
            my $subname = __PACKAGE__ . '::' . $pkg . '::' . $name;

            local $^W = 0;
            *{ $pkg . '::' . $name } = delete $lazyloads{ $pkg }{ $name };
        }

        delete $lazyloads{ $pkg };

        return ~~1;
    }

    sub _build
    {
        my @x = @{$_[0]};

        my $func = shift @x;
        $_[0] = $func->(@x);

        die "INTERNAL ERROR: Cannot build instance of '$x[0]'\n"
            unless defined $_[0];

        # This can occur if the class wasn't loaded correctly.
        die "INTERNAL ERROR: _build() failed to build a new object\n"
            if ref($_[0]) eq __PACKAGE__;

        return ~~1;
    }

    sub lazyload_one
    {
        my ($pkg, $name, @args) = @_;

        die "Must pass in (CLASS, [ CONSTRUCTOR, [ARGS] ]) to lazyload_one().\n"
            unless defined $pkg;

        $name = 'new' unless defined $name && length $name;

        _compile( $pkg );

        my $func = \&{ $pkg . '::' . $name };
        bless [ $func, $pkg, @args ];
    }
}

sub DESTROY{ undef }

1;
__END__