File Coverage

blib/lib/Class/Accessor/WithDefault.pm

Criterion	Covered	Total	%
statement	69	75	92.0
branch	19	30	63.3
condition	10	21	47.6
subroutine	11	11	100.0
pod	2	6	33.3
total	111	143	77.6

package Class::Accessor::WithDefault;
use base qw/Class::Accessor/;
use 5.006;

our $VERSION = '0.23';

sub mk_accessors {
    my $self = shift;
    my @fields;
    foreach (@_) {
        if ( ref $_ eq 'HASH' ) {
            $self->mk_default( %{$_} );
        }
        else {
            push @fields, $_;
        }
    }
    $self->SUPER::mk_accessors(@fields);
}

sub mk_ro_accessors {
    my $self = shift;
    my @fields;
    foreach (@_) {
        if ( ref $_ eq 'HASH' ) {
            $self->mk_ro_default( %{$_} );
        }
        else {
            push @fields, $_;
        }
    }
    $self->SUPER::mk_ro_accessors(@fields);
}

sub mk_default {
    my ( $self, %args ) = @_;
    $self->_make_default( "rw", %args );
}

sub mk_ro_default {
    my ( $self, %args ) = @_;
    $self->_make_default( 'ro', %args );
}

## make accessors and set the default value
## mostly copied from Class::Accessor::_mk_accessors
sub _make_default {
    my ( $self, $access, %args ) = @_;
    my $class = ref $self || $self;
    my $ra = $access eq 'rw' || $access eq 'ro';
    my $wa = $access eq 'rw' || $access eq 'wo';

    while ( my ( $field, $value ) = each %args ) {
        my $accessor_name = $self->accessor_name_for($field);
        my $mutator_name  = $self->mutator_name_for($field);
        if ( $accessor_name eq 'DESTROY' or $mutator_name eq 'DESTROY' ) {
            $self->_carp(
                "Having a data accessor named DESTROY  in '$class' is unwise.");
        }

        if ( $accessor_name eq $mutator_name ) {
            my $accessor;
            if ( $ra && $wa ) {
                $accessor = $self->make_default( $field, $value );
            }
            elsif ($ra) {
                $accessor = $self->make_ro_default( $field, $value );
            }
            my $fullname = "${class}::$accessor_name";
            my $subnamed = 0;
            subname( $fullname, $accessor ) if defined &subname;
            $subnamed = 1;
            *{$fullname} = $accessor;
        }
        else {
            my $fullaccname = "${class}::$accessor_name";
            my $fullmutname = "${class}::$mutator_name";
            if ( $ra and not defined &{$fullaccname} ) {
                my $accessor = $self->make_ro_default( $field, $value );
                subname( $fullaccname, $accessor ) if defined &subname;
                *{$fullaccname} = $accessor;
            }
            if ( $wa and not defined &{$fullmutname} ) {
                my $mutator = $self->make_wo_accessor($field);
                subname( $fullmutname, $mutator ) if defined &subname;
                *{$fullmutname} = $mutator;
            }
        }
    }
}

sub make_default {
    my ( $class, $field, $value ) = @_;
    return sub {
        my $self = shift;

        if (@_) {
            return $self->set( $field, @_ );
        }
        elsif ( ! defined $self->get($field) ) {
            return $self->set( $field, $value );
        }
        else {
            return $self->get($field);
        }
    };

}

sub make_ro_default {
    my ( $class, $field, $value ) = @_;
    return sub {
        my $self = shift;
        if (@_) {
            my $caller = caller;
            $self->_croak(
"'$caller' cannot alter the value of '$field' on objects of class '$class'"
            );
        }
        elsif ( ! defined $self->get($field) ) {
            return $self->set( $field, $value );
        }
        else {
            return $self->get($field);
        }
      }
}

1;
__END__