File Coverage

blib/lib/Class/ObjectTemplate/DB.pm

Criterion	Covered	Total	%
statement	177	205	86.3
branch	54	92	58.7
condition	5	9	55.5
subroutine	30	33	90.9
pod	1	13	7.6
total	267	352	75.8

package Class::ObjectTemplate::DB;
use Class::ObjectTemplate 0.5;
use Carp;
use strict;
no strict 'refs';
require Exporter;

use vars qw(@ISA @EXPORT $VERSION $DEBUG);

@ISA = qw(Class::ObjectTemplate Exporter);
@EXPORT = qw(attributes);
$VERSION = 0.27;

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

# JES -- Added to be able to turn automatic lookup on and off at
# method definition time. Set this to be true before calling
# attributes and the getter method will call undefined() if the
# current value is 'undef'.

# Create accessor functions, and new()
#
# attributes(lookup => ['foo', 'bar'], no_lookup => ['baz'])
# attributes('foo', 'bar', 'baz')
#
sub attributes {
    my ($pkg) = caller;

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

    my %args;
    # figure out if we were called with a simple parameter list
    # or with a hash-style parameter list
    if (scalar @_) {
      if (scalar @_ % 2 == 0 &&
	  ($_[0] eq 'lookup' || $_[0] eq 'no_lookup') &&
	  ref($_[1]) eq 'ARRAY') {
	# we were called with hash style parameters
	%args = @_;
      } else {
	# we were called with a simple parameter list
	%args = ('no_lookup' => [@_]);
      }
    }
    my $lookup;

    #
    # 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
    #
    print STDERR "defining constructor for $pkg\n" if $DEBUG;
    my $code .= Class::ObjectTemplate::_define_constructor($pkg);

    print STDERR "Creating methods for $pkg\n" if $DEBUG;
    foreach my $key (keys %args) {
      push(@{"${pkg}::_ATTRIBUTES_"},@{$args{$key}});

      # set up the $lookup boolean
      $lookup = ($key eq 'lookup');
      foreach my $attr (@{$args{$key}}) {
	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, $lookup);
	}
      }
    }

    eval $code;
    if ($@) {
       die  "ERROR defining constructor and attributes for '$pkg':\n"
            . "\t$@\n"
            . "-----------------------------------------------------"
            . $code;
    }
}

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

    # 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

    # in ObjectTemplate::DB, if the getter is called and the current
    # value of the attribute is undef, then the classes undefined()
    # method will be invoked with the name of the attribute.

    my $code;
    if ($lookup) {
      # If we are to do automatic lookup when the current value
      # is undefined, we need to be complicated
      $code = <<"CODE";
package $pkg;
sub $attr {                                       # Accessor ...
    my \$name = ref(\$_[0]) . "::_$attr";
    return \$name->[\${\$_[0]}] = \$_[1] if \@_ > 1; # set
    return \$name->[\${\$_[0]}]
         if defined \$name->[\${\$_[0]}];     # get
    # else call undefined(), and give it a change to define
    return \$name->[\${\$_[0]}] = \$_[0]->undefined('$attr');
}
CODE
    } else {
      # if we don't need to do lookup, it's short and sweet
      $code = <<"CODE";
package $pkg;
sub $attr {                                      # Accessor ...
    my \$name = ref(\$_[0]) . "::_$attr";
    \@_ > 1 ? \$name->[\${\$_[0]}] = \$_[1]  # set
            : \$name->[\${\$_[0]}];          # get
}
CODE
    }
  return $code;
}

# JES
# default function for lookup. Does the obvious
sub undefined {return undef;}
1;

__END__