File Coverage

blib/lib/Data/BISON/Base.pm

Criterion	Covered	Total	%
statement	47	80	58.7
branch	9	22	40.9
condition	2	6	33.3
subroutine	9	17	52.9
pod	0	1	0.0
total	67	126	53.1

package Data::BISON::Base;

use warnings;
use strict;
use Carp;
use base qw(Exporter);

our @ISA;

sub new {
    my $class = shift;
    my $self = bless {}, ref $class || $class;

    my $args = {};
    if ( @_ ) {
        $args = shift;
        croak "The only argument to new must be a hash reference of options"
          if @_ || ref $args ne 'HASH';
    }

    $self->_pre_init( $args );
    $self->__parse_args( $args );
    $self->_initialize( $args );

    if ( my @extra = sort keys %$args ) {
        croak "Illegal option(s): ", join( ', ', @extra );
    }

    return $self;
}

sub _pre_init    { }
sub __parse_args { }
sub _initialize  { }

# Generate methods
sub import {
    my $class  = shift;
    my $caller = caller;

    if ( my $attr_spec = shift ) {
        no strict 'refs';

        my %default = (

            # Capabilities i=init, s=set
            can => 'is',

            # Set the value of an attribute
            set => sub {
                my $self = shift;
                my $attr = shift;
                my $val  = shift;
                $self->{$attr} = $val;
            },

            # Get the value of an attribute
            get => sub {
                my $self = shift;
                my $attr = shift;
                return $self->{$attr};
            },

            # Return the default value for an attribute
            default => sub {
                my $self = shift;
                my $attr = shift;
                croak "Option $attr is required";
            },
        );

        while ( my ( $attr, $spec ) = each %$attr_spec ) {
            while ( my ( $handler, $def ) = each %default ) {
                $spec->{$handler} = $def unless exists $spec->{$handler};
            }

            # Turn keys that map to a value into a sub that returns
            # that value
            for my $handler ( qw( get default ) ) {
                unless ( ref $spec->{$handler} eq 'CODE' ) {
                    my $value = $spec->{$handler};
                    $spec->{$handler} = sub { return $value };
                }
            }

            # Getter / setter
            my $getter = $spec->{get};
            if ( $spec->{can} =~ /s/ ) {
                my $setter = $spec->{set};
                *{ $caller . '::' . $attr } = sub {
                    my $self = shift;
                    return $getter->( $self, $attr ) unless @_;
                    return $setter->( $self, $attr, @_ );
                };
            }
            else {
                *{ $caller . '::' . $attr } = sub {
                    my $self = shift;
                    return $getter->( $self, $attr ) unless @_;
                    croak "Attribute $attr is read-only";
                };
            }
        }

        *{ $caller . '::__parse_args' } = sub {
            my $self = shift;
            my $args = shift;

            {
                local @ISA = @{ $caller . '::ISA' };
                $self->SUPER::__parse_args( $args );
            }

            while ( my ( $attr, $spec ) = each %$attr_spec ) {
                my @value;
                if ( exists $args->{$attr} ) {
                    croak "Argument $attr can not be set during initialisation"
                      unless $spec->{can} =~ /i/;
                    @value = delete $args->{$attr};
                }
                else {
                    @value = $spec->{default}->( $self, $attr );
                }
                $spec->{set}->( $self, $attr, @value );
            }
        };
    }
}

1;
__END__