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.7 2003/11/05 04:55:14 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.7 $ =~ /\$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 we don't know
 261 anything it doesn't.
 262
 263 =head3 Returns
 264
 265 A coderef to the method if the method is supported, undef otherwise.
 266
 267 =head3 Args
 268
 269 Scalar Method Name
 270
 271 =cut
 272
 273 sub can{
 274      my ($self,$method,$vars) = @_;
 275
 276      if (ref $self and exists $self->{_methodhash}->{$method}) {
 277           # If the method is defined, return a reference to the
 278           # method.
 279           return $self->{_methodhash}->{$method}->{reference};
 280      }
 281      else {
 282           # Otherwise, let UNIVERSAL::can deal with the method
 283           # appropriately.
 284           return UNIVERSAL::can($self,$method);
 285      }
 286 }
 287
 288 =head2 handledby
 289
 290 =head3 Usage
 291
 292      $obj->handledby('methodname');
 293      $obj->handledby('Class::Method::methodname');
 294
 295 =head3 Function
 296
 297 Returns the subclass that handles this method.
 298
 299 =head3 Returns
 300
 301 SCALAR subclass name
 302
 303 =head3 Args
 304
 305 SCALAR method name
 306
 307 =cut
 308
 309 sub handledby{
 310      my ($self,$method_name) = @_;
 311
 312      $method_name =~ s/.*\://;
 313
 314      if (exists $self->{_methodhash}->{$method_name}) {
 315           return $self->{_methodhash}->{$method_name}->{subclass};
 316      }
 317      return undef;
 318 }
 319
 320
 321 =head2 DESTROY
 322
 323 =head3 Usage
 324
 325 Called by perl.
 326
 327 =head3 Function
 328
 329 Calls all subclass _destroy methods.
 330
 331 Subclasses need only implement a _destroy method if they have
 332 references that need to be uncircularized, or things that should be
 333 disconnected or closed.
 334
 335 =cut
 336
 337 sub DESTROY{
 338      my $self = shift;
 339      foreach my $subclass (keys %{$self->{_subclasses}}) {
 340           # use eval to try and call the subclasses _destroy method.
 341           # Ignore no such function errors, but trap other types of
 342           # errors.
 343           eval {
 344                no strict 'refs';
 345                &$subclass::_destroy($self);
 346           };
 347           if ($@) {
 348                # Die unless we've hit an undefined subroutine.
 349                die $@ unless $@ =~ /Undefined\s*subroutine\s*\&.*\:\:\_clone/;
 350                warn "$subclass doesn't have a _clone method\n$@" if $DEBUG;
 351           }
 352      }
 353 }
 354
 355
 356 =head2 AUTOLOAD
 357
 358  Title   : AUTOLOAD
 359  Usage   : Called by perl
 360  Function: Calls child methods which have been installed into this handle
 361  Returns : N/A
 362  Args    : N/A
 363
 364 The AUTOLOAD function is responsible for calling child methods which
 365 have been installed into the current Class::Modular handle.
 366
 367 Subclasses that have a new function as well as an AUTOLOAD function
 368 must call Class::Modular::AUTOLOAD and set $Class::Modular::AUTOLOAD
 369
 370      $Class::Modular::AUTOLOAD = $AUTOLOAD;
 371      goto &Class::Modular::AUTOLOAD;
 372
 373 =cut
 374
 375 sub AUTOLOAD{
 376      my $method = $AUTOLOAD;
 377
 378      $method =~ s/.*\://;
 379
 380      my ($self) = @_;
 381
 382      if (not ref($self)) {
 383          carp "Not a reference in AUTOLOAD.";
 384          return;
 385      }
 386
 387      if (defined $self->{_methodhash}->{$method}->{reference}) {
 388           eval {
 389                no strict 'refs';
 390                goto &$self->{_methodhash}->{$method}->{reference};
 391           }
 392      }
 393 }
 394
 395
 396 1;
 397
 398
 399 __END__
 400
 401
 402
 403
 404
 405