File Coverage

blib/lib/Class/ObjectTemplate.pm

Criterion	Covered	Total	%
statement	168	204	82.3
branch	39	74	52.7
condition			n/a
subroutine	32	37	86.4
pod	0	17	0.0
total	239	332	71.9

package Class::ObjectTemplate;
require Exporter;

use vars qw(@ISA @EXPORT $VERSION $DEBUG);
use Carp;
use strict;
no strict 'refs';

@ISA = qw(Exporter);
@EXPORT = qw(attributes);
$VERSION = 0.7;

$DEBUG = 0; # assign 1 to it to see code generated on the fly

# Create accessor functions
sub attributes {
  my ($pkg) = caller;

  croak "Error: attributes() invoked multiple times"
    if scalar @{"${pkg}::_ATTRIBUTES_"};

  #
  # We must define a constructor for the class, because we must
  # declare the variables used for the free list, $_max_id and
  # @_free. If we don't, we will get compile errors for any class
  # that declares itself a subclass of any Class::ObjectTemplate
  # class
  #
  my $code .= _define_constructor($pkg);

  # _defined_constructor() may have added attributes that we inherited
  # from any superclasses now add the new attributes
  push(@{"${pkg}::_ATTRIBUTES_"},@_);

  # now define any accessor methods
  print STDERR "Creating methods for $pkg\n" if $DEBUG;
  foreach my $attr (@_) {
    print STDERR "  defining method $attr\n" if $DEBUG;
    # If a field name is "color", create a global list in the
    # calling package called @_color
    @{"${pkg}::_$attr"} = ();

    # If the accessor is already present, give a warning
    if (UNIVERSAL::can($pkg,"$attr")) {
      carp "$pkg already has method: $attr";
    } else {
      $code .= _define_accessor ($pkg, $attr);
    }
  }
  eval $code;
  if ($@) {
    die  "ERROR defining constructor and attributes for '$pkg':\n"
       . "\t$@\n"
       . "-----------------------------------------------------"
       . $code;
  }
}

# $obj->set_attributes (name => 'John', age => 23);
# Or, $obj->set_attributes (['name', 'age'], ['John', 23]);
sub set_attributes {
  my $obj = shift;
  my $attr_name;
  if (ref($_[0])) {
    my ($attr_name_list, $attr_value_list) = @_;
    my $i = 0;
    foreach $attr_name (@$attr_name_list) {
      $obj->$attr_name($attr_value_list->[$i++]);
    }
  } else {
    my ($attr_name, $attr_value);
    while (@_) {
      $attr_name = shift;
      $attr_value = shift;
      $obj->$attr_name($attr_value);
    }
  }
}


# @attrs = $obj->get_attributes (qw(name age));
sub get_attributes {
  my $obj = shift;
  my $pkg = ref($obj);
  my (@retval);
  return map {$ {"${pkg}::_$_"}[$$obj]} @_;
}

sub get_attribute_names {
  my $pkg = shift;
  $pkg = ref($pkg) if ref($pkg);
  return @{"${pkg}::_ATTRIBUTES_"};
}

sub set_attribute {
  my ($obj, $attr_name, $attr_value) = @_;
  my ($pkg) = ref($obj);
  return $ {"${pkg}::_$attr_name"}[$$obj] = $attr_value;
}

sub get_attribute {
  my ($obj, $attr_name, $attr_value) = @_;
  my ($pkg) = ref($obj);
  return $ {"${pkg}::_$attr_name"}[$$obj];
}

sub DESTROY {
  # release id back to free list
  my $obj = shift;
  my $pkg = ref($obj);
  my $inst_id = $$obj;

  # Release all the attributes in that row
  my (@attributes) = get_attribute_names($pkg);
  foreach my $attr (@attributes) {
    undef $ {"${pkg}::_$attr"}[$inst_id];
  }

  # The free list is *always* maintained independently by each base
  # class
  push(@{"${pkg}::_free"},$inst_id);
}

sub initialize { }; # dummy method, if subclass doesn't define one.

#################################################################

sub _define_constructor {
  my $pkg = shift;
  my $free = "\@${pkg}::_free";

  # inherit any attributes from our superclasses
  if (defined (@{"${pkg}::ISA"})) {
    foreach my $base_pkg (@{"${pkg}::ISA"}) {
      push (@{"${pkg}::_ATTRIBUTES_"}, get_attribute_names($base_pkg));
    }
  }

  my $code = <<"CODE";
    package $pkg;
    use vars qw(\$_max_id \@_free);
    sub new {
      my \$class = shift;
      my \$inst_id;
      if (scalar $free) {
	\$inst_id = shift($free);
      } else {
	\$inst_id = \$_max_id++;
      }
      my \$obj = bless \\\$inst_id, \$class;
      \$obj->set_attributes(\@_) if \@_;
      my \$rc = \$obj->initialize;
      return undef if \$rc == -1;
      \$obj;
    }

    # Set up the free list, and the ID counter
    \@_free = ();
    \$_max_id = 0;

CODE
  return $code;
}

sub _define_accessor {
  my ($pkg, $attr) = @_;

  # This code creates an accessor method for a given
  # attribute name. This method  returns the attribute value
  # if given no args, and modifies it if given one arg.
  # Either way, it returns the latest value of that attribute

  my $code = <<"CODE";
    package $pkg;
    sub $attr {                                      # Accessor ...
      my \$name = ref(\$_[0]) . "::_$attr";
         \@_ > 1 ? \$name->[\${\$_[0]}] = \$_[1]  # set
                 : \$name->[\${\$_[0]}];          # get
    }
CODE
  return $code;
}

1;
__END__