File Coverage

blib/lib/Astro/App/Satpass2/Copier.pm

Criterion	Covered	Total	%
statement	52	66	78.7
branch	15	20	75.0
condition	5	18	27.7
subroutine	14	18	77.7
pod	10	10	100.0
total	96	132	72.7

package Astro::App::Satpass2::Copier;

use strict;
use warnings;

use Clone ();

use Astro::App::Satpass2::Utils qw{ @CARP_NOT };
use Astro::App::Satpass2::Warner;
use Scalar::Util 1.26 qw{ blessed };

our $VERSION = '0.051';

sub attribute_names {
    return ( qw{ warner } );
}

sub class_name_of_record {
    my ( $self ) = @_;
    return ref $self || $self;
}

sub clone {
    my ( $self ) = @_;
    return Clone::clone( $self );
}

sub copy {
    my ( $self, $copy, %skip ) = @_;
    foreach my $attr ( $self->attribute_names() ) {
	not exists $skip{$attr}
	    and $copy->can( $attr )
	    and $copy->$attr( $self->$attr() );
    }
    return $self;
}

sub create_attribute_methods {
    my ( $self ) = @_;
    my $class = ref $self || $self;
    foreach my $attr ( $self->attribute_names() ) {
	$class->can( $attr ) and next;
	my $method = $class . '::' . $attr;
	no strict qw{ refs };
	*$method = sub {
	    my ( $self, @args ) = @_;
	    if ( @args ) {
		$self->{$attr} = $args[0];
		return $self;
	    } else {
		return $self->{$attr};
	    }
	};
    }
    return;
}

sub init {
    my ( $self, %arg ) = @_;
    exists $arg{warner}
	and $self->warner( delete $arg{warner} );
    foreach my $name ( $self->attribute_names() ) {
	exists $arg{$name}
	    and $self->$name( delete $arg{$name} );
    }
    if ( %arg ) {
	my @extra = sort keys %arg;
	$self->wail(
	    join ' ', 'Unknown attribute name(s):', @extra
	);
    }
    return $self;
}

sub wail {
    my ( $self, @args ) = @_;
    return $self->warner()->wail( @args );
}

sub warner {
    my ( $self, @args ) = @_;
    if ( @args ) {
	my $val = shift @args;
	if ( ! defined $val ) {
	    $val = Astro::App::Satpass2::Warner->new();
	} elsif ( ! ref $val && $val->isa(
		'Astro::App::Satpass2::Warner' ) ) {
	    $val = Astro::App::Satpass2::Warner->new();
	} elsif ( ! ( blessed( $val ) &&
		$val->isa('Astro::App::Satpass2::Warner' ) ) ) {
	    $self->wail(
		'Warner must be undef or an Astro::App::Satpass2::Warner'
	    );
	}
	$self->{warner} = $val;
	return $self;
    } else {
	return $self->{warner} ||= Astro::App::Satpass2::Warner->new();
    }
}

sub weep {
    my ( $self, @args ) = @_;
    return $self->warner()->weep( @args );
}

sub whinge {
    my ( $self, @args ) = @_;
    return $self->warner()->whinge( @args );
}

1;

__END__