File Coverage

blib/lib/Class/Class.pm

Criterion	Covered	Total	%
statement	165	177	93.2
branch	74	94	78.7
condition	14	47	29.7
subroutine	36	37	97.3
pod	2	7	28.5
total	291	362	80.3

package Class::Class;

require 5.005;
require Pragmatic;

use strict;


%Class::Class::BUILT_METHODS = ( );

@Class::Class::EXPORT_OK = qw (package_exists);

@Class::Class::ISA = qw(Pragmatic);

# Bookkeepping; use our own MEMBERS so that objects inherit this,
# instead of it being global:
%Class::Class::MEMBERS =
  (__inited => '%',
   __tried_polymorph => '%');

%Class::Class::PRAGMATA =
  (override_inherited =>
   sub { $Class::Class::OVERRIDE_INHERITED = 1; });

# The package version, both in 1.23 style *and* usable by MakeMaker:
$Class::Class::VERSION = (substr q$Revision: 1.18 $, 10) - 1;
my $rcs = ' $Id: Class.pm,v 1.18 2000/01/05 16:15:48 binkley Exp $ ' ;


use Carp ( );
use Class::ISA;
use Symbol ( );


BEGIN { $Class::Class::OVERRIDE_INHERITED = 0; }


# Yes, it's true: I provide a default "new" for you.  See the
# documentation (below) for an explanation of this so-called feature.
sub new ($;@) {
  # Why is this here?? --bko FIXME
  no strict qw(refs);

  my ($this, @args) = @_;
  my $class = ref ($this) || $this;
  my $self = { };
  bless $self, $class;

  $self->renew (@args);
}

# This is used to reinitialize objects:
sub renew ($;@) {
  my ($self, @args) = @_;

  return $self->_make_methods->_process_args (@args)->_initialize_parents;
}

# Copy an object:
sub clone ($;@) {
  my ($self, @args) = @_;

  return $self->new ($self, @args);
}

# NOT a method:
sub package_exists ($) {
  no strict qw (refs);

  my ($class) = @_;
  $class =~ s/^:://o; # catch ::TopLevelPackage
  # Start at the root stash:
  my $last = '::';

  # Look in each successive sub-stash: [NB - the RE there just keeps
  # the :: tacked onto the end of the preceding package label: a
  # zero-width positive lookbehind assertion :-]
  for (split /(?<=::)/o, "$class\::") {
    return undef unless exists ${$last}{$_};
    $last = $_;
  }

  return 1;
}

# NB -- This is not (presently) a supported method for Class::Class --
# as a matter of fact, I consider it quite broken.  Why is it here?
# Since Class::Class has such intimate knowlege of your classes
# inheritance tree, it was easy for me to implement object changing
# into other objects, a feature I use in a seperate dynamic
# web-content system.  If I get request to support this, I may fix
# "polymorph" properly: until then, caveat emptor.  Double extra so
# for polyvolve!

# Turn into a different class:
sub polymorph ($;$@) {
  no strict qw(refs);

  my ($self, $class, @args) = @_;

  # Catch ::TopLevelModule:
  $class =~ s/^:://o;

  # Safe to call with no arguments:
  return $self unless $class;

  # We've already initialized (I think... ? --bko FIXME), so just
  # upcast ourselves:
  return bless $self, $class
    if ($self->isa ($class) or $self->__tried_polymorph ($class));

  # Save time and effort for next time through (note, we cache this
  # even for non-existent classes, just to save the work):
  $self->__tried_polymorph ($class, 1);

  (my $file = $class) =~ s,::,/,go;
  $file .= '.pm';

  # Limit the scope of the __DIE__ handler by using a block:
  {
    # Watch out that someone else may have installed a handler ahead
    # of us:
    local $SIG{__DIE__} = sub {
      die $_[0] unless $_[0] =~ /^Can't locate $file in \@INC/;
    };

    # Since use must have a bareword, carry out it's operations
    # explicitly rather than fall back on eval "use $class".  This
    # avoids the overhead of recompiling the string each time:
    eval { require $file; };

    # Try to setup the class anyway, in case it's defined not in
    # it's own separate file, but watch out -- it is just fine to
    # have no import method defined; need to be very careful not to
    # artificially create a stash for the package where none existed
    # before:
    $class->import
      if (package_exists ($class) and $class->can ('import'));
  }

  return $self unless package_exists ($class);

  bless $self, $class;

  return $self->renew (@args);
}

# This is like polymorph, except that I keep trying until it works,
# stripping off the last ::package name from the target class.  Again,
# I use this for a dynamic-content web system.  It could go there, but
# this functionality has nothing to do with web pages.  An example to
# illustrate: turn a Fred into a Human::Caveman::Flintstone::Barney,
# else a Human::Caveman::Flintstone, else a Human::Caveman, else a
# Human, else return the original Fred.

sub polyvolve ($;$@) {
  my ($self, $class, @args) = @_;

  do {
    $self = $self->polymorph ($class, @args);
  } while ($class ne ref $self and $class =~ s/::[^:]+$//o);

  return $self;
}

# Yes, it's true: I provide a default DESTROY for you.  See the
# documentation (below) for an explanation of this so-called feature.
sub DESTROY ($) {
  no strict qw(refs);

  my ($self) = @_;
  my $class = ref $self;

  # Give ourselves a chance to call cleanup code:
  my $glob = ${"$class\::"}{uninitialize};
  # This is for the object's package itself defining the method:
  $self->unitialize if (defined $glob and defined *{$glob}{CODE});

  for (keys %{"$class\::MEMBERS"}) {
    # Use internal knowlege.  This needs fixing for array
    # representation:
    $self->{$_} = undef if exists $self->{$_};
  }

  for my $class (@{"$class\::ISA"}) {
    # Explicity run super DESTROYS so we can handle multiple
    # inheritance:
    bless $self, $class;
    $self->DESTROY;
  }

  # Make us ourselves again so that we don't try to run more super's
  # DESTROYS:
  bless $self, $class;
}

### Methods below here are for implementation only -- need to look
### into using arrays instead of hashes:

sub add_method ($$$) {
  no strict qw(refs);

  my ($this, $name, $type) = @_;
  # Allowed to call as Fred::Barney->add_method (...):
  my $class = ref ($this) || $this;
  my $glob = ${"$class\::"}{$name};

  if ($type eq '$') {		# scalar
    *{"$class\::$name"} = sub ($;$) {
      (scalar @_ == 2) ? ($_[0]->{$name} = $_[1])
	: ($_[0]->{$name});
    };

  } elsif ($type eq '\$') {	# scalar reference
    *{"$class\::$name"} = sub ($;$) {
      (scalar @_ == 2) ? \($_[0]->{$name} = $_[1])
        : \($_[0]->{$name});
    };

  } elsif ($type eq '@') {	# array
    *{"$class\::$name"} = sub ($;$$) {
      (scalar @_ == 3) ? ($_[0]->{$name}[$_[1]] = $_[2])
	: (scalar @_ == 2) ? ($_[0]->{$name}[$_[1]])
	  : ($_[0]->{$name} ||= [ ]);
    };

  } elsif ($type eq '\@') {	# array reference
    *{"$class\::$name"} = sub ($;$$) {
      (scalar @_ == 3) ? \($_[0]->{$name}[$_[1]] = $_[2])
      : (scalar @_ == 2) ? \($_[0]->{$name}[$_[1]])
        : ($_[0]->{$name} ||= [ ]);
      };

  } elsif ($type eq '%') {	# hash
    *{"$class\::$name"} = sub ($;$$) {
      (scalar @_ == 3) ? ($_[0]->{$name}{$_[1]} = $_[2])
	: (scalar @_ == 2) ? ($_[0]->{$name}{$_[1]})
	  : ($_[0]->{$name} ||= { });
    };

  } elsif ($type eq '\%') {	# hash reference
    *{"$class\::$name"} = sub ($;$$) {
      (scalar @_ == 3) ? \($_[0]->{$name}{$_[1]} = $_[2])
      : (scalar @_ == 2) ? \($_[0]->{$name}{$_[1]})
        : ($_[0]->{$name} ||= { });
      };

  } elsif ($type eq '*') {	# glob
    *{"$class\::$name"} = sub ($;$) {
      (scalar @_ == 2) ? ($_[0]->{$name} = $_[1])
	: ($_[0]->{$name} ||= *{Symbol::gensym ( )});
    };

  } elsif ($type eq '\*') {	# glob reference
    *{"$class\::$name"} = sub ($;$) {
      (scalar @_ == 2) ? \($_[0]->{$name} = $_[1])
        : \($_[0]->{$name} ||= *{Symbol::gensym ( )});
    };

  } elsif ($type eq '&') {		# coderef
    *{"$class\::$name"} = sub ($;$) {
      # Surpress subroutine redefined and prototype mismatch:
      local $^W = 0;
      local $SIG{__WARN__} = sub {
	warn @_ unless $_[0] =~ /^Prototype mismatch:/o;
      };
      (scalar @_ == 2) ? (*{"$class\::$name"} = $_[1])
	: Carp::croak ("No coderef defined for '$name' yet");
    };

  } elsif ($type eq '\&') {		# coderef reference
    *{"$class\::$name"} = sub ($;$) {
      my ($self, $value) = @_; # need lexicals
      (scalar @_ == 2) ? ($self->{$name} = $value)
	# Need to do it this way so that we can arrange for $self to
	# be at the front of the argument list, as if by magic:
	: (sub { $self->{$name}->($self, @_); });
    };

  } elsif ($type =~ /^[^\\]/) {	# class (we hope)
    *{"$class\::$name"} = sub ($;$) {
      Carp::croak ("Not a class or subclass of '$_[1]'")
	if defined $_[1] and not UNIVERSAL::isa ($_[1], $type);

      # Be super careful -- because of closure tricks, need to use
      # $type->new syntax instead of new $type.  (Why?  See TC's
      # "indirect object syntax considered harmful" whitepaper.)
      (scalar @_ == 2) ? ($_[0]->{$name} = $_[1])
	: ($_[0]->{$name} ||= $type->new);
    };

  } else {			# class reference (we hope)
    $type =~ s/^\\//o;		# object class is name sans leader

    *{"$class\::$name"} = sub ($;$) {
      Carp::croak ("Not a class or subclass of '$_[1]'")
        if defined $_[1] and not UNIVERSAL::isa ($_[1], $type);

      # Be super careful -- because of closure tricks, need to use
      # $type->new syntax instead of new $type.  (Why?  See TC's
      # "indirect object syntax considered harmful" whitepaper.)
      (scalar @_ == 2) ? \($_[0]->{$name} = $_[1])
        : \($_[0]->{$name} ||= $type->new);
    };
  }

  return $this;
}

sub _make_methods ($) {
  no strict qw(refs);

  my ($self) = @_;

  # Build from most derived to least derived order:
  foreach my $class (Class::ISA::self_and_super_path (ref $self)) {
    # Try to avoid fooling around with a parent class which defines
    # MEMBERS but for different purposes:
    next unless UNIVERSAL::isa ($class, __PACKAGE__);

    # Check the cache so we don't do this twice:
    next if $Class::Class::BUILT_METHODS{$class};

    for my $key (keys %{"$class\::MEMBERS"}) {
      # Careful not to override user-defined access methods:
      if ($Class::Class::OVERRIDE_INHERITED) {
	# This is for the object's package itself defining the method:
	my $glob = ${"$class\::"}{$key};
	next if (defined $glob and defined *{$glob}{CODE});

      } else {
	# This is for inherited methods:
	next if $self->can ($key);
      }

      $class->add_method ($key, ${"$class\::MEMBERS"}{$key});
    }

    $Class::Class::BUILT_METHODS{$class} = 1;
  }

  # Lastly, wire in our DESTROY:
  my $class = ref $self;
  *{"$class\::DESTROY"} = \&DESTROY;

  return $self;
};

sub _process_args ($;@) {
  my $self = shift; # important not to use my ($self) = @_;
  my @args;

  while (ref $_[0]) {
    push @args, %{(shift)};
  }

  # Include yourself so you don't delete existing keys:
  %$self = (%$self, @args, @_);

  return $self;
}

sub _initialize_parents ($) {
  no strict qw(refs);

  my ($self) = @_;
  # To restore my class after initing my parents:
  my $class = ref $self;

  # Initing is idempotent:
  return $self if $self->__inited ($class);
  # I'm not inited until after all my parents init, but this breaks
  # downcasting via polymorph.  Think about this more.  --bko FIXME
  $self->__inited ($class, 1);

  for (@{"$class\::ISA"}) {
    next unless UNIVERSAL::isa ($_, __PACKAGE__);

    # While initializing, self should be the class of the parent so
    # that ISA lookup doesn't check unconstructed subclasses:
    $self = (bless $self, $_)->_initialize_parents;
  }

  # Check if we've been polymorphed into a subclass already:
  bless $self, $class unless UNIVERSAL::isa (ref $self, $class);

  $self = &{"$class\::initialize"} ($self)
    if defined &{"$class\::initialize"};

  return $self;
}

1;


__END__