Class/Modular/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. Copyright 2003 by Don
   4 # Armstrong <don@donarmstrong.com>.
   5 # $Id: Modular.pm,v 1.4 2003/10/24 04:48:51 don Exp $
   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 @ISA = qw(Class::Modular);
  18
  19
  20 =head1 DESCRIPTION
  21
  22 Class::Modular is a superclass for generating modular classes, where
  23 methods can be added into the class from the perspective of the
  24 object, rather than the perspective of the class.
  25
  26 That is, you can create a class which has a set of generic common
  27 functions. Less generic functions can be included or overridden
  28 without modifying the base classes. This allows for code to be more
  29 modular, and reduces code duplication.
  30
  31 =over
  32
  33 =item new
  34
  35 new is responsible for blessing and creating a new database superclass.
  36
  37 =item load
  38
  39 load is responsible for loading database plugins
  40
  41 =back
  42
  43
  44 =head1 BUGS
  45
  46 None known.
  47
  48 =cut
  49
  50 use strict;
  51 use vars qw($VERSION $DEBUG);
  52
  53 use Carp;
  54
  55 use Data::Copy qw(deep_copy); # Used for deep copying objects
  56
  57 BEGIN{
  58      ($VERSION) = q$Revision: 1.4 $ =~ /\$Revision:\s+([^\s+])/;
  59      $DEBUG = 0 unless defined $DEBUG;
  60 }
  61
  62 our $AUTOLOAD;
  63
  64 =head2 new
  65
  66  Title   : new
  67  Usage   : $obj = Foo::Bar->new();
  68  Function: Creates a new Foo::Bar object
  69  Returns : A new Foo::Bar object
  70  Args    : none.
  71
  72  Aditional arguments can be passed to this creator, and they are
  73  stored in $self->{_creation_args}. You can also override the new
  74  method in your subclass. It's just provided here for completeness.
  75
  76 =cut
  77
  78 sub new {
  79      my ($class,@args) = @_;
  80
  81      # We shouldn't be called $me->new, but just in case
  82      $class = ref($class) || $class;
  83
  84      my $self = {};
  85      bless $self, $class;
  86
  87      $self->{_creation_args} = [@args];
  88
  89      return $self;
  90 }
  91
  92
  93 =head2 load
  94
  95  Title   : load
  96  Usage   : $db->load('FOO::Subclass');
  97  Function: loads a Class::Modular subclass
  98  Returns : nothing
  99  Args    : SCALAR subclass SCALAR options
 100
 101  Loads the named subclass into this object if the named subclass has
 102  not been loaded.
 103
 104  The options scalar is passed to $subclass::_methods when determining
 105  which methods should be added using _addmethods.
 106
 107  The subclasses _init method is called right after methods are loaded.
 108
 109  If debugging is enabled, will warn about loading already loaded
 110  subclasses.
 111
 112 =cut
 113
 114
 115 sub load($$;$) {
 116      my ($self,$subclass,$options) = @_;
 117
 118      $options ||= {};
 119
 120      # check to see if the subclass has already been loaded.
 121
 122      if (not defined $self->{_subclasses}->{$subclass}){
 123           eval {
 124                no strict 'refs';
 125                $self->_addmethods($subclass,&{"${subclass}::_methods"}($self,$options));
 126                &{"${subclass}::_init"}($self);
 127           };
 128           warn $@ if $@;
 129           $self->{_subclasses}->{$subclass} = {};
 130      }
 131      else {
 132           carp "Not reloading subclass $subclass" if $DEBUG;
 133      }
 134 }
 135
 136 =head2 _addmethods
 137
 138  Title   : _addmethods
 139  Usage   : $self->_addmethods()
 140  Function: Adds the passed methods into the function table
 141  Returns :
 142  Args    : ARRAY of methods
 143
 144  Given an array of methods, adds the methods into the _methodhash
 145  calling table.
 146
 147  Methods that have previously been overridden by override are _NOT_
 148  overridden again. This may need to be adjusted in load.
 149
 150 =cut
 151
 152 sub _addmethods($@) {
 153      my ($self,$subclass,@methods) = @_;
 154
 155      # stick the method into the table
 156      # DLA: Make with the munchies!
 157
 158      foreach my $method (@methods) {
 159           if (not $method =~ /^$subclass/) {
 160                $method = $subclass.$method;
 161           }
 162           my ($method_name) = $method =~ /\:*([^\:]+)\s*$/;
 163           if (exists $self->{_methodhash}->{$method_name}) {
 164                if ($self->{_methodhash}->{$method_name}->{overridden}) {
 165                     carp "Not overriding already overriden method $method_name\n" if $DEBUG;
 166                     next;
 167                }
 168                carp "Overriding $method_name $self->{_methodhash}->{$method_name}->{reference} with $method\n";
 169           }
 170           $self->{_methodhash}->{$method_name}->{reference} = $method;
 171      }
 172
 173 }
 174
 175 =head2 override
 176
 177  Title   : override
 178  Usage   : $obj->override('methodname', $code_ref)
 179  Function: Overrides the method methodname and calls $code_ref instead.
 180  Returns : TRUE on success, FALSE on failure.
 181  Args    : SCALAR method name
 182            CODEREF function reference
 183
 184  Allows you to override utility functions that are called internally
 185  to provide a different default function.
 186
 187  It's superficially similar to _addmethods, which is called by load,
 188  but it deals with code references, and requires the method name to be
 189  known.
 190
 191  Methods overridden here are _NOT_ overrideable in _addmethods. This
 192  may need to be changed.
 193
 194 =cut
 195
 196 sub override {
 197      my ($self, $method_name, $function_reference) = @_;
 198
 199      $self->{_methodhash}->{$method_name}->{reference} = $function_reference;
 200      $self->{_methodhash}->{$method_name}->{overridden} = 1;
 201 }
 202
 203 =head2 clone
 204
 205  Title   : clone
 206  Usage   : my $clone  = $obj->clone
 207  Function: Produces a clone of the Class::Modular object
 208  Returns :
 209  Args    :
 210
 211  Produces a clone of the object with duplicates of all data and/or new
 212  connections as appropriate.
 213
 214  Calls _clone on all loaded subclasses.
 215
 216  Warns if debugging is on for classes which don't have a _clone
 217  method.  Dies on other errors.
 218
 219 =cut
 220
 221 sub clone {
 222      my ($self) = @_;
 223
 224      my $clone = {};
 225      bless $clone, ref($self);
 226
 227      # copy data structures at this level
 228      $clone->{_methodhash} = deep_copy($self->{_methodhash});
 229      $clone->{_subclasses} = deep_copy($self->{_subclasses});
 230
 231      foreach my $subclass (keys %{$self->{_subclasses}}) {
 232           # use eval to try and call the subclasses _clone method.
 233           # Ignore no such function errors, but trap other types of
 234           # errors.
 235
 236           eval {
 237                no strict 'refs';
 238                &$subclass::_clone($self,$clone);
 239           };
 240           if ($@) {
 241                # Die unless we've hit an undefined subroutine.
 242                die $@ unless $@ =~ /Undefined\s*subroutine\s*\&.*\:\:\_clone/;
 243                warn "$subclass doesn't have a _clone method\n$@" if $DEBUG;
 244           }
 245
 246
 247      }
 248 }
 249
 250
 251 =head2 DESTROY
 252
 253 =head3 Usage
 254
 255 Called by perl.
 256
 257 =head3 Function
 258
 259 Calls all subclass _destroy methods.
 260
 261 Subclasses need only implement a _destroy method if they have
 262 references that need to be uncircularized, or things that should be
 263 disconnected or closed.
 264
 265 =cut
 266
 267 sub DESTROY{
 268      my $self = shift;
 269      foreach my $subclass (keys %{$self->{_subclasses}}) {
 270           # use eval to try and call the subclasses _destroy method.
 271           # Ignore no such function errors, but trap other types of
 272           # errors.
 273           eval {
 274                no strict 'refs';
 275                &$subclass::_destroy($self);
 276           };
 277           if ($@) {
 278                # Die unless we've hit an undefined subroutine.
 279                die $@ unless $@ =~ /Undefined\s*subroutine\s*\&.*\:\:\_clone/;
 280                warn "$subclass doesn't have a _clone method\n$@" if $DEBUG;
 281           }
 282      }
 283 }
 284
 285
 286 =head2 AUTOLOAD
 287
 288  Title   : AUTOLOAD
 289  Usage   : Called by perl
 290  Function: Calls child methods which have been installed into this handle
 291  Returns : N/A
 292  Args    : N/A
 293
 294  The AUTOLOAD function is responsible for calling child methods which
 295  have been installed into the current Class::Modular handle.
 296
 297 =cut
 298
 299 sub AUTOLOAD{
 300      my $method = $AUTOLOAD;
 301
 302      $method =~ s/.*\://;
 303
 304      my ($self) = @_;
 305
 306      if (not ref($self)) {
 307          carp "Not a reference in AUTOLOAD.";
 308          return;
 309      }
 310
 311      if (defined $self->{_methodhash}->{$method}->{reference}) {
 312           eval {
 313                no strict 'refs';
 314                goto &$self->{_methodhash}->{$method}->{reference};
 315           }
 316      }
 317 }
 318
 319
 320 1;
 321
 322
 323 __END__
 324
 325
 326
 327
 328
 329