File Coverage

lib/Badger/Class/Methods.pm

Criterion	Covered	Total	%
statement	77	77	100.0
branch	20	26	76.9
condition	12	17	70.5
subroutine	21	21	100.0
pod	10	10	100.0
total	140	151	92.7

#========================================================================
#
# Badger::Class::Methods
#
# DESCRIPTION
#   Class mixin module for adding methods to a class.
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Class::Methods;

use Carp;
use Badger::Class
    version   => 0.01,
    debug     => 0,
    base      => 'Badger::Base',
    import    => 'class BCLASS',
    constants => 'DELIMITER ARRAY HASH PKG CODE',
    utils     => 'is_object',
    exports   => {
        hooks => {
            init => \&initialiser,
            map { $_ => [\&generate, 1] }
            qw( accessors mutators get set slots hash auto_can )
        },
    },
    messages  => {
        no_target  => 'No target class specified to generate methods for',
        no_type    => 'No method type specified to generate',
        no_methods => 'No %s specified to generate',
        bad_method => 'Invalid %s method: %s',
        bad_type   => 'Invalid method generator specified: %s',
    };

# method aliases
*get = \&accessors;
*set = \&mutators;

our $AUTOLOAD;

sub generate {
    my $class   = shift;
    my $target  = shift
        || return $class->error_msg('no_target');
    my $type    = shift
        || return $class->error_msg('no_type');
    my $methods = shift
        || return $class->error_msg( no_methods => $type );
    my $code    = $class->can($type)
        || return $class->error_msg( bad_type => $type );

    $class->debug("generate($target, $type, $methods)") if DEBUG;

    $code->($class, $target, $methods);
}

sub accessors {
    my ($class, $target, $methods) = shift->args(@_);

    $target->import_symbol(
        $_ => $class->accessor($_)
    ) for @$methods;
}

sub accessor {
    my ($self, $name) = @_;
    return sub {
        $_[0]->{ $name };
    };
}

sub mutators {
    my ($class, $target, $methods) = shift->args(@_);

    $target->import_symbol(
        $_ => $class->mutator($_)
    ) for @$methods;
}

sub mutator {
    my ($self, $name) = @_;
    return sub {
        # You wouldn't ever want to write a real subroutine like this.
        # But that's OK, because we're here to do it for you.  You get
        # the efficiency without having to ever look at code like this:
        @_ == 2
            ? ($_[0]->{ $name } = $_[1])
            :  $_[0]->{ $name };
    };
}

sub hash {
    my ($class, $target, $methods) = shift->args(@_);

    foreach (@$methods) {
        my $name = $_;              # new lexical var for closure
        $target->import_symbol(
            $name => sub {
                # return hash ref when called without args
                return $_[0]->{ $name } if @_ == 1;

                # return hash item when called with one non-ref arg
                return $_[0]->{ $name }->{ $_[1] } if @_ == 2 && ! ref $_[1];

                # add items to hash when called with hash ref or multiple args
                my $self  = shift;
                my $items = @_ == 1 && ref $_[0] eq HASH ? shift : { @_ };
                my $hash  = $self->{ $name };
                @$hash{ keys %$items } = values %$items;
                return $hash;
            }
        );
    }
}

sub initialiser {
    my ($class, $target, $methods) = shift->args(@_);

    $target->import_symbol(
        init => sub {
            my ($self, $config) = @_;
            $self->{ config } = $config;
            foreach my $name (@$methods) {
                $self->$name($config);
            }
            return $self;
        }
    );
}

sub slots {
    my ($class, $target, $methods) = shift->args(@_);
    my $index = 0;

    foreach my $method (@$methods) {
        my $i = $index++;           # new lexical var for closure
        $target->import_symbol(
            $method => sub {
                return @_ > 1
                    ? ($_[0]->[$i] = $_[1])
                    :  $_[0]->[$i];
            }
        );
    }
}

sub auto_can {
    my ($class, $target, $methods) = shift->args(@_);

    die "auto_can only support a single method at this time\n"
        if @$methods != 1;

    my $method = shift @$methods;

    croak "Invalid auto_can method specified: $method\n"
        if ref $method eq CODE;

    # avoid runaways
    my $seen = { };

    $class->debug("installing AUTOLOAD and can() in $target") if DEBUG;

    $target->import_symbol(
        can => sub {
            my ($this, $name, @args) = @_;
            $class->debug("looking to see if $this can $name()") if DEBUG;

            # This avoids runaways where can() calls itself repeatedly, but
            # doesn't prevent can() from being called several times for the
            # same item.
            return if $seen->{ $name };
            local $seen->{ $name } = 1;

            return $this->SUPER::can($name)
                || $this->$method($name, @args);
        }
    );

    $target->import_symbol(
        AUTOLOAD => sub {
            my ($this, @args) = @_;
            my ($name) = ($AUTOLOAD =~ /([^:]+)$/ );
            return if $name eq 'DESTROY';
            if (my $method = $this->can($name, @args)) {
                my $that = class($this);
                $class->debug("$class installing $name method in $that") if DEBUG;
                $that->method( $name => $method );
                return $method->($this, @args);
            }

            # Hmmm... what if $this isn't a subclass of Badger::Base?
            return $this->error_msg( bad_method => $name, ref $this, (caller())[1,2] );
        }
    );

    $class->debug("installed AUTOLOAD and can() in $target") if DEBUG;
}

sub args {
    my $class   = shift;
    my $target  = shift;
    my $methods = @_ == 1 ? shift : [ @_ ];

    # update $target to a Badger::Class object if not already one
    $target  = class($target)
        unless is_object(BCLASS, $target);

    # split text string into list ref of method names
    $methods = [ split(DELIMITER, $methods) ]
        unless ref $methods eq ARRAY;

    return ($class, $target, $methods);
}



1;

__END__