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