lib/Class/Modular.pm

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