File Coverage

blib/lib/MRP/BaseClass.pm

Criterion	Covered	Total	%
statement	88	352	25.0
branch	14	162	8.6
condition	7	65	10.7
subroutine	12	29	41.3
pod	4	5	80.0
total	125	613	20.3

package MRP::BaseClass;

use Exporter;
use Carp;
use strict;

use MRP::Introspection;
use MRP::Text;
use MRP::Interface;

use vars qw($AUTOLOAD %cache $VERSION);

$VERSION = 1.0;

# print nice diagnostics when functions are incorrectly called
#
sub AUTOLOAD {
    my ($package,$name) = $AUTOLOAD =~ /^(.+?)::([^:]+)$/;
    return if $name eq 'DESTROY';
    #print "Called with @_ and autoload $AUTOLOAD\n";
    my $self = shift || die $package."->".$name." called for nothing!";
    my $ref = ref $self || $self;
    my $message = ($ref eq $self) ? "Can't access '$name' in class $ref:\n" :
	                            "Can't access '$name' in object $self:\n";
    my ($member,$func);
    if($^W) {
	if(ref $self) {
	    foreach $member (sort keys %$self) {
		if( $member =~ /$name/i || $name =~ /$member/i ) {
		    $message .= "Did you mean member\t'$member'?\n";
		}
	    }
	}
	my %funcs = MRP::Introspection::recursiveInheritance($self,'MRP::Introspection::functions');
	foreach $func (sort keys %funcs) {
	  my ($funcn) = $func =~ /([^:]+)$/;
	  if( $funcn =~ /$name/i || $name =~ /$funcn/i ) {
	    $message .= "Did you mean function\t'$func'?\n";
	  }
	}
	my ($package, $filename, $line) = caller;
	$message .= "in $filename at line $line\n";
	$message .= "\n".$self->_printMembers()."\n";
    }
    confess $message;
}

# returns a MRP::MyBase object
# use this for all derived classes
#
sub new {
    my $ref = shift;
    my $class = ref($ref) || $ref;
    my $self = {};

    rebless($self,$class);

#    print "Created $self\n";
    return $self;
}

sub DESTROY {
#  my $self = shift;
#  print "Destroying $self\n";
}

sub clone {
  my $self = shift;
  my $depth = shift;
  my $clone = {};
  my ($name, $value);
  my $ref;

  $depth = defined($depth)
    ? ($depth =~ /'shallow'/) ? '' : 1
      : '';

  while (($name, $value) = each %$self) {
    if($depth) {                                      # if we are doing a deep copy
      if($ref = ref($value)) {                        # and we have a reference
	for($ref) {                                   # what type of reference?
	  /^HASH$/ && do { %{$self->{$name}} = %$value; next; };
	  /^ARRAY$/ && do { @{$self->{$name}} = @$value; next; };
	  /^SCALAR$/ && do { my $tmp = $$value; $self->{$name} = \$tmp; next; };
	  $clone->{$name} = $value->can('clone')          # and clone this object
	    ? $value->clone()                         # by hook
	      : $value->MRP::BaseClass::clone($depth); # or by crook
	}
      } else {
	$clone->{$name} = $value;
      }
    } else {                                          # if wee are doing a shallow copy
      $clone->{$name} = $value;                       # add each filed itself.
    }
  }

  bless $clone, ref $self;
  return $clone;
}

# reblesses a reference to a base class object into your class
# adds the apropreate members with their default values as
# defined in the %fields hash, and modified by initialize
# If the default value for any of the fields is a hash or
# array ref, puts in a new ref for the object.
#

sub rebless {
  my ($self,$class,%fields);
  if(ref $_[0]) {
    $self = shift || confess "You must give an object to rebless";
    $class = shift || confess "You must give a package to rebless $self into";
  } else {
    $class = shift;
    $self = {};
    my @parents = @_;
    %$self = map { ref $_
		     ? %$_
		       : confess "You tried to treat scalar $_ as an object for rebless"
		     } @parents; # add all the parental fileds to this object
    #print "Multiple inheritance. $self is created from ", MRP::Text->pretyArray(@parents), "\n";
  }

  # add this classes fields to the object
  %fields = _fields($class);
  foreach my $field (sort keys %fields) {
    my $val = $fields{$field};
    for (ref $val) {
      /^ARRAY$/ && do {
	$fields{$field} = [];
	last;
      };
      /^HASH$/ && do {
	$fields{$field} = {};
	last;
      };
    }
  }
  %{$self} = (%{$self}, %fields);
  #print "Reblessing $self into $class\n";
  bless $self, $class;
  my $initialize = MRP::Introspection::function($self,'initialize');
  &$initialize($self) if defined $initialize;

  return $self;
}

# prints a list of all members out - nice but not necisary. Will be lost
#
sub _printMembers {
    my $self = shift;
    my ($key, $val);
    my ($func, $scalar, $hash, $array, $ref);
    my $text;
    local $^W = undef;
    if(ref $self) {
	$text  = "Dumping model for $self\n";
	$text .= "Members\n";
	$text .= MRP::Text->pretyHash("\t", $self);
    }
    $text .= "Methods\n";
    my %funcs = MRP::Introspection::recursiveInheritance($self,'MRP::Introspection::functions');
    foreach $func (sort keys %funcs) {
      $ref = $funcs{$func};
      $func =~ /:_/ && next;
      $func =~ /:memberAccess::.*?_/ && next;
      $func =~ /(croak)|(confess)|(carp)/ && next;
      $text .= "\t$func\t= $ref\n";
    }
    $text .= "Variables\n";
    my %scalars = MRP::Introspection::scalars($self);
    while (($scalar, $ref) = each %scalars) {
	$text .= "\t\$$scalar\t= $$ref\n";
    }
    my %hashes = MRP::Introspection::hashes($self);
    while (($hash, $ref) = each %hashes) {
	$text .= "\t\%$hash\t= $ref=\n".MRP::Text->pretyHash("\t\t", $ref)."\n";
    }
    my %arrays = MRP::Introspection::arrays($self);
    while (($array, $ref) = each %arrays) {
	$text .= "\t\@$array\t= $ref=".MRP::Text->pretyArray($ref)."\n";
    }
    return $text;
}

sub _fields ($) {
  my $thingy = shift;
  my $fields = MRP::Introspection::hash($thingy,'fields');
  return () unless defined $fields;
  return (wantarray)
    ? %$fields
      : $fields;
}

# checks for name clashes between a class and all of it's base classes and delegates.
# Supports multiple inheritance, and multi-level inheritance
#
# also makes sure that $package::memberAccess is at the beginning of @$package::INC
sub check4Clashes {
  my $class = shift;
  my %debug = @_;
  my $memberPackage = $class."::memberAccess";
#  print "Checking $class\n";
  # open the debug streams
  my ($VARIABLES, $DELEGATES);
  if(exists $debug{'variables'}) {
    unless(defined(my $fh = $debug{'variables'})) {
      $VARIABLES = \*STDERR;
    } elsif (ref($fh) eq 'GLOB') {
      $VARIABLES = $fh;
      $debug{'variables'} = undef;
    } else {
      open(VARIABLES, ">>$fh") || die "Could not open $fh for appending: $!";
      $VARIABLES = \*VARIABLES;
      $debug{'variables'} = 'close';
    }
  } else { $VARIABLES = undef; }
  if(exists $debug{'delegates'}) {
    unless(defined(my $fh = $debug{'delegates'})) {
      $DELEGATES = \*STDERR;
    } elsif (ref($fh) eq 'GLOB') {
      $DELEGATES = $fh;
      $debug{'delegates'} = undef;
    } else {
      open(DELEGATES, ">>$fh") || die "Could not open $fh for output: $!";
      $DELEGATES = \*DELEGATES;
      $debug{'delegates'} = 'close';
    }
  } else { $DELEGATES = undef; }

  # get the fields has for $class
  my $fields = $class->MRP::BaseClass::_fields() || {};
  my $delegates = MRP::Introspection::hash($class,'delegates') || {};
  my $variables = MRP::Introspection::array($class,'public_vars') || [];
  my %variables = map {
    /^([\@\$\%])(.*)$/;
    ($2,($1 eq '@')
     ? []
     : ($1 eq '%')
     ? {} : undef
    )
  } @$variables;
  my $default = MRP::Introspection::array($class,'defaults') || [];
  my %default = map {
    /^([\@\$\%])(.*)$/;
    ($2,($1 eq '@')
     ? []
     : ($1 eq '%')
     ? {} : undef
    )
  } @$default;
  my %all = map { ($_,1) } keys %$fields, keys %variables, keys %default;
  my $isaref = MRP::Introspection::ISA($class) || [];
  my $override;
  my @found = ();

  # check for ambiguous functions
  my $isaCache;
  my @lISA = @$isaref;

  if(@lISA) {
    my $firstParent = shift @lISA;
    $isaCache = $cache{$firstParent};
    unless($isaCache) {
      $firstParent->MRP::BaseClass::check4Clashes();
      $isaCache = $cache{$firstParent};
    }
#    print "$class: Adding $firstParent\n";
  }

  my @clashes;
  my %allfunctions = %{scalar($isaCache->{'functions'}) || {}};
  my %allfields = %{scalar($isaCache->{'fields'}) || {}};
  my $classCache = {functions=>{},fields=>{}};
  my %classFunctions = MRP::Introspection::functions($class);
  my %classFields = MRP::BaseClass->_fields($class);
  foreach (keys %classFunctions) { $classFunctions{$_} = [$class, $classFunctions{$_}] }
  foreach (keys %classFields) { $classFields{$_} = $class }

  foreach my $isa (@lISA) {
#   print "$class: Checking $isa for clashes\n";
    my $isaCache = $cache{$isa} || do {$isa->MRP::BaseClass::check4Clashes, $cache{$isa}};
    my %functions = %{scalar($isaCache->{'functions'}) || {}};
    my %fields = %{scalar($isaCache->{'fields'}) || {}};
    foreach my $function (keys %functions) {
      my ($package,$ref) = @{$functions{$function}};
      if(my $clash = $allfunctions{$function}) {
	if($clash->[1] ne $ref) {
	  unless($classFunctions{$function}) {
	    push @clashes, "$package->$function\t <----->\t$clash->[0]"."->$function";
	  }
	}
      }
      $allfunctions{$function} = $functions{$function};
    }
    foreach my $field (keys %fields) {
      if(my $clash = $allfields{$field}) {
	push @clashes, "method:   $isa->$field\t <----->\t$clash->$field";
      }
      $allfields{$field} = $fields{$field};
    }
  }

  foreach my $delegate (keys %$delegates) {
    my $list = $delegates->{$delegate};
    ref $list || next;
    my @list;
    foreach my $func (@$list) {
      (ref($func)) and
	push @list, $func->functions() or
	  push @list, $func;
    }
    foreach my $func (@list) {
      if(my $clash = $allfunctions{$func}) {
	unless($classFunctions{$func}) {
	  push @clashes, "delegate: $delegate->$func\t <-----> " . $clash->[0] . "->$func";
	}
      }
    }
  }

  %allfunctions = (%allfunctions, %classFunctions);
  %allfields = (%allfields, %classFields);

  # check that delegate functions do not clash with fields or inherited functions
  foreach my $field (keys %$fields) {
    foreach my $delegate (keys %$delegates) {
      push @clashes,
		  map { ($field eq $_ and
		       not MRP::Introspection::function($class,$field))
			  ? "field $field clashes with $delegate->$_"
			    : ();
		      } @{$delegates->{$delegate}}
    }
  }

  # check that default variables don't clash with package/field or inherited field variables
  foreach my $default (keys %default) {
    if(exists $fields->{$default}) {
      push @clashes, "default $default clashes with field";
    } elsif (exists $allfields{$default}) {
      push @clashes, "default $default clashes with inherited field";
    } elsif (exists $variables{$default}) {
      push @clashes, "default $default clashes with variable";
    }
  }
  %$fields = (%$fields, map { ($_,undef) } keys %default);

  if(@clashes) {
    die "The following parts of $class are ambiguous:\n",
    join "\n",@clashes,"\n";
  }

  my $func;
  # add the member access functions
  foreach my $item (keys %all) {
    my $item_ref = $item.'_ref';
    my $item_field = $item.'_field';
    my $item_global = $item.'_global';
    MRP::Introspection::function($memberPackage,$item)
      && confess "$item already exists in $memberPackage\n";
    # generate the @default member access functions
    if(exists $default{$item}) {
      #print "Generating defualt function for '$item'\n";
      for (ref $default{$item}) {
	if(/^ARRAY$/) {	# this is an array member
	  $func = $class->_fieldArrayFunc($memberPackage,$item_field,$item);
	  $func.= $class->_packageArrayFunc($memberPackage,$item_global,$item);
	} elsif (/^HASH$/) {	# this is a hash member
	  $func = $class->_fieldHashFunc($memberPackage,$item_field,$item);
	  $func.= $class->_packageHashFunc($memberPackage,$item_global,$item);
	} else {
	  $func = $class->_fieldScalarFunc($memberPackage,$item_field,$item,$fields->{$item});
	  $func.= $class->_packageScalarFunc($memberPackage,$item_global,$item);
	}
      }
      $func .= $class->_defaultField($memberPackage, $item,
				     $item_field, $item_global)
    } elsif(exists $fields->{$item}) {
      if(exists $variables{$item}) {
	# Generate access functions for duel field/package items
	#print "generating dual acces for '$item'\n";
	for (ref $fields->{$item}) {
	  if(/^ARRAY$/) {
	    $func = $class->_fieldArrayFunc($memberPackage,$item_field,$item);
	  } elsif (/^HASH$/) {
	    $func = $class->_fieldHashFunc($memberPackage,$item_field,$item);
	  } else {
	    $func = $class->_fieldScalarFunc($memberPackage,$item_field,$item,$fields->{$item});
	  }
	}
	for (ref $variables{$item}) {
	  if(/^ARRAY$/) {
	    $func .= $class->_packageArrayFunc($memberPackage,$item_global,$item);
	  } elsif (/^HASH$/) {
	    $func .= $class->_packageHashFunc($memberPackage,$item_global,$item);
	  } else {
	    $func .= $class->_packageScalarFunc($memberPackage,$item_global,$item);
	  }
	}
	$func .= $class->_packageAndField($memberPackage, $item,
					  $item_field, $item_global)
      } else {
	# generate field member functions
	#print "generating field '$item'\n";
	for (ref $fields->{$item}) {
	  if(/^ARRAY$/) {
	    $func = $class->_fieldArrayFunc($memberPackage,$item);
	  } elsif (/^HASH$/) {
	    $func = $class->_fieldHashFunc($memberPackage,$item);
	  } else {
	    $func = $class->_fieldScalarFunc($memberPackage,$item,$fields->{$item});
	  }
	}
      }
    } else {
      # generate package member functions
      #print "Generating package member function '$item'";
      for (ref $variables{$item}) {
	if(/^ARRAY$/) {
	  $func = $class->_packageArrayFunc($memberPackage,$item);
	} elsif (/^HASH$/) {
	  $func = $class->_packageHashFunc($memberPackage,$item);
	} else {
	  $func = $class->_packageScalarFunc($memberPackage,$item);
	}
      }
    }
   $VARIABLES && print $VARIABLES $func;
#    print "Compiling member access:\n$func\n";
    eval $func; $@ && die "Error compiling code: $@";
  }
  # add the delegation functions
  foreach my $delegate (keys %$delegates) {
#    print "Processing delegate $delegate\n";
    exists $fields->{$delegate} and
      die "You have specified $class->$delegate as a delegate but there is a field by that name";
    my @interfaces = ();
    my $func = "";
    foreach my $item (@{$delegates->{$delegate}}) {
#      print "Generating delegate for '$delegate->$item'\n";
      if(ref($item)) {
	$func .= join '', map { $class->_delegateFunc($memberPackage,$delegate,$_) } ($item->functions());
	push @interfaces, $item;
      } else {
	$func .= $class->_delegateFunc($memberPackage,$delegate,$item); # make a function for it
      }
      $DELEGATES && print $DELEGATES $func;
    }
    $func .= $class->_delegateAccess($memberPackage,$delegate,@interfaces);
#    print "Compiling delegates:\n$func\n";
    eval $func; $@ && die "Error compiling code:\n$func";
  }
  # now add that entry to @ISA
  my %ISA = map { ($_,1) } @$isaref;
  if(((%all or %$delegates) and not exists $ISA{$class."::memberAccess"})) {
    $memberPackage->MRP::BaseClass::check4Clashes();
    unshift(@$isaref, $class."::memberAccess");
    %allfunctions = (%allfunctions,%{$cache{$memberPackage}->{functions}});
  }

  $classCache->{functions} = {%allfunctions};
  $classCache->{fields} = {%allfields};
#  print "$class has interface\n", MRP::Text->pretyHash('  ', %allfunctions), "\n";

  $cache{$class} = $classCache;
  close $VARIABLES if $debug{'variables'};
  close $DELEGATES if $debug{'delegates'};
#  print "Checked  $class\n";
}

sub _delegateFunc {
  my ($thingy, $memberPackage, $delegate, $function) = @_;

  return qq(
	    package $memberPackage;
	    sub $function {
			   my \$self = shift;
			   return \$self->$delegate->$function(\@_);
			  }
	   );
}

sub _delegateAccess {
  my ($thingy, $memberPackage, $item) = (shift,shift,shift);

  my $performChecks = join ";\n", map {qq(MRP::Interface->$_->implementedBy(\$value) or
					  Carp::confess "Delegate \$value must implement interface $_")
				     } map { $_->name() } @_;

  return qq(
	    package $memberPackage;
	    sub $item {
		       my \$self = shift;
		       if(\@_) {
			 my \$value = shift;
			 $performChecks;
			 return \$self->{'$item'} = \$value;
		       } else {
			 return \$self->{'$item'};
		       }
		      }
	   );
}

sub _fieldScalarFunc {
    my ($thingy, $memberPackage, $name, $interface, $item) = @_;
    $item ||= $name;

    my $interfaceText = "";
    if(ref($interface)) {
      $interface = $interface->name;
      $interfaceText = qq(MRP::Interface->$interface->implementedBy(\$_[0]) or
			  Carp::confess "field \$_[0] must implement interface $interface";);

    }

    return qq(
	      package $memberPackage;
	      sub $name {
			 my \$self = shift;
			 (\@_)
			 ? do { $interfaceText
				\$self->{'$item'} = \$_[0];
			      }
			 : \$self->{'$item'};
			}
	     );
}

sub _packageScalarFunc {
    my ($thingy, $memberPackage, $name, $item) = @_;
    $item ||= $name;
    my $packagevar = $thingy.'::'.$item;

    return qq(
	      package $memberPackage;
	      sub $name {
			 my \$class = shift;
			 scalar(\@_)
			 ? \$$packagevar = \$_[0]
			 : \$$packagevar;
			}
              );
}

sub _fieldArrayFunc {
    my ($thingy, $memberPackage, $name, $item) = @_;
    $item ||= $name;
    my $name_ref = $name.'_ref';

    return qq(
	      package $memberPackage;
	      sub $name {
			 my \$self = shift;
			 if (\@_ or not defined wantarray) {
			   \$self->{'$item'} = [] if not defined \$self->{'$item'};
			   \@{\$self->{'$item'}} = \@_;
			 }
			 my \$ret = \$self->{'$item'};
			 return ref(\$ret)
			 ? (wantarray)
			   ? \@{\$self->{'$item'}}
			   : \$self->{'$item'}
                         : (not defined \$ret)
                           ? undef
			   : &Carp::confess("Ilegal value for $item in \$self\n".\$self->_printMembers);
			}
	  ) . $thingy->_fieldScalarFunc($memberPackage, $name_ref, undef, $item);
}

sub _packageArrayFunc {
    my ($thingy, $memberPackage, $name, $item) = @_;
    $item ||= $name;
    my $packagevar = $thingy.'::'.$item;

    return qq(
	      package $memberPackage;
	      sub $name {
			 my \$class = shift;
			 \@$packagevar = \@_ if (\@_) or not defined wantarray;
			 wantarray
			 ? \@$packagevar
			 : \\\@$packagevar;
			}
              );
}

sub _fieldHashFunc {
    my ($thingy, $memberPackage, $name, $item) = @_;
    $item ||= $name;
    my $name_ref = $item.'_ref';

    return qq(
	      package $memberPackage;
	      sub $name {
			 my \$self = shift;
			 if(\@_ or not defined wantarray) {
			   if(\@_==1) {
			     my \$val = shift;
			     if(ref \$val eq 'HASH') {
			       %{\$self->{'$item'}} = %\$val;
			     } elsif (ref \$_[0] eq 'ARRAY') {
			       %{\$self->{'$item'}} = \@\$val;
			     } else {
			       Carp::confess "Can not set the hash member variable '$item' to \$val";
			     }
			   } else {
			     %{\$self->{'$item'}} = \@_;
			   }
			 }
			 my \$ret = \$self->{'$item'};
			 return (ref \$ret)
			   ? (wantarray)
			     ? (%{\$self->{'$item'}})
			     : (\$self->{'$item'})
			   : not defined(\$ret)
                             ? undef
			     : Carp::confess "Member $item of \$self has gained the ilegal value '\$ret'" . \$self->_printMembers;
			}
	      ) . $thingy->_fieldScalarFunc($memberPackage, $name_ref, undef, $item);
}

sub _packageHashFunc {
    my ($thingy, $memberPackage, $name, $item) = @_;
    $item ||= $name;
    my $packagevar = $thingy.'::'.$item;

    return qq(
	      package $memberPackage;
	      sub $name {
			 my \$class = shift;
			 \%$packagevar = \@_ if (\@_ or not defined wantarray);
			 wantarray
			 ?\%$packagevar
			 : \\%$packagevar;
			}
              );
}

sub _packageAndField {
    my ($thingy,$memberPackage,$item,$fieldFunc,$packageFunc) = @_;

    return qq(
	      package $memberPackage;
	      sub $item {
			 my \$thingy = shift;
			 ref(\$thingy)
			 ? \$thingy->$fieldFunc(\@_)
			 : \$thingy->$packageFunc(\@_);
			}
              );
}

sub _defaultField {
    my ($thingy,$memberPackage,$item,$fieldFunc,$packageFunc) = @_;

    return qq(
	      package $memberPackage;
	      sub $item {
			 my \$thingy = shift;
			 my \@return;
			 ref(\$thingy)
			 ? do {
			   \@return = (\$thingy->$fieldFunc(\@_));
			   (\@return &&
			    not (\@return == 1 && not defined(\$return[0])))
			     ? \@return
			       : \$thingy->$packageFunc(\@_)
			 }
			 : \$thingy->$packageFunc(\@_);
			}
              );
}

use vars qw(%builtInRefs);
%builtInRefs = map { ($_,1) } qw(REF SCALAR ARRAY HASH CODE GLOB);

sub isObject {
  my $self = shift;
  my $ref = shift;
  $ref = ref($ref) || return undef;
  exists $builtInRefs{$ref} && return undef;
  return $ref;
}

BEGIN {
  use vars qw(@ISA);
  @ISA = qw(Exporter);
  MRP::BaseClass->check4Clashes();
}

$VERSION;  # says use was ok
__END__