Class/Modular/Modular.pm

   1 # This module is part of DA, Don Armstrong's Modules, and is released
   2 # under the terms of the GPL version 2, or any later version. See the
   3 # file README and COPYING for more information. Copyright 2003 by Don
   4 # Armstrong <don@donarmstrong.com>.
   5 # $Id: Modular.pm,v 1.3 2003/09/13 05:46:53 don Exp $
   6
   7 package Class::Modular;
   8
   9 =head1 NAME
  10
  11 Class::Modular -- Modular class generation superclass
  12
  13 =head1 SYNOPSIS
  14
  15 package Foo::Bar;
  16
  17 @ISA = qw(Class::Modular);
  18
  19
  20 =head1 DESCRIPTION
  21
  22 Class::Modular is a superclass for generating modular classes, where
  23 methods can be added into the class from the perspective of the
  24 object, rather than the perspective of the class.
  25
  26 That is, you can create a class which has a set of generic common
  27 functions. Less generic functions can be included or overridden
  28 without modifying the base classes. This allows for code to be more
  29 modular, and reduces code duplication.
  30
  31 =over
  32
  33 =item new
  34
  35 new is responsible for blessing and creating a new database superclass.
  36
  37 =item load
  38
  39 load is responsible for loading database plugins
  40
  41 =back
  42
  43
  44 =head1 BUGS
  45
  46 None known.
  47
  48 =cut
  49
  50 use strict;
  51 use vars qw($VERSION $DEBUG);
  52
  53 use Carp;
  54
  55 use Data::Copy qw(deep_copy); # Used for deep copying objects
  56
  57 BEGIN{
  58      ($VERSION) = q$Revision: 1.3 $ =~ /\$Revision:\s+([^\s+])/;
  59      $DEBUG = 0 unless defined $DEBUG;
  60 }
  61
  62 our $AUTOLOAD;
  63
  64 =head2 new
  65
  66  Title   : new
  67  Usage   : $obj = Foo::Bar->new();
  68  Function: Creates a new Foo::Bar object
  69  Returns : A new Foo::Bar object
  70  Args    : none.
  71
  72  Aditional arguments can be passed to this creator, and they are
  73  stored in $self->{_creation_args}. You can also override the new
  74  method in your subclass. It's just provided here for completeness.
  75
  76 =cut
  77
  78 sub new {
  79      my ($class,@args) = @_;
  80
  81      # We shouldn't be called $me->new, but just in case
  82      $class = ref($class) || $class;
  83
  84      my $self = {};
  85      bless $self, $class;
  86
  87      $self->{_creation_args} = [@args];
  88
  89      return $self;
  90 }
  91
  92
  93 =head2 load
  94
  95  Title   : load
  96  Usage   : $db->load('FOO::Subclass');
  97  Function: loads a Class::Modular subclass
  98  Returns : nothing
  99  Args    : SCALAR subclass SCALAR options
 100
 101  Loads the named subclass into this object if the named subclass has
 102  not been loaded.
 103
 104  The options scalar is passed to $subclass::_methods when determining
 105  which methods should be added using _addmethods.
 106
 107  The subclasses _init method is called right after methods are loaded.
 108
 109  If debugging is enabled, will warn about loading already loaded
 110  subclasses.
 111
 112 =cut
 113
 114
 115 sub load($$;$) {
 116      my ($self,$subclass,$options) = @_;
 117
 118      $options ||= {};
 119
 120      # check to see if the subclass has already been loaded.
 121
 122      if (not defined $self->{_subclasses}->{$subclass}){
 123           eval {
 124                no strict 'refs';
 125                $self->_addmethods($subclass::_methods($self,$options));
 126                $subclass::_init($self);
 127           };
 128           warn $@ if $@;
 129           $self->{_subclasses}->{$subclass} = {};
 130      }
 131      else {
 132           carp "Not reloading subclass $subclass" if $DEBUG;
 133      }
 134 }
 135
 136 =head2 _addmethods
 137
 138  Title   : _addmethods
 139  Usage   : $self->_addmethods()
 140  Function: Adds the passed methods into the function table
 141  Returns :
 142  Args    : ARRAY of methods
 143
 144  Given an array of methods, adds the methods into the _methodhash
 145  calling table.
 146
 147  Methods that have previously been overridden by override are _NOT_
 148  overridden again. This may need to be adjusted in load.
 149
 150 =cut
 151
 152 sub _addmethods($@) {
 153      my ($self,@methods) = @_;
 154
 155      # stick the method into the table
 156      # DLA: Make with the munchies!
 157
 158      foreach my $method (@methods) {
 159           my ($method_name) = $method =~ /\:*([^\:]+)$/;
 160           if ($self->{_methodhash}->{$method_name}->{overridden}) {
 161                carp "Not overriding already overriden method $method_name\n" if $DEBUG;
 162                next;
 163           }
 164           if (exists $self->{_methodhash}->{$method_name}) {
 165                carp "Overriding $method_name $self->{_methodhash}->{$method_name}->{reference} with $method\n";
 166           }
 167           $self->{_methodhash}->{$method_name}->{reference} = $method;
 168      }
 169
 170 }
 171
 172 =head2 override
 173
 174  Title   : override
 175  Usage   : $obj->override('methodname', $code_ref)
 176  Function: Overrides the method methodname and calls $code_ref instead.
 177  Returns : TRUE on success, FALSE on failure.
 178  Args    : SCALAR method name
 179            CODEREF function reference
 180
 181  Allows you to override utility functions that are called internally
 182  to provide a different default function.
 183
 184  It's superficially similar to _addmethods, which is called by load,
 185  but it deals with code references, and requires the method name to be
 186  known.
 187
 188  Methods overridden here are _NOT_ overrideable in _addmethods. This
 189  may need to be changed.
 190
 191 =cut
 192
 193 sub override {
 194      my ($self, $method_name, $function_reference) = @_;
 195
 196      $self->{_methodhash}->{$method_name}->{reference} = $function_reference;
 197      $self->{_methodhash}->{$method_name}->{overridden} = 1;
 198 }
 199
 200 =head2 clone
 201
 202  Title   : clone
 203  Usage   : my $clone  = $obj->clone
 204  Function: Produces a clone of the Class::Modular object
 205  Returns :
 206  Args    :
 207
 208  Produces a clone of the object with duplicates of all data and/or new
 209  connections as appropriate.
 210
 211  Calls _clone on all loaded subclasses.
 212
 213  Warns if debugging is on for classes which don't have a _clone
 214  method.  Dies on other errors.
 215
 216 =cut
 217
 218 sub clone {
 219      my ($self) = @_;
 220
 221      my $clone = {};
 222      bless $clone, ref($self);
 223
 224      # copy data structures at this level
 225      $clone->{_methodhash} = deep_copy($self->{_methodhash});
 226      $clone->{_subclasses} = deep_copy($self->{_subclasses});
 227
 228      foreach my $subclass (keys %{$self->{_subclasses}}) {
 229           # use eval to try and call the subclasses _clone method.
 230           # Ignore no such function errors, but trap other types of
 231           # errors.
 232
 233           eval {
 234                no strict refs;
 235                &$subclass::_clone($self,$clone);
 236           };
 237           if ($@) {
 238                # Die unless we've hit an undefined subroutine.
 239                die $@ unless $@ =~ /Undefined\s*subroutine\s*\&.*\:\:\_clone/;
 240                warn "$subclass doesn't have a _clone method\n$@" if $DEBUG;
 241           }
 242
 243
 244      }
 245 }
 246
 247
 248 =head2 DESTROY
 249
 250 =head3 Usage
 251
 252 Called by perl.
 253
 254 =head3 Function
 255
 256 Calls all subclass _destroy methods.
 257
 258 Subclasses need only implement a _destroy method if they have
 259 references that need to be uncircularized, or things that should be
 260 disconnected or closed.
 261
 262 =cut
 263
 264 sub DESTROY{
 265      my $self = shift;
 266      foreach my $subclass (keys %{$self->{_subclasses}}) {
 267           # use eval to try and call the subclasses _destroy method.
 268           # Ignore no such function errors, but trap other types of
 269           # errors.
 270           eval {
 271                no strict refs;
 272                &$subclass::_destroy($self,$clone);
 273           };
 274           if ($@) {
 275                # Die unless we've hit an undefined subroutine.
 276                die $@ unless $@ =~ /Undefined\s*subroutine\s*\&.*\:\:\_clone/;
 277                warn "$subclass doesn't have a _clone method\n$@" if $DEBUG;
 278           }
 279      }
 280 }
 281
 282
 283 =head2 AUTOLOAD
 284
 285  Title   : AUTOLOAD
 286  Usage   : Called by perl
 287  Function: Calls child methods which have been installed into this handle
 288  Returns : N/A
 289  Args    : N/A
 290
 291  The AUTOLOAD function is responsible for calling child methods which
 292  have been installed into the current Class::Modular handle.
 293
 294 =cut
 295
 296 sub AUTOLOAD{
 297      my $method = $AUTOLOAD;
 298
 299      $method =~ s/.*\://;
 300
 301      my ($self) = @_;
 302
 303      if (not ref($self)) {
 304          carp "Not a reference in AUTOLOAD.";
 305          return;
 306      }
 307
 308      if (defined $self->{_methodhash}->{$method}->{reference}) {
 309           eval {
 310                no strict 'refs';
 311                goto &$self->{_methodhash}->{$method}->{reference};
 312           }
 313      }
 314 }
 315
 316
 317 1;
 318
 319
 320 __END__
 321
 322
 323
 324
 325
 326