From: Don Armstrong Date: Tue, 29 Jun 2004 10:29:33 +0000 (+0000) Subject: * Module tests now work correctly X-Git-Url: https://git.donarmstrong.com/?p=class_modular.git%2F.git;a=commitdiff_plain;h=7d57528ea18f57f1893e1944dbff1d747ff8d012 * Module tests now work correctly * Cleaned up Class::Modular documentaiton * Stopped improperly using can git-svn-id: file:///srv/don_svn/class_modular/trunk@20 96c6a18b-02ce-0310-9fca-9eb62c757ba6 --- diff --git a/lib/Class/Modular.pm b/lib/Class/Modular.pm index f66c520..9197583 100644 --- a/lib/Class/Modular.pm +++ b/lib/Class/Modular.pm @@ -1,7 +1,7 @@ -# This file is part of Class::Modular and is released under the terms -# of the GPL version 2, or any later version at your option. See the -# file README and COPYING for more information. -# Copyright 2003, 2004 by Don Armstrong . +# 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 . # $Id$ package Class::Modular; @@ -12,10 +12,19 @@ Class::Modular -- Modular class generation superclass =head1 SYNOPSIS - package Foo::Bar; + package Foo; use base qw(Class::Modular); + [...] + + use Foo; + + $foo = new Foo; + $foo->load('Bar'); + $foo->method_that_bar_provides; + + =head1 DESCRIPTION Class::Modular is a superclass for generating modular classes, where @@ -27,10 +36,6 @@ 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. -It fills the middle ground between traditional class based OOP and -classless OOP. L and L are similar to -Class::Modular but less manic. - =head1 FUNCTIONS =cut @@ -48,8 +53,73 @@ BEGIN{ $DEBUG = 0 unless defined $DEBUG; } +# This is the class_modular namespace, so we don't muck up the +# subclass(es) by accident. + +my $cm = q(__class_modular); + our $AUTOLOAD; +=head2 new + +=head3 Usage + + $obj = Foo::Bar->new(); + +=head3 Function + +Creates a new Foo::Bar object + +Aditional arguments can be passed to this creator, and they are stored +in $self->{creation_args} (and $self->{$cm}{creation_args} by +_init. 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 from B + +You can also override this method, but if you do so, you should call +Class::Modular::_init(@_) if you don't set creation_args. + +=cut + +sub _init { + my ($self,@creation_args) = @_; + + my $creation_args = [@_]; + $self->{creation_args} = $creation_args if not exists $self->{creation_args}; + + # Make another reference to this, so we can get it if a subclass + # overwrites it, or if it was already set for some reason + $self->{$cm}->{creation_args} = $creation_args; +} + + =head2 load =head3 Usage @@ -79,35 +149,74 @@ sub load($$;$) { # check to see if the subclass has already been loaded. - if (not defined $self->{_subclasses}->{$subclass}){ + if (not defined $self->{$cm}{_subclasses}->{$subclass}){ eval { no strict 'refs'; + # Yeah, I don't care if calling an inherited AUTOLOAD + # for a non method is deprecated. Bite me. + no warnings 'deprecated'; eval "require $subclass" or die $@; - my @methods = (); - if (UNIVERSAL::can($subclass,'METHODS')) { - push @methods,&{"${subclass}::METHODS"}; - } - elsif (UNIVERSAL::can($subclass,'METHODS')) { - push @methods,&{"${subclass}::_methods"}; - } - $self->_addmethods($subclass,@methods); - my $initref = UNIVERSAL::can($subclass,'_init'); - &$initref($self,$options) if defined $initref; + $self->_addmethods($subclass,&{"${subclass}::_methods"}($self,$options)); + &{"${subclass}::_init"}($self); }; - die $@ if $@; - $self->{_subclasses}->{$subclass} = {}; + die $@ if $@ and $@ !~ /^Undefined function ${subclass}::_init at [^\n]*$/; + $self->{$cm}{_subclasses}->{$subclass} = {}; } else { carp "Not reloading subclass $subclass" if $DEBUG; } } -=head2 override +=head2 _addmethods =head3 Usage + $self->_addmethods() + +=head3 Function + +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->{$cm}{_methodhash}->{$method_name}) { + if ($self->{$cm}{_methodhash}->{$method_name}->{overridden}) { + carp "Not overriding already overriden method $method_name\n" if $DEBUG; + next; + } + carp "Overriding $method_name $self->{$cm}{_methodhash}->{$method_name}->{reference} with $method\n"; + } + $self->{$cm}{_methodhash}->{$method_name}->{reference} = $method; + $self->{$cm}{_methodhash}->{$method_name}->{subclass} = $subclass; + } + +} + +=head2 override + +=head3 Function + $obj->override('methodname', $code_ref) +=head3 Returns + +TRUE on success, FALSE on failure. + =head3 Function Allows you to override utility functions that are called internally to @@ -125,8 +234,8 @@ may need to be changed. sub override { my ($self, $method_name, $function_reference) = @_; - $self->{_methodhash}->{$method_name}->{reference} = $function_reference; - $self->{_methodhash}->{$method_name}->{overridden} = 1; + $self->{$cm}{_methodhash}->{$method_name}->{reference} = $function_reference; + $self->{$cm}{_methodhash}->{$method_name}->{overridden} = 1; } =head2 clone @@ -142,8 +251,8 @@ 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. +Warns if debugging is on for classes which don't have a _clone +method. Dies on other errors. =cut @@ -154,26 +263,29 @@ sub clone { bless $clone, ref($self); # copy data structures at this level - $clone->{_methodhash} = dclone($self->{_methodhash}); - $clone->{_subclasses} = dclone($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. + $clone->{$cm}{_methodhash} = dclone($self->{$cm}{_methodhash}); + $clone->{$cm}{_subclasses} = dclone($self->{$cm}{_subclasses}); - # XXX Switch to can instead. + foreach my $subclass (keys %{$self->{$cm}{_subclasses}}) { + # Find out if the subclass has a clone method. + # If it does, call it, die on errors. + my $function = UNIVERSAL::can($subclass, '_clone'); eval { no strict 'refs'; + # No, I could care less that AUTOLOAD is + # deprecated. Eat me. + no warnings 'deprecated'; &{"${subclass}::_clone"}($self,$clone); }; if ($@) { # Die unless we've hit an undefined subroutine. - die $@ unless $@ =~ /Undefined\s*function\s*.*\:\:\_clone/; - warn "$subclass doesn't have a _clone method\n$@" if $DEBUG; + if ($@ !~ /^Undefined function ${subclass}::_clone at [^\n]*$/){ + die "Failed while trying to clone: $@"; + } + else { + carp "No _clone method defined for $subclass" if $DEBUG; + } } - - } } @@ -203,10 +315,12 @@ Scalar Method Name sub can{ my ($self,$method,$vars) = @_; - if (ref $self and exists $self->{_methodhash}->{$method}) { + croak "Usage: can(object-ref, method, [vars]);\n" if not defined $method; + + if (ref $self and exists $self->{$cm}{_methodhash}->{$method}) { # If the method is defined, return a reference to the # method. - return $self->{_methodhash}->{$method}->{reference}; + return $self->{$cm}{_methodhash}->{$method}->{reference}; } else { # Otherwise, let UNIVERSAL::can deal with the method @@ -241,114 +355,12 @@ sub handledby{ $method_name =~ s/.*\://; - if (exists $self->{_methodhash}->{$method_name}) { - return $self->{_methodhash}->{$method_name}->{subclass}; + if (exists $self->{$cm}{_methodhash}->{$method_name}) { + return $self->{$cm}{_methodhash}->{$method_name}->{subclass}; } return undef; } -=head1 INTERNAL FUNCTIONS - -The functions below are functions internal to Class::Modular. The -first two, new and _init should probably be overriden in any class -that inherits from Class::Modular, but they are provided just in case -you don't want to write a new and/or _init. - -=cut - -=head2 new - -=head3 Usage - - $obj = Foo::Bar->new(); - -=head3 Function - -Creates a new C object. - -Aditional arguments can be passed to this creator, and they are stored -in C<$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 - -This function is called by default from new. Classes may only wish to -override _init. - -=cut - -sub _init { - my ($self,@creation_args) = @_; - - $self->{creation_args} = [@creation_args]; -} - - -=head2 _addmethods - -=head3 Usage - - $self->_addmethods($subclass,&{"${subclass}::_methods"}($self,$options)); - -=head3 Function - -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 DESTROY @@ -366,24 +378,30 @@ disconnected or closed. =cut - - sub DESTROY{ my $self = shift; - foreach my $subclass (keys %{$self->{_subclasses}}) { + foreach my $subclass (keys %{$self->{$cm}{_subclasses}}) { # use eval to try and call the subclasses _destroy method. # Ignore no such function errors, but trap other types of # errors. - my $destroy_func = UNIVERSAL::can($subclass,'_destroy'); - &$destroy_func($self) if defined $destroy_func; + eval { + no strict 'refs'; + &{"${subclass}::_destroy"}($self); + }; + if ($@) { + if ($@ !~ /^Undefined function ${subclass}::_destroy at [^\n]*$/){ + die "Failed while trying to destroy: $@"; + } + else { + carp "No _destroy method defined for $subclass" if $DEBUG; + } + } } } =head2 AUTOLOAD -=head3 Function - The AUTOLOAD function is responsible for calling child methods which have been installed into the current Class::Modular handle. @@ -407,11 +425,11 @@ sub AUTOLOAD{ return; } - if (exists $self->{_methodhash}->{$method} and - defined $self->{_methodhash}->{$method}->{reference}) { + if (exists $self->{$cm}{_methodhash}->{$method} and + defined $self->{$cm}{_methodhash}->{$method}->{reference}) { eval { no strict 'refs'; - goto &{$self->{_methodhash}{$method}{reference}}; + goto &{$self->{$cm}{_methodhash}{$method}{reference}}; } } else { diff --git a/t/01_module.t b/t/01_module.t index e2711c5..20f4618 100644 --- a/t/01_module.t +++ b/t/01_module.t @@ -23,6 +23,10 @@ my $destroy_hit = 0; return 1; } + sub _methods { + return qw(blah); + } + sub _destroy{ $destroy_hit = 1; } @@ -36,7 +40,7 @@ ok(defined $foo and ref($foo) eq 'Foo' and UNIVERSAL::isa($foo,'Class::Modular') $foo->load('Foo'); # 2: test load() -ok(exists $foo->{_subclasses}{Foo}, 'load() works'); +ok(exists $foo->{__class_modular}{_subclasses}{Foo}, 'load() works'); # 3: test AUTOLOAD ok($foo->blah, 'AUTOLOAD works');