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.5 2003/10/25 02:15:04 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 FUNCTIONS
  45
  46 =cut
  47
  48 use strict;
  49 use vars qw($VERSION $DEBUG);
  50
  51 use Carp;
  52
  53 use Data::Copy qw(deep_copy); # Used for deep copying objects
  54
  55 BEGIN{
  56      ($VERSION) = q$Revision: 1.5 $ =~ /\$Revision:\s+([^\s+])/;
  57      $DEBUG = 0 unless defined $DEBUG;
  58 }
  59
  60 our $AUTOLOAD;
  61
  62 =head2 new
  63
  64  Title   : new
  65  Usage   : $obj = Foo::Bar->new();
  66  Function: Creates a new Foo::Bar object
  67  Returns : A new Foo::Bar object
  68  Args    : none.
  69
  70  Aditional arguments can be passed to this creator, and they are
  71  stored in $self->{_creation_args}. You can also override the new
  72  method in your subclass. It's just provided here for completeness.
  73
  74 =cut
  75
  76 sub new {
  77      my ($class,@args) = @_;
  78
  79      # We shouldn't be called $me->new, but just in case
  80      $class = ref($class) || $class;
  81
  82      my $self = {};
  83      bless $self, $class;
  84
  85      $self->{_creation_args} = [@args];
  86
  87      return $self;
  88 }
  89
  90
  91 =head2 load
  92
  93  Title   : load
  94  Usage   : $db->load('FOO::Subclass');
  95  Function: loads a Class::Modular subclass
  96  Returns : nothing
  97  Args    : SCALAR subclass SCALAR options
  98
  99  Loads the named subclass into this object if the named subclass has
 100  not been loaded.
 101
 102  The options scalar is passed to $subclass::_methods when determining
 103  which methods should be added using _addmethods.
 104
 105  The subclasses _init method is called right after methods are loaded.
 106
 107  If debugging is enabled, will warn about loading already loaded
 108  subclasses.
 109
 110 =cut
 111
 112
 113 sub load($$;$) {
 114      my ($self,$subclass,$options) = @_;
 115
 116      $options ||= {};
 117
 118      # check to see if the subclass has already been loaded.
 119
 120      if (not defined $self->{_subclasses}->{$subclass}){
 121           eval {
 122                no strict 'refs';
 123                $self->_addmethods($subclass,&{"${subclass}::_methods"}($self,$options));
 124                &{"${subclass}::_init"}($self);
 125           };
 126           warn $@ if $@;
 127           $self->{_subclasses}->{$subclass} = {};
 128      }
 129      else {
 130           carp "Not reloading subclass $subclass" if $DEBUG;
 131      }
 132 }
 133
 134 =head2 _addmethods
 135
 136  Title   : _addmethods
 137  Usage   : $self->_addmethods()
 138  Function: Adds the passed methods into the function table
 139  Returns :
 140  Args    : ARRAY of methods
 141
 142  Given an array of methods, adds the methods into the _methodhash
 143  calling table.
 144
 145  Methods that have previously been overridden by override are _NOT_
 146  overridden again. This may need to be adjusted in load.
 147
 148 =cut
 149
 150 sub _addmethods($@) {
 151      my ($self,$subclass,@methods) = @_;
 152
 153      # stick the method into the table
 154      # DLA: Make with the munchies!
 155
 156      foreach my $method (@methods) {
 157           if (not $method =~ /^$subclass/) {
 158                $method = $subclass.$method;
 159           }
 160           my ($method_name) = $method =~ /\:*([^\:]+)\s*$/;
 161           if (exists $self->{_methodhash}->{$method_name}) {
 162                if ($self->{_methodhash}->{$method_name}->{overridden}) {
 163                     carp "Not overriding already overriden method $method_name\n" if $DEBUG;
 164                     next;
 165                }
 166                carp "Overriding $method_name $self->{_methodhash}->{$method_name}->{reference} with $method\n";
 167           }
 168           $self->{_methodhash}->{$method_name}->{reference} = $method;
 169      }
 170
 171 }
 172
 173 =head2 override
 174
 175  Title   : override
 176  Usage   : $obj->override('methodname', $code_ref)
 177  Function: Overrides the method methodname and calls $code_ref instead.
 178  Returns : TRUE on success, FALSE on failure.
 179  Args    : SCALAR method name
 180            CODEREF function reference
 181
 182  Allows you to override utility functions that are called internally
 183  to provide a different default function.
 184
 185  It's superficially similar to _addmethods, which is called by load,
 186  but it deals with code references, and requires the method name to be
 187  known.
 188
 189  Methods overridden here are _NOT_ overrideable in _addmethods. This
 190  may need to be changed.
 191
 192 =cut
 193
 194 sub override {
 195      my ($self, $method_name, $function_reference) = @_;
 196
 197      $self->{_methodhash}->{$method_name}->{reference} = $function_reference;
 198      $self->{_methodhash}->{$method_name}->{overridden} = 1;
 199 }
 200
 201 =head2 clone
 202
 203  Title   : clone
 204  Usage   : my $clone  = $obj->clone
 205  Function: Produces a clone of the Class::Modular object
 206  Returns :
 207  Args    :
 208
 209  Produces a clone of the object with duplicates of all data and/or new
 210  connections as appropriate.
 211
 212  Calls _clone on all loaded subclasses.
 213
 214  Warns if debugging is on for classes which don't have a _clone
 215  method.  Dies on other errors.
 216
 217 =cut
 218
 219 sub clone {
 220      my ($self) = @_;
 221
 222      my $clone = {};
 223      bless $clone, ref($self);
 224
 225      # copy data structures at this level
 226      $clone->{_methodhash} = deep_copy($self->{_methodhash});
 227      $clone->{_subclasses} = deep_copy($self->{_subclasses});
 228
 229      foreach my $subclass (keys %{$self->{_subclasses}}) {
 230           # use eval to try and call the subclasses _clone method.
 231           # Ignore no such function errors, but trap other types of
 232           # errors.
 233
 234           # XXX Switch to can instead.
 235           eval {
 236                no strict 'refs';
 237                &$subclass::_clone($self,$clone);
 238           };
 239           if ($@) {
 240                # Die unless we've hit an undefined subroutine.
 241                die $@ unless $@ =~ /Undefined\s*subroutine\s*\&.*\:\:\_clone/;
 242                warn "$subclass doesn't have a _clone method\n$@" if $DEBUG;
 243           }
 244
 245
 246      }
 247 }
 248
 249 =head2 can
 250
 251 =head3 Usage
 252
 253      $obj->can('METHOD');
 254      Class::Modular->can('METHOD');
 255
 256 =head3 Function
 257
 258 Replaces UNIVERSAL's can method so that handled methods are reported
 259 correctly. Calls UNIVERSAL::can in the places where
 260
 261 =head3 Returns
 262
 263 A coderef to the method if the method is supported, undef otherwise.
 264
 265 =head3 Args
 266
 267 Scalar Method Name
 268
 269 =cut
 270
 271 sub can{
 272      my ($self,$method,$vars) = @_;
 273
 274      if (ref $self and exists $self->{_methodhash}->{$method}) {
 275           # If the method is defined, return a reference to the
 276           # method.
 277           return $self->{_methodhash}->{$method}->{reference};
 278      }
 279      else {
 280           # Otherwise, let UNIVERSAL::can deal with the method
 281           # appropriately.
 282           return UNIVERSAL::can($self,$method);
 283      }
 284 }
 285
 286
 287 =head2 DESTROY
 288
 289 =head3 Usage
 290
 291 Called by perl.
 292
 293 =head3 Function
 294
 295 Calls all subclass _destroy methods.
 296
 297 Subclasses need only implement a _destroy method if they have
 298 references that need to be uncircularized, or things that should be
 299 disconnected or closed.
 300
 301 =cut
 302
 303 sub DESTROY{
 304      my $self = shift;
 305      foreach my $subclass (keys %{$self->{_subclasses}}) {
 306           # use eval to try and call the subclasses _destroy method.
 307           # Ignore no such function errors, but trap other types of
 308           # errors.
 309           eval {
 310                no strict 'refs';
 311                &$subclass::_destroy($self);
 312           };
 313           if ($@) {
 314                # Die unless we've hit an undefined subroutine.
 315                die $@ unless $@ =~ /Undefined\s*subroutine\s*\&.*\:\:\_clone/;
 316                warn "$subclass doesn't have a _clone method\n$@" if $DEBUG;
 317           }
 318      }
 319 }
 320
 321
 322 =head2 AUTOLOAD
 323
 324  Title   : AUTOLOAD
 325  Usage   : Called by perl
 326  Function: Calls child methods which have been installed into this handle
 327  Returns : N/A
 328  Args    : N/A
 329
 330 The AUTOLOAD function is responsible for calling child methods which
 331 have been installed into the current Class::Modular handle.
 332
 333 Subclasses that have a new function as well as an AUTOLOAD function
 334 must call Class::Modular::AUTOLOAD and set $Class::Modular::AUTOLOAD
 335
 336      $Class::Modular::AUTOLOAD = $AUTOLOAD;
 337      goto &Class::Modular::AUTOLOAD;
 338
 339 =cut
 340
 341 sub AUTOLOAD{
 342      my $method = $AUTOLOAD;
 343
 344      $method =~ s/.*\://;
 345
 346      my ($self) = @_;
 347
 348      if (not ref($self)) {
 349          carp "Not a reference in AUTOLOAD.";
 350          return;
 351      }
 352
 353      if (defined $self->{_methodhash}->{$method}->{reference}) {
 354           eval {
 355                no strict 'refs';
 356                goto &$self->{_methodhash}->{$method}->{reference};
 357           }
 358      }
 359 }
 360
 361
 362 1;
 363
 364
 365 __END__
 366
 367
 368
 369
 370
 371