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