File Coverage

blib/lib/Class/AccessorMaker/Private.pm

Criterion	Covered	Total	%
statement	38	47	80.8
branch	13	18	72.2
condition	5	14	35.7
subroutine	6	7	85.7
pod			n/a
total	62	86	72.0

package Class::AccessorMaker::Private;

##
## Class::AccessorMaker::Private by Hartog 'Sinister' de Mik
##

use strict;
no strict 'refs';

our $VERSION = "1.0";

use Carp;

# lexical for data-hiding

my %obj_ = ();

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
      $obj_{$self}->{$sub} = $subs->{$sub} if !exists $obj_{$self}->{$sub};

      # 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.
	$obj_{$self}->{$sub} = $value;
	return $self;
      }

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

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


1;

__END__