File Coverage

blib/lib/Autocache.pm

Criterion	Covered	Total	%
statement	122	139	87.7
branch	22	30	73.3
condition	1	2	50.0
subroutine	26	29	89.6
pod	0	13	0.0
total	171	213	80.2

package Autocache;

use strict;
use warnings;

our $VERSION = '0.003_003';
$VERSION = eval $VERSION;

use Autocache::Config;
use Autocache::Request;
use Autocache::Strategy::Store::Memory;
use Autocache::WorkQueue;
use Autocache::Logger qw(get_logger);
use Carp;

require Exporter;

our @ISA = qw( Exporter );
our @EXPORT = qw( autocache );

my $SINGLETON;

sub autocache
{
    my ($name,$args) = @_;
    get_logger()->debug( "autocache $name" );
    my $package = caller;
    __PACKAGE__->singleton->_cache_function( $package, $name, $args );
}

sub singleton
{
    my $class = shift;
    __PACKAGE__->initialise()
        unless $SINGLETON;
    return $SINGLETON;
}

sub initialise
{
    my $class = shift;
    $SINGLETON = $class->new( @_ );
    $SINGLETON->configure;
    my %args = @_;
    Autocache::Logger->initialise(logger => $args{logger})
        if $args{logger};
}

sub new
{
    my ($class,%args) = @_;
    my $config = Autocache::Config->new( $args{filename} );
    my $self =
        {
            config => $config,
            strategy => {},
            default_strategy => undef,
            work_queue => undef,
        };
    bless $self, $class;
    return $self;
}

sub configure
{
    my ($self) = @_;

    foreach my $node ( $self->{config}->get_node( 'strategy' )->children )
    {
        my $name = $node->name;
        my $package = $node->value;
        _use_package( $package );

        my $strategy;

        eval
        {
            $strategy = $package->new( $node );
        };
        if( $@ )
        {
            confess "cannot create strategy $name using package $package - $@";
        }
        $self->{strategy}{$node->name} = $strategy;
    }

    $self->configure_functions( $self->{config}->get_node( 'fn' ) );

    if( $self->{config}->node_exists( 'default_strategy' ) )
    {
        $self->{default_strategy} = $self->get_strategy(
            $self->{config}->get_node( 'default_strategy' )->value );
    }
}

sub configure_functions
{
    my ($self,$node,$namespace) = @_;

    $namespace ||= '';

    if( $node->value )
    {
        get_logger()->debug( "fn: $namespace -> " . $node->value );

        $self->{fn}{$namespace}{strategy} = $node->value;
    }

    foreach my $child ( $node->children )
    {
        $self->configure_functions( $child, $namespace . '::' . $child->name );
    }
}

sub cache_function
{
    my ($self,$name,$args) = @_;
    get_logger()->debug( "cache_function '$name'" );
    my $package = caller;
    $self->_cache_function( $package, $name, $args );
}

sub _cache_function
{
    my ($self,$package,$name,$args) = @_;

    get_logger()->debug( "_cache_function '$name'" );

    # r : cache routine name
    my $r = '::' . $package . '::' . $name;

    # n : cache routine normaliser name
    my $n = '::' . $package . '::_normalise_' . $name;

    # g : generator routine name
    my $g = __PACKAGE__ . '::G' . $r;

    get_logger()->debug( "cache : $r / $g"  );

    no strict 'refs';

    # get generator routine ref
    my $gsub = *{$r}{CODE};

    # see if we have a normaliser
    my $gsub_norm = *{$n}{CODE};

    unless( defined $gsub_norm )
    {
        get_logger()->debug( "no normaliser, using default" );
        $gsub_norm = $self->get_default_normaliser();
    }

    my $rsub = $self->_generate_cached_fn( $r, $gsub_norm, $gsub );

    {
        # avoid "subroutine redefined" warning
        no warnings;
        # setup cached routine for caller
        *{$r} = $rsub;
    }
    1;
}

sub run_work_queue
{
    my($self) = @_;
    get_logger()->debug( "run_work_queue" );
    $self->get_work_queue()->execute();
}

sub get_work_queue
{
    my ($self) = @_;
    get_logger()->debug( "get_work_queue" );
    unless( $self->{work_queue} )
    {
        $self->{work_queue} = Autocache::WorkQueue->new();
    }
    return $self->{work_queue};
}

sub get_strategy_for_fn
{
    my ($self,$name) = @_;
    get_logger()->debug( "get_strategy_for_fn '$name'" );

    return $self->get_default_strategy()
        unless exists $self->{fn}{$name}{strategy};

    return $self->get_strategy( $self->{fn}{$name}{strategy} );
}

sub get_strategy
{
    my ($self,$name) = @_;
    get_logger()->debug( "get_strategy '$name'" );
    confess "cannot find strategy $name"
        unless $self->{strategy}{$name};
    return $self->{strategy}{$name};
}

sub get_default_strategy
{
    my ($self) = @_;
    get_logger()->debug( "get_default_strategy" );
    unless( $self->{default_strategy} )
    {
        $self->{default_strategy} = Autocache::Strategy::Store::Memory->new;
    }
    return $self->{default_strategy};
}

sub get_default_normaliser
{
    my ($self) = @_;
    get_logger()->debug( "get_default_normaliser" );
    return \&_default_normaliser;
}

sub _generate_cached_fn
{
    my ($self,$name,$normaliser,$coderef) = @_;
    get_logger()->debug( "_generate_cached_fn $name" );

    return sub
    {
        get_logger()->debug( "CACHE $name" );
        return unless defined wantarray;
        my $context = wantarray ? 'L' : 'S';

        get_logger()->debug( "calling context: $context" );

        my $request = Autocache::Request->new(
            name => $name,
            normaliser => $normaliser,
            generator => $coderef,
            args => \@_,
            context => $context,
        );

        my $strategy = $self->get_strategy_for_fn( $name );

        my $rec = $strategy->get( $request );

        unless( $rec )
        {
            $rec = $strategy->create( $request );
            $strategy->set( $request, $rec );
        }

        my $value = $rec->value;

        return wantarray ? @$value : $value;
    };
}

sub _default_normaliser
{
    get_logger()->debug( "_default_normaliser" );
    return join ':', @_;
}

sub _use_package
{
    my ($name) = @_;
    get_logger()->debug( "use $name" );
    eval "use $name";
    if( $@ )
    {
        confess $@;
    }
}

1;

__END__