Class::Class - Adds data members to Perl packages

Class-Class documentation Contained in the Class-Class distribution.

Index

Code Index:

NAME

Top

Class::Class - Adds data members to Perl packages

SYNOPSIS

Top

In module MyModule.pm:

  package MyModule;
  use Class::Class;
  @ISA = qw (Class::Class);

  %MEMBERS =
    (scalar_ => '$', # "scalar" is a keyword
     scalarref => '\$',
     array => '@',
     arrayref => '\@',
     hash => '%',
     hashref => '\%',
     glob => '*',
     globref => '\*',
     object => 'Some::Package',
     objectref => '\Some::Package');

  sub initialize ($) {
    my ($self) = @_;

    # object initialization goes here: DO NOT USE 'new'

    return $self;
  }

  sub deinitialize ($) {
    my ($self) = @_;

    # object cleanup (if any) goes here: DO NOT USE 'DESTROY'

    return $self;
  }

In other files which wish to use MyModule:

  use MyModule;

  my $mm = new MyModule;

  $mm->scalar_ (42); # set "scalar_" to 42
  $mm->scalar_ ( ); # get value of "scalar_"
  $mm->scalarref (1.1); # set "scalarref" to 1.1
  $mm->scalarref ( ); # get reference to value of "scalarref"

  $mm->array ( ); # get arrayref stored in "array"
  $mm->array (1); # get 2nd element of "array"
  $mm->array (1, 'fish'); # set 2nd element of "array" to 'fish'
  $mm->arrayref ( ); # get arrayref stored in "arrayref"
  $mm->arrayref (1); # get reference to 2nd element of "arrayref"
  $mm->arrayref (1, 'fish'); # set 2nd element of "arrayref" to 'fish'

  $mm->hash ( ); # get hashref stored in "hash"
  $mm->hash ('bob'); # get 'bob' element of "hash"
  $mm->hash ('bob', 'one'); # set 'bob' element of "hash" to 'one'
  $mm->hashref ( ); # get hashref stored in "hashref"
  $mm->hashref ('bob'); # get reference to 'bob' element of "hashref"
  $mm->hashref ('bob', 'one'); # set 'bob' element of "hashref" to 'one'

  open G, '<blah.txt';
  $mm->glob (*G); # set "glob" to *G
  $mm->glob ( ); # get value of "glob"
  use Symbol;
  $mm->globref (gensym); # set "globref" to anonymous symbol
  $mm->globref ( ); # get reference to value of "globref"

  $mm->object ( ); # get object in "object"
  $mm->object->method; # invoke method on object in "object"
  $mm->objectref ( ); # get reference to object in "objectref"

DESCRIPTION

Top

Class::Class implements inheritable data methods for your packages with the same rules of inheritance as your other methods by generating creating accessor methods for your data the first time you make an instance of your package.

Why reinvent the wheel, you say? I got tired of the way Class::Struct worked, since the methods weren't inheritable the way I expected (no initialization of parent members before child members, for example), it was invoked programatically rather than declaratively, and I wanted to learn more about globs and the like. Plus I have a big head. :-)

Using Class::Class Modules

Using Class::Class modules is very simple. Just inherit from them as normal, but don't bother with writing a new method -- Class::Class provides one for you that arranges for superclasses to be initialized before subclasses. It also takes multiple inheritance into account (correctly, I hope).

To initialize your package, instead of sub new, write a sub initialize which takes an instance of your package as its only argument, and returns an instance:

  sub initialize ($) {
    my ($self) = @_;

    # Do something clever here with your object...

    return $self;
  }

There is no requirement you return the same instance that was handed to you. The methods polymorph and polyvolve are provided for this very purpose, to help with "virtual constructors".

Writing Class::Class Modules

Writing Class::Class modules is straight-forward.

Polymorph and Polyvolve

polymorph
polyvolve

EXAMPLES

Top

Using Class::Class Modules

1. Simple use:

Writing Class::Class Modules

1. Setting a package global:

SEE ALSO

Top

Class::ISA

Class::ISA creates an inverted inheritance tree, permitting easy traversal of a packages entire inheritance.

DIAGNOSTICS

Top

The following are the diagnostics generated by Class::Class. Items marked "(W)" are non-fatal (invoke Carp::carp); those marked "(F)" are fatal (invoke Carp::croak).

Not a class or subclass of '%s'

(F) The caller tried to assign to an object data member something which isn't an instance of that object's class, or which isn't an instance of a derived class.

No coderef defined for '%s' yet

(F) The caller tried to use a code reference without first providing assigning a coderef to the member.

BUGS AND CAVEATS

Top

Presently, Class::Class uses hashes for data members; array are demonstrably better for several reasons (see XXX -- TPJ) if you don't need direct access to data members by name. And even if you do, fields shows a good way to do that with recent versions of Perl.

AUTHORS

Top

B. K. Oxley (binkley) at Home <binkley@bigfoot.com>

COPYRIGHT

Top

  Copyright 1999, B. K. Oxley (binkley).

This library is free software; you may redistribute it and/or modify it under the same terms as Perl itself.

Class-Class documentation Contained in the Class-Class distribution. 
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__