File Coverage

blib/lib/Meta/Builder/Base.pm

Criterion	Covered	Total	%
statement	141	143	98.6
branch	28	44	63.6
condition	4	12	33.3
subroutine	34	34	100.0
pod	22	25	88.0
total	229	258	88.7

package Meta::Builder::Base;
use strict;
use warnings;

use Meta::Builder::Util;
use Carp qw/croak carp/;

sub new {
    my $class = shift;
    my ( $package, %metrics ) = @_;
    my $meta = $class->meta_meta;
    my $self = bless( [ $package ], $class );

    for my $metric ( keys %{ $meta->{metrics} }) {
        my $idx = $meta->{metrics}->{$metric};
        $self->[$idx] = $metrics{$metric}
                     || $meta->{generators}->[$idx]->();
    }

    inject(
        $package,
        ($meta->{accessor} || croak "$class does not have an accessor set."),
        sub { $self }
    );

    $self->init( %metrics ) if $self->can( 'init' );

    return $self;
}

sub meta_meta {
    my $class = shift;
    return $class->_meta_meta
        if $class->can( '_meta_meta' );

    my $meta = { index => 1 };
    inject( $class, "_meta_meta", sub { $meta });
    return $meta;
}

sub package { shift->[0] }

sub set_accessor {
    my $class = shift;
    ($class->meta_meta->{accessor}) = @_;
}

sub add_hash_metric {
    my $class = shift;
    my ( $metric, %actions ) = @_;
    $class->add_metric(
        $metric,
        \&gen_hash,
        add   => \&default_hash_add,
        get   => \&default_hash_get,
        has   => \&default_hash_has,
        clear => \&default_hash_clear,
        pull  => \&default_hash_pull,
        merge => \&default_hash_merge,
        %actions,
    );
}

sub add_lists_metric {
    my $class = shift;
    my ( $metric, %actions ) = @_;
    $class->add_metric(
        $metric,
        \&gen_hash,
        push  => \&default_list_push,
        get   => \&default_list_get,
        has   => \&default_list_has,
        clear => \&default_list_clear,
        pull  => \&default_list_pull,
        merge => \&default_list_merge,
        %actions,
    );
}

sub add_metric {
    my $class = shift;
    my ( $metric, $generator, %actions ) = @_;
    my $meta = $class->meta_meta;
    my $index = $meta->{index}++;

    croak "Already tracking metric '$metric'"
        if $meta->{metrics}->{$metric};

    $meta->{metrics}->{$metric} = $index;
    $meta->{generators}->[$index] = $generator;
    $meta->{indexes}->{$index} = $metric;

    inject( $class, $metric, sub { shift->[$index] });
    $class->add_action( $metric, %actions );
}

sub add_action {
    my $class = shift;
    my ( $metric, %actions ) = @_;
    $class->_add_action( $metric, $_, $actions{ $_ })
        for keys %actions;
}

sub _add_action {
    my $class = shift;
    my ( $metric, $action, $code ) = @_;
    croak "You must specify a metric, an action name, and a coderef"
        unless $metric && $action && $code;

    my $meta = $class->meta_meta;
    my $name = $class->action_method_name( $metric, $action );

    inject( $class, $name, sub {
        my $self = shift;
        my $args = \@_;
        $_->( $self, $self->$metric, $metric, $action, @$args )
            for @{ $meta->{before}->{$name} || [] };
        my @out = $code->( $self, $self->$metric, $metric, $action, @$args );
        $_->( $self, $self->$metric, $metric, $action, @$args )
            for @{ $meta->{after}->{$name} || [] };
        return @out ? (@out > 1 ? @out : $out[0]) : ();
    });
}

sub action_method_name {
    my $class = shift;
    my ( $metric, $action ) = @_;
    return "$metric\_$action";
}

sub hook_before {
    my $class = shift;
    my ( $metric, $action, $code ) = @_;
    my $name = $class->action_method_name( $metric, $action );
    push @{ $class->meta_meta->{before}->{$name} } => $code;
}

sub hook_after {
    my $class = shift;
    my ( $metric, $action, $code ) = @_;
    my $name = $class->action_method_name( $metric, $action );
    push @{ $class->meta_meta->{after}->{$name} } => $code;
}

sub gen_hash { {} }

sub default_hash_add {
    my $self = shift;
    my ( $data, $metric, $action, $item, @value ) = @_;
    my $name = $self->action_method_name( $metric, $action );
    croak "$name() called without anything to add"
        unless $item;

    croak "$name('$item') called without a value to add"
        unless @value;

    croak "'$item' already added for metric $metric"
        if $data->{$item};

    ($data->{$item}) = @value;
}

sub default_hash_get {
    my $self = shift;
    my ( $data, $metric, $action, $item ) = @_;
    my $name = $self->action_method_name( $metric, $action );
    croak "$name() called without anything to get"
        unless $item;

    # Prevent autovivication
    return exists $data->{$item}
        ? $data->{$item}
        : undef;
}

sub default_hash_has {
    my $self = shift;
    my ( $data, $metric, $action, $item ) = @_;
    my $name = $self->action_method_name( $metric, $action );
    croak "$name() called without anything to find"
        unless $item;
    return exists $data->{$item} ? 1 : 0;
}

sub default_hash_clear {
    my $self = shift;
    my ( $data, $metric, $action, $item ) = @_;
    my $name = $self->action_method_name( $metric, $action );
    croak "$name() called without anything to clear"
        unless $item;
    delete $data->{$item};
    return 1;
}

sub default_hash_pull {
    my $self = shift;
    my ( $data, $metric, $action, $item ) = @_;
    my $name = $self->action_method_name( $metric, $action );
    croak "$name() called without anything to pull"
        unless $item;
    return delete $data->{$item};
}

sub default_hash_merge {
    my $self = shift;
    my ( $data, $metric, $action, $merge ) = @_;
    for my $key ( keys %$merge ) {
        croak "$key is defined for $metric in both meta-objects"
            if $data->{$key};
        $data->{$key} = $merge->{$key};
    }
}

sub default_list_push {
    my $self = shift;
    my ( $data, $metric, $action, $item, @values ) = @_;
    my $name = $self->action_method_name( $metric, $action );
    croak "$name() called without an item to which data should be pushed"
        unless $item;

    croak "$name('$item') called without values to push"
        unless @values;

    push @{$data->{$item}} => @values;
}

sub default_list_get {
    my $data = default_hash_get(@_);
    return $data ? @$data : ();
}

sub default_list_has {
    default_hash_has( @_ );
}

sub default_list_clear {
    default_hash_clear( @_ );
}

sub default_list_pull {
    my @out = default_list_get( @_ );
    default_list_clear( @_ );
    return @out;
}

sub default_list_merge {
    my $self = shift;
    my ( $data, $metric, $action, $merge ) = @_;
    for my $key ( keys %$merge ) {
        push @{ $data->{$key} } => @{ $merge->{$key} };
    }
}

sub merge {
    my $self = shift;
    my ( $merge ) = @_;
    for my $metric ( keys %{ $self->meta_meta->{ metrics }}) {
        my $mergesub = $self->action_method_name( $metric, 'merge' );
        unless( $self->can( $mergesub )) {
            carp "Cannot merge metric '$metric', define a 'merge' action for it.";
            next;
        }
        $self->$mergesub( $merge->$metric );
    }
}

1;

__END__