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