File Coverage

blib/lib/Class/Accessor/Assert.pm

Criterion	Covered	Total	%
statement	57	87	65.5
branch	19	44	43.1
condition	16	30	53.3
subroutine	10	15	66.6
pod	3	4	75.0
total	105	180	58.3

package Class::Accessor::Assert;
use 5.006;
use strict;
use warnings;
use base qw(Class::Accessor Class::Data::Inheritable);
use Carp qw(croak confess);
our $VERSION = '1.41';

sub _mk_accessors {
    my ( $self, $maker, @fields ) = @_;
    $self->mk_classdata("accessor_specs")
      unless $self->can("accessor_specs");

    my %spec = $self->parse_fields(@fields);
    $self->accessor_specs( { %spec, %{ $self->accessor_specs || {} } } );

    $self->SUPER::_mk_accessors( 'rw', keys %spec );

    {
        no strict 'refs';

        # additional methods for magic array methods
        my $class = ref $self || $self;
	# Note how we curry the subs with the lexical "$field":
	# The subs are closures and therefore have access to their lexical
	# scope. Clarity suffers from this, but the performance should be
	# about 25% higher than a cleaner approach due to a saved subroutine
	# call for every ary_*(...) call.
        for my $field ( grep { $spec{$_}{array} } keys %spec ) {
	    # foo_push sub
            *{"${class}::${field}_push"} = sub {
                my ( $self, @values ) = @_;
                $self->{$field} = [] unless defined $self->{$field};
                push @{ $self->{$field} }, @values;
            };
	    # foo_pop sub
            *{"${class}::${field}_pop"} = sub {
                my ( $self ) = @_;
                return pop @{ $self->{$field} || [] };
            };
	    # foo_unshift sub
            *{"${class}::${field}_unshift"} = sub {
                my ( $self, @values ) = @_;
                $self->{$field} = [] unless defined $self->{$field};
                unshift @{ $self->{$field} }, @values;
            };
	    # foo_shift sub
            *{"${class}::${field}_shift"} = sub {
                my ( $self ) = @_;
                return shift @{ $self->{$field} || [] };
            };
        }
    }
}

sub new {
    my ( $self, $stuff ) = @_;
    my $not_a_void_context = eval { %{ $stuff || {} } };
    croak "$stuff doesn't look much like a hash to me" if $@;
    if ( $self->can("accessor_specs") ) {
        my $spec = $self->accessor_specs;
        for my $k ( keys %$spec ) {
            confess "Required member $k not given to constructor"
              if $spec->{$k}->{required}
              and not exists $stuff->{$k};
            confess "Member $k needs to be of type " . $spec->{$k}->{class}
              if exists $spec->{$k}->{class}
              and exists $stuff->{$k}
              and !UNIVERSAL::isa( $stuff->{$k}, $spec->{$k}->{class} );
        }
    }
    return $self->SUPER::new($stuff);
}

sub set {
    return shift->SUPER::set(@_) unless $_[0]->can("accessor_specs");
    my ( $self, $key ) = splice( @_, 0, 2 );
    my $spec = $self->accessor_specs;
    return $self->SUPER::set( $key, @_ )
      if !exists $spec->{$key}
      or @_ > 1;    # No support for arrays
    confess "Member $key needs to be of type " . $spec->{$key}->{class}
      if defined $_[0]
      and exists $spec->{$key}->{class}
      and !UNIVERSAL::isa( $_[0], $spec->{$key}->{class} );

    $_[0] = [ $_[0] ]
      if defined $_[0]
      and $spec->{$key}->{array}
      and ref $_[0] ne 'ARRAY';

    $self->{$key} = $_[0];
}

sub get {
    return shift->SUPER::get(@_) unless $_[0]->can("accessor_specs");
    my ( $self, $key ) = splice( @_, 0, 2 );
    my $spec = $self->accessor_specs;
    return $self->SUPER::get( $key, @_ )
      if !exists $spec->{$key}
      or @_ > 1;    # No support for arrays
    if ( $spec->{$key}{array} ) {
        wantarray
          ? @{ $self->SUPER::get( $key, @_ ) || [] }
          : $self->SUPER::get( $key, @_ );
    }
    else {
        $self->SUPER::get( $key, @_ );
    }
}

sub parse_fields {
    my ( $self, @fields ) = @_;
    my %spec;
    for my $f (@fields) {
        my $orig_f = $f;    # For error reporting
        my %subspec;

        # All the tests go here
        $subspec{required} = $f =~ s/^\+//;
        $f =~ s/=(.*)// and $subspec{class} = $1;
        $subspec{array} = $f =~ s/^\@//;
        $f =~ /^\w+$/
          or croak "Couldn't understand field specification $orig_f";
        $spec{$f} = \%subspec;
    }
    return %spec;
}

1;
__END__