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