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.6 2003/10/25 03:01:35 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.6 $ =~ /\$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           $self->{_methodhash}->{$method_name}->{subclass} = $subclass;
 170      }
 171
 172 }
 173
 174 =head2 override
 175
 176  Title   : override
 177  Usage   : $obj->override('methodname', $code_ref)
 178  Function: Overrides the method methodname and calls $code_ref instead.
 179  Returns : TRUE on success, FALSE on failure.
 180  Args    : SCALAR method name
 181            CODEREF function reference
 182
 183  Allows you to override utility functions that are called internally
 184  to provide a different default function.
 185
 186  It's superficially similar to _addmethods, which is called by load,
 187  but it deals with code references, and requires the method name to be
 188  known.
 189
 190  Methods overridden here are _NOT_ overrideable in _addmethods. This
 191  may need to be changed.
 192
 193 =cut
 194
 195 sub override {
 196      my ($self, $method_name, $function_reference) = @_;
 197
 198      $self->{_methodhash}->{$method_name}->{reference} = $function_reference;
 199      $self->{_methodhash}->{$method_name}->{overridden} = 1;
 200 }
 201
 202 =head2 clone
 203
 204  Title   : clone
 205  Usage   : my $clone  = $obj->clone
 206  Function: Produces a clone of the Class::Modular object
 207  Returns :
 208  Args    :
 209
 210  Produces a clone of the object with duplicates of all data and/or new
 211  connections as appropriate.
 212
 213  Calls _clone on all loaded subclasses.
 214
 215  Warns if debugging is on for classes which don't have a _clone
 216  method.  Dies on other errors.
 217
 218 =cut
 219
 220 sub clone {
 221      my ($self) = @_;
 222
 223      my $clone = {};
 224      bless $clone, ref($self);
 225
 226      # copy data structures at this level
 227      $clone->{_methodhash} = deep_copy($self->{_methodhash});
 228      $clone->{_subclasses} = deep_copy($self->{_subclasses});
 229
 230      foreach my $subclass (keys %{$self->{_subclasses}}) {
 231           # use eval to try and call the subclasses _clone method.
 232           # Ignore no such function errors, but trap other types of
 233           # errors.
 234
 235           # XXX Switch to can instead.
 236           eval {
 237                no strict 'refs';
 238                &$subclass::_clone($self,$clone);
 239           };
 240           if ($@) {
 241                # Die unless we've hit an undefined subroutine.
 242                die $@ unless $@ =~ /Undefined\s*subroutine\s*\&.*\:\:\_clone/;
 243                warn "$subclass doesn't have a _clone method\n$@" if $DEBUG;
 244           }
 245
 246
 247      }
 248 }
 249
 250 =head2 can
 251
 252 =head3 Usage
 253
 254      $obj->can('METHOD');
 255      Class::Modular->can('METHOD');
 256
 257 =head3 Function
 258
 259 Replaces UNIVERSAL's can method so that handled methods are reported
 260 correctly. Calls UNIVERSAL::can in the places where
 261
 262 =head3 Returns
 263
 264 A coderef to the method if the method is supported, undef otherwise.
 265
 266 =head3 Args
 267
 268 Scalar Method Name
 269
 270 =cut
 271
 272 sub can{
 273      my ($self,$method,$vars) = @_;
 274
 275      if (ref $self and exists $self->{_methodhash}->{$method}) {
 276           # If the method is defined, return a reference to the
 277           # method.
 278           return $self->{_methodhash}->{$method}->{reference};
 279      }
 280      else {
 281           # Otherwise, let UNIVERSAL::can deal with the method
 282           # appropriately.
 283           return UNIVERSAL::can($self,$method);
 284      }
 285 }
 286
 287 =head2 handledby
 288
 289 =head3 Usage
 290
 291      $obj->handledby('methodname');
 292      $obj->handledby('Class::Method::methodname');
 293
 294 =head3 Function
 295
 296 Returns the subclass that handles this method.
 297
 298 =head3 Returns
 299
 300 SCALAR subclass name
 301
 302 =head3 Args
 303
 304 SCALAR method name
 305
 306 =cut
 307
 308 sub handledby{
 309      my ($self,$method_name) = @_;
 310
 311      $method_name =~ s/.*\://;
 312
 313      if (exists $self->{_methodhash}->{$method_name}) {
 314           return $self->{_methodhash}->{$method_name}->{subclass};
 315      }
 316      return undef;
 317 }
 318
 319
 320 =head2 DESTROY
 321
 322 =head3 Usage
 323
 324 Called by perl.
 325
 326 =head3 Function
 327
 328 Calls all subclass _destroy methods.
 329
 330 Subclasses need only implement a _destroy method if they have
 331 references that need to be uncircularized, or things that should be
 332 disconnected or closed.
 333
 334 =cut
 335
 336 sub DESTROY{
 337      my $self = shift;
 338      foreach my $subclass (keys %{$self->{_subclasses}}) {
 339           # use eval to try and call the subclasses _destroy method.
 340           # Ignore no such function errors, but trap other types of
 341           # errors.
 342           eval {
 343                no strict 'refs';
 344                &$subclass::_destroy($self);
 345           };
 346           if ($@) {
 347                # Die unless we've hit an undefined subroutine.
 348                die $@ unless $@ =~ /Undefined\s*subroutine\s*\&.*\:\:\_clone/;
 349                warn "$subclass doesn't have a _clone method\n$@" if $DEBUG;
 350           }
 351      }
 352 }
 353
 354
 355 =head2 AUTOLOAD
 356
 357  Title   : AUTOLOAD
 358  Usage   : Called by perl
 359  Function: Calls child methods which have been installed into this handle
 360  Returns : N/A
 361  Args    : N/A
 362
 363 The AUTOLOAD function is responsible for calling child methods which
 364 have been installed into the current Class::Modular handle.
 365
 366 Subclasses that have a new function as well as an AUTOLOAD function
 367 must call Class::Modular::AUTOLOAD and set $Class::Modular::AUTOLOAD
 368
 369      $Class::Modular::AUTOLOAD = $AUTOLOAD;
 370      goto &Class::Modular::AUTOLOAD;
 371
 372 =cut
 373
 374 sub AUTOLOAD{
 375      my $method = $AUTOLOAD;
 376
 377      $method =~ s/.*\://;
 378
 379      my ($self) = @_;
 380
 381      if (not ref($self)) {
 382          carp "Not a reference in AUTOLOAD.";
 383          return;
 384      }
 385
 386      if (defined $self->{_methodhash}->{$method}->{reference}) {
 387           eval {
 388                no strict 'refs';
 389                goto &$self->{_methodhash}->{$method}->{reference};
 390           }
 391      }
 392 }
 393
 394
 395 1;
 396
 397
 398 __END__
 399
 400
 401
 402
 403
 404