File Coverage

blib/lib/Class/AccessorMaker.pm

Criterion	Covered	Total	%
statement	55	58	94.8
branch	18	24	75.0
condition	7	14	50.0
subroutine	7	7	100.0
pod			n/a
total	87	103	84.4

package Class::AccessorMaker;

##
## Class::AccessorMaker by Hartog "Sinister" de Mik
##

use strict;
no strict 'refs';

our $VERSION = "1.11";

use Carp;

sub import {
  my ($class, $subs, $xtra) = @_;
  my $pkg = ref(caller) || caller;
  $xtra ||="";

  croak "Can't make methods out of an empty hash-ref\n" if !defined $subs;

  ## define a constructor
  if ( $xtra ne "no_new" ) {
    # we have a green light for 'new()' creation
    if ( $xtra ne "new_init" ) {
      *{"${pkg}::new"} = sub {
	my $class = ref($_[0]) || $_[0]; shift;
	my $self = bless({}, $class);

	while ( @_ ) {
	  my ($sub, $value) = (shift, shift);
	  $self->$sub($value);
	}

	return $self;
      };
    } elsif ( $xtra eq "new_init" ) {
      *{"${pkg}::new"} = sub {
	my $class = ref($_[0]) || $_[0]; shift;
	my $self = bless({}, $class);

	while ( @_ ) {
	  my ($sub, $value) = (shift, shift);
	  $self->$sub($value);
	}

	$self->init();
	return $self;
      };
    }
  }


  foreach my $sub ( keys %$subs ) {
    ## construct the method if it is not defined yet.
    next if ( defined &{"${pkg}::$sub"} );

    *{"${pkg}::$sub"} = sub {
      my ( $self, $value ) = @_;

      # fill with default at first run
      if ( !exists $self->{$sub} ) {
	my $val = $subs->{$sub};
	my $rval = ref($val);
	if (!$rval) {
	  #scalar
	  $self->{$sub} = $val;
	} elsif ($rval =~ /ARRAY/) {
	  my @val = @{$val};
	  $self->{$sub} = \@val;
	} elsif($rval =~ /HASH/) {
	  my %val = %{$val};
	  $self->{$sub} = \%val;
	} else {
	  #object ref.. use at own risk.
	  $self->{$sub} = $val;
	}
      }

      # more then just self, something has to be set.
      if ($#_ > 0) {
	warn "The value supplied to '$sub()' is not of propper type"
	  if (ref($subs->{$sub}) and !ref($value));

	# set the value and return the object.
	$self->{$sub} = $value;
	return $self;
      }

      # return the value;
      return $self->{$sub};

    } or warn "Method: $sub not implemented\n";
  }
  return 1;			# import succeeded
}


1;

__END__