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