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