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