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                # Use subclass::METHODS if it exists [use constants METHODS => qw(foo)]
  87                $self->_addmethods($subclass,&{"${subclass}::_methods"}($self,$options));
  88                &{"${subclass}::_init"}($self);
  89           };
  90           die $@ if $@;
  91           $self->{_subclasses}->{$subclass} = {};
  92      }
  93      else {
  94           carp "Not reloading subclass $subclass" if $DEBUG;
  95      }
  96 }
  97
  98 =head2 override
  99
 100 =head3 Usage
 101
 102      $obj->override('methodname', $code_ref)
 103
 104 =head3 Function
 105
 106 Allows you to override utility functions that are called internally to
 107 provide a different default function.
 108
 109 It's superficially similar to _addmethods, which is called by load,
 110 but it deals with code references, and requires the method name to be
 111 known.
 112
 113 Methods overridden here are _NOT_ overrideable in _addmethods. This
 114 may need to be changed.
 115
 116 =cut
 117
 118 sub override {
 119      my ($self, $method_name, $function_reference) = @_;
 120
 121      $self->{_methodhash}->{$method_name}->{reference} = $function_reference;
 122      $self->{_methodhash}->{$method_name}->{overridden} = 1;
 123 }
 124
 125 =head2 clone
 126
 127 =head3 Usage
 128
 129      my $clone  = $obj->clone
 130
 131 =head3 Function
 132
 133 Produces a clone of the object with duplicates of all data and/or new
 134 connections as appropriate.
 135
 136 Calls _clone on all loaded subclasses.
 137
 138 Warns if debugging is on for classes which don't have a _clone method.
 139 Dies on other errors.
 140
 141 =cut
 142
 143 sub clone {
 144      my ($self) = @_;
 145
 146      my $clone = {};
 147      bless $clone, ref($self);
 148
 149      # copy data structures at this level
 150      $clone->{_methodhash} = dclone($self->{_methodhash});
 151      $clone->{_subclasses} = dclone($self->{_subclasses});
 152
 153      foreach my $subclass (keys %{$self->{_subclasses}}) {
 154           # use eval to try and call the subclasses _clone method.
 155           # Ignore no such function errors, but trap other types of
 156           # errors.
 157
 158           # XXX Switch to can instead.
 159           eval {
 160                no strict 'refs';
 161                &$subclass::_clone($self,$clone);
 162           };
 163           if ($@) {
 164                # Die unless we've hit an undefined subroutine.
 165                die $@ unless $@ =~ /Undefined\s*subroutine\s*\&.*\:\:\_clone/;
 166                warn "$subclass doesn't have a _clone method\n$@" if $DEBUG;
 167           }
 168
 169
 170      }
 171 }
 172
 173 =head2 can
 174
 175 =head3 Usage
 176
 177      $obj->can('METHOD');
 178      Class::Modular->can('METHOD');
 179
 180 =head3 Function
 181
 182 Replaces UNIVERSAL's can method so that handled methods are reported
 183 correctly. Calls UNIVERSAL::can in the places where we don't know
 184 anything it doesn't.
 185
 186 =head3 Returns
 187
 188 A coderef to the method if the method is supported, undef otherwise.
 189
 190 =head3 Args
 191
 192 Scalar Method Name
 193
 194 =cut
 195
 196 sub can{
 197      my ($self,$method,$vars) = @_;
 198
 199      if (ref $self and exists $self->{_methodhash}->{$method}) {
 200           # If the method is defined, return a reference to the
 201           # method.
 202           return $self->{_methodhash}->{$method}->{reference};
 203      }
 204      else {
 205           # Otherwise, let UNIVERSAL::can deal with the method
 206           # appropriately.
 207           return UNIVERSAL::can($self,$method);
 208      }
 209 }
 210
 211 =head2 handledby
 212
 213 =head3 Usage
 214
 215      $obj->handledby('methodname');
 216      $obj->handledby('Class::Method::methodname');
 217
 218 =head3 Function
 219
 220 Returns the subclass that handles this method.
 221
 222 =head3 Returns
 223
 224 SCALAR subclass name
 225
 226 =head3 Args
 227
 228 SCALAR method name
 229
 230 =cut
 231
 232 sub handledby{
 233      my ($self,$method_name) = @_;
 234
 235      $method_name =~ s/.*\://;
 236
 237      if (exists $self->{_methodhash}->{$method_name}) {
 238           return $self->{_methodhash}->{$method_name}->{subclass};
 239      }
 240      return undef;
 241 }
 242
 243 =head1 INTERNAL FUNCTIONS
 244
 245 The functions below are functions internal to Class::Modular. The
 246 first two, new and _init should probably be overriden in any class
 247 that inherits from Class::Modular, but they are provided just in case
 248 you don't want to write a new and/or _init.
 249
 250 =cut
 251
 252 =head2 new
 253
 254 =head3 Usage
 255
 256      $obj = Foo::Bar->new();
 257
 258 =head3 Function
 259
 260 Creates a new C<Foo::Bar> object.
 261
 262 Aditional arguments can be passed to this creator, and they are stored
 263 in C<$self->{_creation_args}>. You can also override the new method in
 264 your subclass. It's just provided here for completeness.
 265
 266 =cut
 267
 268 sub new {
 269      my ($class,@args) = @_;
 270
 271      # We shouldn't be called $me->new, but just in case
 272      $class = ref($class) || $class;
 273
 274      my $self = {};
 275      bless $self, $class;
 276
 277      $self->_init(@args);
 278
 279      return $self;
 280 }
 281
 282
 283 =head2 _init
 284
 285 =head3 Usage
 286
 287      $self->_init(@args);
 288
 289 =head3 Function
 290
 291 Stores the arguments used at new so modules that are loaded later can
 292 read them
 293
 294 This function is called by default from new. Classes may only wish to
 295 override _init.
 296
 297 =cut
 298
 299 sub _init {
 300      my ($self,@creation_args) = @_;
 301
 302      $self->{creation_args} = [@_];
 303 }
 304
 305
 306 =head2 DESTROY
 307
 308 =head3 Usage
 309
 310 Called by perl.
 311
 312 =head3 Function
 313
 314 Calls all subclass _destroy methods.
 315
 316 Subclasses need only implement a _destroy method if they have
 317 references that need to be uncircularized, or things that should be
 318 disconnected or closed.
 319
 320 =cut
 321
 322 =head2 _addmethods
 323
 324 =head3 Usage
 325
 326      $self->_addmethods($subclass,&{"${subclass}::_methods"}($self,$options));
 327
 328 =head3 Function
 329
 330 Given an array of methods, adds the methods into the _methodhash
 331 calling table.
 332
 333 Methods that have previously been overridden by override are _NOT_
 334 overridden again. This may need to be adjusted in load.
 335
 336 =cut
 337
 338 sub _addmethods($@) {
 339      my ($self,$subclass,@methods) = @_;
 340
 341      # stick the method into the table
 342      # DLA: Make with the munchies!
 343
 344      foreach my $method (@methods) {
 345           if (not $method =~ /^$subclass/) {
 346                $method = $subclass.'::'.$method;
 347           }
 348           my ($method_name) = $method =~ /\:*([^\:]+)\s*$/;
 349           if (exists $self->{_methodhash}->{$method_name}) {
 350                if ($self->{_methodhash}->{$method_name}->{overridden}) {
 351                     carp "Not overriding already overriden method $method_name\n" if $DEBUG;
 352                     next;
 353                }
 354                carp "Overriding $method_name $self->{_methodhash}->{$method_name}->{reference} with $method\n";
 355           }
 356           $self->{_methodhash}->{$method_name}->{reference} = $method;
 357           $self->{_methodhash}->{$method_name}->{subclass} = $subclass;
 358      }
 359
 360 }
 361
 362
 363
 364 sub DESTROY{
 365      my $self = shift;
 366      foreach my $subclass (keys %{$self->{_subclasses}}) {
 367           # use eval to try and call the subclasses _destroy method.
 368           # Ignore no such function errors, but trap other types of
 369           # errors.
 370           eval {
 371                no strict 'refs';
 372                &$subclass::_destroy($self);
 373           };
 374           if ($@) {
 375                # Die unless we've hit an undefined subroutine.
 376                die $@ unless $@ =~ /Undefined\s*subroutine\s*\&.*\:\:\_clone/;
 377                warn "$subclass doesn't have a _clone method\n$@" if $DEBUG;
 378           }
 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