--- /dev/null
+# This module is part of DA, Don Armstrong's Modules, and is released
+# under the terms of the GPL version 2, or any later version. See the
+# file README and COPYING for more information. Copyright 2003 by Don
+# Armstrong <don@donarmstrong.com>.
+# $Id: Modular.pm,v 1.8 2003/12/09 02:00:10 don Exp $
+
+package Class::Modular;
+
+=head1 NAME
+
+Class::Modular -- Modular class generation superclass
+
+=head1 SYNOPSIS
+
+package Foo::Bar;
+
+@ISA = qw(Class::Modular);
+
+
+=head1 DESCRIPTION
+
+Class::Modular is a superclass for generating modular classes, where
+methods can be added into the class from the perspective of the
+object, rather than the perspective of the class.
+
+That is, you can create a class which has a set of generic common
+functions. Less generic functions can be included or overridden
+without modifying the base classes. This allows for code to be more
+modular, and reduces code duplication.
+
+=over
+
+=item new
+
+new is responsible for blessing and creating a new database superclass.
+
+=item load
+
+load is responsible for loading database plugins
+
+=back
+
+
+=head1 FUNCTIONS
+
+=cut
+
+use strict;
+use vars qw($VERSION $DEBUG);
+
+use Carp;
+
+use Data::Copy qw(deep_copy); # Used for deep copying objects
+
+BEGIN{
+ ($VERSION) = q$Revision: 1.8 $ =~ /\$Revision:\s+([^\s+])/;
+ $DEBUG = 0 unless defined $DEBUG;
+}
+
+our $AUTOLOAD;
+
+=head2 new
+
+ Title : new
+ Usage : $obj = Foo::Bar->new();
+ Function: Creates a new Foo::Bar object
+ Returns : A new Foo::Bar object
+ Args : none.
+
+ Aditional arguments can be passed to this creator, and they are
+ stored in $self->{_creation_args}. You can also override the new
+ method in your subclass. It's just provided here for completeness.
+
+=cut
+
+sub new {
+ my ($class,@args) = @_;
+
+ # We shouldn't be called $me->new, but just in case
+ $class = ref($class) || $class;
+
+ my $self = {};
+ bless $self, $class;
+
+ $self->_init(@args);
+
+ return $self;
+}
+
+
+=head2 _init
+
+=head3 Usage
+
+ $self->_init(@args);
+
+=head3 Function
+
+Stores the arguments used at new so modules that are loaded later can
+read them
+
+=cut
+
+sub _init {
+ my ($self,@creation_args) = @_;
+
+ $self->{creation_args} = [@_];
+}
+
+
+=head2 load
+
+ Title : load
+ Usage : $db->load('FOO::Subclass');
+ Function: loads a Class::Modular subclass
+ Returns : nothing
+ Args : SCALAR subclass SCALAR options
+
+ Loads the named subclass into this object if the named subclass has
+ not been loaded.
+
+ The options scalar is passed to $subclass::_methods when determining
+ which methods should be added using _addmethods.
+
+ The subclasses _init method is called right after methods are loaded.
+
+ If debugging is enabled, will warn about loading already loaded
+ subclasses.
+
+=cut
+
+
+sub load($$;$) {
+ my ($self,$subclass,$options) = @_;
+
+ $options ||= {};
+
+ # check to see if the subclass has already been loaded.
+
+ if (not defined $self->{_subclasses}->{$subclass}){
+ eval {
+ no strict 'refs';
+ eval "require $subclass" or die $@;
+ $self->_addmethods($subclass,&{"${subclass}::_methods"}($self,$options));
+ &{"${subclass}::_init"}($self);
+ };
+ die $@ if $@;
+ $self->{_subclasses}->{$subclass} = {};
+ }
+ else {
+ carp "Not reloading subclass $subclass" if $DEBUG;
+ }
+}
+
+=head2 _addmethods
+
+ Title : _addmethods
+ Usage : $self->_addmethods()
+ Function: Adds the passed methods into the function table
+ Returns :
+ Args : ARRAY of methods
+
+ Given an array of methods, adds the methods into the _methodhash
+ calling table.
+
+ Methods that have previously been overridden by override are _NOT_
+ overridden again. This may need to be adjusted in load.
+
+=cut
+
+sub _addmethods($@) {
+ my ($self,$subclass,@methods) = @_;
+
+ # stick the method into the table
+ # DLA: Make with the munchies!
+
+ foreach my $method (@methods) {
+ if (not $method =~ /^$subclass/) {
+ $method = $subclass.'::'.$method;
+ }
+ my ($method_name) = $method =~ /\:*([^\:]+)\s*$/;
+ if (exists $self->{_methodhash}->{$method_name}) {
+ if ($self->{_methodhash}->{$method_name}->{overridden}) {
+ carp "Not overriding already overriden method $method_name\n" if $DEBUG;
+ next;
+ }
+ carp "Overriding $method_name $self->{_methodhash}->{$method_name}->{reference} with $method\n";
+ }
+ $self->{_methodhash}->{$method_name}->{reference} = $method;
+ $self->{_methodhash}->{$method_name}->{subclass} = $subclass;
+ }
+
+}
+
+=head2 override
+
+ Title : override
+ Usage : $obj->override('methodname', $code_ref)
+ Function: Overrides the method methodname and calls $code_ref instead.
+ Returns : TRUE on success, FALSE on failure.
+ Args : SCALAR method name
+ CODEREF function reference
+
+ Allows you to override utility functions that are called internally
+ to provide a different default function.
+
+ It's superficially similar to _addmethods, which is called by load,
+ but it deals with code references, and requires the method name to be
+ known.
+
+ Methods overridden here are _NOT_ overrideable in _addmethods. This
+ may need to be changed.
+
+=cut
+
+sub override {
+ my ($self, $method_name, $function_reference) = @_;
+
+ $self->{_methodhash}->{$method_name}->{reference} = $function_reference;
+ $self->{_methodhash}->{$method_name}->{overridden} = 1;
+}
+
+=head2 clone
+
+ Title : clone
+ Usage : my $clone = $obj->clone
+ Function: Produces a clone of the Class::Modular object
+ Returns :
+ Args :
+
+ Produces a clone of the object with duplicates of all data and/or new
+ connections as appropriate.
+
+ Calls _clone on all loaded subclasses.
+
+ Warns if debugging is on for classes which don't have a _clone
+ method. Dies on other errors.
+
+=cut
+
+sub clone {
+ my ($self) = @_;
+
+ my $clone = {};
+ bless $clone, ref($self);
+
+ # copy data structures at this level
+ $clone->{_methodhash} = deep_copy($self->{_methodhash});
+ $clone->{_subclasses} = deep_copy($self->{_subclasses});
+
+ foreach my $subclass (keys %{$self->{_subclasses}}) {
+ # use eval to try and call the subclasses _clone method.
+ # Ignore no such function errors, but trap other types of
+ # errors.
+
+ # XXX Switch to can instead.
+ eval {
+ no strict 'refs';
+ &$subclass::_clone($self,$clone);
+ };
+ if ($@) {
+ # Die unless we've hit an undefined subroutine.
+ die $@ unless $@ =~ /Undefined\s*subroutine\s*\&.*\:\:\_clone/;
+ warn "$subclass doesn't have a _clone method\n$@" if $DEBUG;
+ }
+
+
+ }
+}
+
+=head2 can
+
+=head3 Usage
+
+ $obj->can('METHOD');
+ Class::Modular->can('METHOD');
+
+=head3 Function
+
+Replaces UNIVERSAL's can method so that handled methods are reported
+correctly. Calls UNIVERSAL::can in the places where we don't know
+anything it doesn't.
+
+=head3 Returns
+
+A coderef to the method if the method is supported, undef otherwise.
+
+=head3 Args
+
+Scalar Method Name
+
+=cut
+
+sub can{
+ my ($self,$method,$vars) = @_;
+
+ if (ref $self and exists $self->{_methodhash}->{$method}) {
+ # If the method is defined, return a reference to the
+ # method.
+ return $self->{_methodhash}->{$method}->{reference};
+ }
+ else {
+ # Otherwise, let UNIVERSAL::can deal with the method
+ # appropriately.
+ return UNIVERSAL::can($self,$method);
+ }
+}
+
+=head2 handledby
+
+=head3 Usage
+
+ $obj->handledby('methodname');
+ $obj->handledby('Class::Method::methodname');
+
+=head3 Function
+
+Returns the subclass that handles this method.
+
+=head3 Returns
+
+SCALAR subclass name
+
+=head3 Args
+
+SCALAR method name
+
+=cut
+
+sub handledby{
+ my ($self,$method_name) = @_;
+
+ $method_name =~ s/.*\://;
+
+ if (exists $self->{_methodhash}->{$method_name}) {
+ return $self->{_methodhash}->{$method_name}->{subclass};
+ }
+ return undef;
+}
+
+
+=head2 DESTROY
+
+=head3 Usage
+
+Called by perl.
+
+=head3 Function
+
+Calls all subclass _destroy methods.
+
+Subclasses need only implement a _destroy method if they have
+references that need to be uncircularized, or things that should be
+disconnected or closed.
+
+=cut
+
+sub DESTROY{
+ my $self = shift;
+ foreach my $subclass (keys %{$self->{_subclasses}}) {
+ # use eval to try and call the subclasses _destroy method.
+ # Ignore no such function errors, but trap other types of
+ # errors.
+ eval {
+ no strict 'refs';
+ &$subclass::_destroy($self);
+ };
+ if ($@) {
+ # Die unless we've hit an undefined subroutine.
+ die $@ unless $@ =~ /Undefined\s*subroutine\s*\&.*\:\:\_clone/;
+ warn "$subclass doesn't have a _clone method\n$@" if $DEBUG;
+ }
+ }
+}
+
+
+=head2 AUTOLOAD
+
+ Title : AUTOLOAD
+ Usage : Called by perl
+ Function: Calls child methods which have been installed into this handle
+ Returns : N/A
+ Args : N/A
+
+The AUTOLOAD function is responsible for calling child methods which
+have been installed into the current Class::Modular handle.
+
+Subclasses that have a new function as well as an AUTOLOAD function
+must call Class::Modular::AUTOLOAD and set $Class::Modular::AUTOLOAD
+
+ $Class::Modular::AUTOLOAD = $AUTOLOAD;
+ goto &Class::Modular::AUTOLOAD;
+
+=cut
+
+sub AUTOLOAD{
+ my $method = $AUTOLOAD;
+
+ $method =~ s/.*\://;
+
+ my ($self) = @_;
+
+ if (not ref($self)) {
+ carp "Not a reference in AUTOLOAD.";
+ return;
+ }
+
+ if (exists $self->{_methodhash}->{$method} and
+ defined $self->{_methodhash}->{$method}->{reference}) {
+ eval {
+ no strict 'refs';
+ goto &{$self->{_methodhash}{$method}{reference}};
+ }
+ }
+ else {
+ croak "Undefined function $AUTOLOAD";
+ }
+}
+
+
+1;
+
+
+__END__
+
+
+
+
+
+
+++ /dev/null
-# This module is part of DA, Don Armstrong's Modules, and is released
-# under the terms of the GPL version 2, or any later version. See the
-# file README and COPYING for more information. Copyright 2003 by Don
-# Armstrong <don@donarmstrong.com>.
-# $Id: Modular.pm,v 1.8 2003/12/09 02:00:10 don Exp $
-
-package Class::Modular;
-
-=head1 NAME
-
-Class::Modular -- Modular class generation superclass
-
-=head1 SYNOPSIS
-
-package Foo::Bar;
-
-@ISA = qw(Class::Modular);
-
-
-=head1 DESCRIPTION
-
-Class::Modular is a superclass for generating modular classes, where
-methods can be added into the class from the perspective of the
-object, rather than the perspective of the class.
-
-That is, you can create a class which has a set of generic common
-functions. Less generic functions can be included or overridden
-without modifying the base classes. This allows for code to be more
-modular, and reduces code duplication.
-
-=over
-
-=item new
-
-new is responsible for blessing and creating a new database superclass.
-
-=item load
-
-load is responsible for loading database plugins
-
-=back
-
-
-=head1 FUNCTIONS
-
-=cut
-
-use strict;
-use vars qw($VERSION $DEBUG);
-
-use Carp;
-
-use Data::Copy qw(deep_copy); # Used for deep copying objects
-
-BEGIN{
- ($VERSION) = q$Revision: 1.8 $ =~ /\$Revision:\s+([^\s+])/;
- $DEBUG = 0 unless defined $DEBUG;
-}
-
-our $AUTOLOAD;
-
-=head2 new
-
- Title : new
- Usage : $obj = Foo::Bar->new();
- Function: Creates a new Foo::Bar object
- Returns : A new Foo::Bar object
- Args : none.
-
- Aditional arguments can be passed to this creator, and they are
- stored in $self->{_creation_args}. You can also override the new
- method in your subclass. It's just provided here for completeness.
-
-=cut
-
-sub new {
- my ($class,@args) = @_;
-
- # We shouldn't be called $me->new, but just in case
- $class = ref($class) || $class;
-
- my $self = {};
- bless $self, $class;
-
- $self->_init(@args);
-
- return $self;
-}
-
-
-=head2 _init
-
-=head3 Usage
-
- $self->_init(@args);
-
-=head3 Function
-
-Stores the arguments used at new so modules that are loaded later can
-read them
-
-=cut
-
-sub _init {
- my ($self,@creation_args) = @_;
-
- $self->{creation_args} = [@_];
-}
-
-
-=head2 load
-
- Title : load
- Usage : $db->load('FOO::Subclass');
- Function: loads a Class::Modular subclass
- Returns : nothing
- Args : SCALAR subclass SCALAR options
-
- Loads the named subclass into this object if the named subclass has
- not been loaded.
-
- The options scalar is passed to $subclass::_methods when determining
- which methods should be added using _addmethods.
-
- The subclasses _init method is called right after methods are loaded.
-
- If debugging is enabled, will warn about loading already loaded
- subclasses.
-
-=cut
-
-
-sub load($$;$) {
- my ($self,$subclass,$options) = @_;
-
- $options ||= {};
-
- # check to see if the subclass has already been loaded.
-
- if (not defined $self->{_subclasses}->{$subclass}){
- eval {
- no strict 'refs';
- eval "require $subclass" or die $@;
- $self->_addmethods($subclass,&{"${subclass}::_methods"}($self,$options));
- &{"${subclass}::_init"}($self);
- };
- die $@ if $@;
- $self->{_subclasses}->{$subclass} = {};
- }
- else {
- carp "Not reloading subclass $subclass" if $DEBUG;
- }
-}
-
-=head2 _addmethods
-
- Title : _addmethods
- Usage : $self->_addmethods()
- Function: Adds the passed methods into the function table
- Returns :
- Args : ARRAY of methods
-
- Given an array of methods, adds the methods into the _methodhash
- calling table.
-
- Methods that have previously been overridden by override are _NOT_
- overridden again. This may need to be adjusted in load.
-
-=cut
-
-sub _addmethods($@) {
- my ($self,$subclass,@methods) = @_;
-
- # stick the method into the table
- # DLA: Make with the munchies!
-
- foreach my $method (@methods) {
- if (not $method =~ /^$subclass/) {
- $method = $subclass.'::'.$method;
- }
- my ($method_name) = $method =~ /\:*([^\:]+)\s*$/;
- if (exists $self->{_methodhash}->{$method_name}) {
- if ($self->{_methodhash}->{$method_name}->{overridden}) {
- carp "Not overriding already overriden method $method_name\n" if $DEBUG;
- next;
- }
- carp "Overriding $method_name $self->{_methodhash}->{$method_name}->{reference} with $method\n";
- }
- $self->{_methodhash}->{$method_name}->{reference} = $method;
- $self->{_methodhash}->{$method_name}->{subclass} = $subclass;
- }
-
-}
-
-=head2 override
-
- Title : override
- Usage : $obj->override('methodname', $code_ref)
- Function: Overrides the method methodname and calls $code_ref instead.
- Returns : TRUE on success, FALSE on failure.
- Args : SCALAR method name
- CODEREF function reference
-
- Allows you to override utility functions that are called internally
- to provide a different default function.
-
- It's superficially similar to _addmethods, which is called by load,
- but it deals with code references, and requires the method name to be
- known.
-
- Methods overridden here are _NOT_ overrideable in _addmethods. This
- may need to be changed.
-
-=cut
-
-sub override {
- my ($self, $method_name, $function_reference) = @_;
-
- $self->{_methodhash}->{$method_name}->{reference} = $function_reference;
- $self->{_methodhash}->{$method_name}->{overridden} = 1;
-}
-
-=head2 clone
-
- Title : clone
- Usage : my $clone = $obj->clone
- Function: Produces a clone of the Class::Modular object
- Returns :
- Args :
-
- Produces a clone of the object with duplicates of all data and/or new
- connections as appropriate.
-
- Calls _clone on all loaded subclasses.
-
- Warns if debugging is on for classes which don't have a _clone
- method. Dies on other errors.
-
-=cut
-
-sub clone {
- my ($self) = @_;
-
- my $clone = {};
- bless $clone, ref($self);
-
- # copy data structures at this level
- $clone->{_methodhash} = deep_copy($self->{_methodhash});
- $clone->{_subclasses} = deep_copy($self->{_subclasses});
-
- foreach my $subclass (keys %{$self->{_subclasses}}) {
- # use eval to try and call the subclasses _clone method.
- # Ignore no such function errors, but trap other types of
- # errors.
-
- # XXX Switch to can instead.
- eval {
- no strict 'refs';
- &$subclass::_clone($self,$clone);
- };
- if ($@) {
- # Die unless we've hit an undefined subroutine.
- die $@ unless $@ =~ /Undefined\s*subroutine\s*\&.*\:\:\_clone/;
- warn "$subclass doesn't have a _clone method\n$@" if $DEBUG;
- }
-
-
- }
-}
-
-=head2 can
-
-=head3 Usage
-
- $obj->can('METHOD');
- Class::Modular->can('METHOD');
-
-=head3 Function
-
-Replaces UNIVERSAL's can method so that handled methods are reported
-correctly. Calls UNIVERSAL::can in the places where we don't know
-anything it doesn't.
-
-=head3 Returns
-
-A coderef to the method if the method is supported, undef otherwise.
-
-=head3 Args
-
-Scalar Method Name
-
-=cut
-
-sub can{
- my ($self,$method,$vars) = @_;
-
- if (ref $self and exists $self->{_methodhash}->{$method}) {
- # If the method is defined, return a reference to the
- # method.
- return $self->{_methodhash}->{$method}->{reference};
- }
- else {
- # Otherwise, let UNIVERSAL::can deal with the method
- # appropriately.
- return UNIVERSAL::can($self,$method);
- }
-}
-
-=head2 handledby
-
-=head3 Usage
-
- $obj->handledby('methodname');
- $obj->handledby('Class::Method::methodname');
-
-=head3 Function
-
-Returns the subclass that handles this method.
-
-=head3 Returns
-
-SCALAR subclass name
-
-=head3 Args
-
-SCALAR method name
-
-=cut
-
-sub handledby{
- my ($self,$method_name) = @_;
-
- $method_name =~ s/.*\://;
-
- if (exists $self->{_methodhash}->{$method_name}) {
- return $self->{_methodhash}->{$method_name}->{subclass};
- }
- return undef;
-}
-
-
-=head2 DESTROY
-
-=head3 Usage
-
-Called by perl.
-
-=head3 Function
-
-Calls all subclass _destroy methods.
-
-Subclasses need only implement a _destroy method if they have
-references that need to be uncircularized, or things that should be
-disconnected or closed.
-
-=cut
-
-sub DESTROY{
- my $self = shift;
- foreach my $subclass (keys %{$self->{_subclasses}}) {
- # use eval to try and call the subclasses _destroy method.
- # Ignore no such function errors, but trap other types of
- # errors.
- eval {
- no strict 'refs';
- &$subclass::_destroy($self);
- };
- if ($@) {
- # Die unless we've hit an undefined subroutine.
- die $@ unless $@ =~ /Undefined\s*subroutine\s*\&.*\:\:\_clone/;
- warn "$subclass doesn't have a _clone method\n$@" if $DEBUG;
- }
- }
-}
-
-
-=head2 AUTOLOAD
-
- Title : AUTOLOAD
- Usage : Called by perl
- Function: Calls child methods which have been installed into this handle
- Returns : N/A
- Args : N/A
-
-The AUTOLOAD function is responsible for calling child methods which
-have been installed into the current Class::Modular handle.
-
-Subclasses that have a new function as well as an AUTOLOAD function
-must call Class::Modular::AUTOLOAD and set $Class::Modular::AUTOLOAD
-
- $Class::Modular::AUTOLOAD = $AUTOLOAD;
- goto &Class::Modular::AUTOLOAD;
-
-=cut
-
-sub AUTOLOAD{
- my $method = $AUTOLOAD;
-
- $method =~ s/.*\://;
-
- my ($self) = @_;
-
- if (not ref($self)) {
- carp "Not a reference in AUTOLOAD.";
- return;
- }
-
- if (exists $self->{_methodhash}->{$method} and
- defined $self->{_methodhash}->{$method}->{reference}) {
- eval {
- no strict 'refs';
- goto &{$self->{_methodhash}{$method}{reference}};
- }
- }
- else {
- croak "Undefined function $AUTOLOAD";
- }
-}
-
-
-1;
-
-
-__END__
-
-
-
-
-
-
projects / class_modular.git / .git / commitdiff