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