package Class::SubclassDeep;

# $Id: SubclassDeep.pm,v 1.8 2003/12/10 22:52:56 mrodrigu Exp $

use strict;
use warnings;
use Carp;

require Exporter;

use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK $SUPER);

@ISA = qw(Exporter);

@EXPORT = qw( &subclass);
@EXPORT_OK = qw( &resync_isa &package_list );

$VERSION = '0.05';

my $DEBUG=0;

# naming convention mapped_* is the new subclass, * is the iniちial one (that we want to subclass)

sub subclass
  { my %map= @_;
	  my %package_map;
    while( my ($class, $mapped_class)= each %map)
      { my $constructors;
        if( $mapped_class=~ m{^ \s* ([\w:]+) \s* (?: \( \s* (\w+((\s+|\s*,\s*)\w+)*) \s* \) \s* )? $}x)
          { # mapped class includes the constructor name
            $mapped_class= $1;
            $constructors = $2 || "new";
						$package_map{$class}= $mapped_class;
          }
        else
          { carp "wrong map syntax $mapped_class"; }
				my @constructors= split /(?:\s+|\s*,\s*)/, $constructors;
				foreach my $constructor_name (@constructors)
          { _subclass( $class, $mapped_class, $constructor_name) or carp "subclass error: $!"; }
      }
		resync_isa( %package_map); # just in case the inheritance tree got out-of-sync
    return 1;
  }

sub _subclass
  { my( $class, $mapped_class, $constructor_name)= @_;
		no strict 'refs';
    my $constructor_fullname= $class . "::" . $constructor_name;
		my $saved_constructor_class= __PACKAGE__ . "::" . $class;
    my $saved_constructor_name=  $saved_constructor_class . "::" . $constructor_name;

	  undef &$saved_constructor_name;
    *{$saved_constructor_name}= \&$constructor_fullname;   # save the initial constructor
    
    undef *$constructor_fullname;
    my $mapped_constructor_fullname= $mapped_class . "::" . $constructor_name;
		my $mapped_constructor= $mapped_class->can( $constructor_name) 
		                        ||
														# this should happen only if there is no constructor at compile time 
														 sub 
                               { my $arg= shift; 
																   remap_class( $arg, $class => $mapped_class);
																	 my $self;
																	 if( defined &$saved_constructor_name)
																	   { $self= $saved_constructor_name->( $arg, @_); }
																	 else
																	   { $arg= change_class_to_super( $arg, $class);
																			 $self= $arg->$constructor_name( @_);
																	   }
																	 return $self;
                               };

		*$constructor_fullname=
          sub { unshift @{"$mapped_class\::ISA"}, $saved_constructor_class; 
                my $self= $mapped_constructor->( @_);
								remap_class( $self, $class => $mapped_class);
                my $shifted= shift @{"$mapped_class\::ISA"};   # needs to be improved in case new messes with @ISA ?
                return $self;
              }
  }
   
# $arg is a class name or an object
# change its class from $class to $mapped_class	
# only if the initial class is $class
sub remap_class
  { my( $arg, $class, $mapped_class)= @_;
	  my $arg_class= ref $arg || $arg;
	  if( $arg_class eq $class)
		  { if( ref $arg) { bless $_[0], $mapped_class; }
		    else          { $_[0]= $mapped_class;       }
			}
	}

# $arg is a class name or an object
# change its class to $class	
sub change_class
  { my( $arg, $class)= @_;
		if( ref $arg) { bless $_[0], $class; }
		else          { $_[0]= $class;       }
	}

# $arg is a class name or an object
# change its class to the SUPER of $class
sub change_class_to_super
  { my( $arg, $class)= @_;
		no strict 'refs';
		my $super= super( $class);
		change_class( $_[0], super( $class));
	}

sub super
  { my( $arg)= @_;
		no strict 'refs';
	  my $class= ref $arg || $arg;
	  my @isa= @{"$class\::ISA"};
		return $isa[0]; 
	}
	  
	
# debugging tool
sub warn_isa
  { my( $type, $arg)= @_;
		my $class= ref $arg || $arg;
		no strict 'refs';
	  warn "  $type: $class\::ISA = ", join( " - ", @{"$class\::ISA"}), "\n" if( $DEBUG);
	}
	
# makes sure that all ISA are correct: in case of hierarchy
# of inheritance, some initial classes need to be remapped to
# mapped classes
sub resync_isa
  { my %map= @_;

		my @packages= package_list( '::');
		no strict 'refs';
		foreach my $package (@packages)
		  { foreach (@{$package ."ISA"})
					{ # if the class isa initial class, remap as isa mapped class,
						# unless it is the mapped class of course
						if( $map{$_} && ($package ne "$map{$_}::") )
						  { warn "in $package $_ => $map{$_} \n" if( $DEBUG);
								$_= $map{$_};
						 	}
					}
			}
	}

# all packages in the code
sub package_list
  { my $package= shift;
    my @packages= ( $package); 
    foreach( _package_list( $package))
      { next if( ($_ eq $package) || ($_ eq 'main::') );
        push @packages, package_list( "$package$_");
      }
    return map { s{^::}{}; $_ } @packages;
  }

# all sub packages of a package
sub _package_list
  { my $package= shift;
    no strict 'refs';
    return grep { /::$/ }  keys %{$package};
  }

		
1;
__END__
=head1 NAME

Class::SubclassDeep - Perl extension for subclassing "out-of-reach" classes

=head1 SYNOPSIS

  use Class::SubclassDeep;
  subclass( class1 => "sub_class1",  class2 => "sub_class2( constructor)";
  my $object= top_class->new;

C<top_class> originally creates sub-objects in the C<class1> and C<class2> packages
(using C<new> for C<class1> and C<constructor> for C<class2>).

After the call to C<subclass> the sub-objects will be now created as C<sub_class1> and
C<sub_class2>.

The constructor does not need to be present in the new classes.

=head1 DESCRIPTION

This module can be used to change the classes of objects generated by object factories:

If you are using an existing module with an OO interface, then you can subclass this object.
If this object itself is an object factory, ie if it generates other objects, in other classes,
it might be difficult to subclass these objects, unless the original author has put the appropriate 
hooks in the code.

C<Class::SubclassDeep> lets you solve this by specifying classes to use instead of the hard-coded
ones.

Here is an exemple, with XML::DOM (I do not advise you to use XML::DOM BTW, but that's not the point here,
and XML::DOM is one of those real tricky modules where using Class::Subclass::Deep is just the beginning
of the story...)

  #!/usr/bin/perl -w
  use strict; 

  use Class::SubclassDeep;
  use XML::DOM;

  my $doc=q{<doc><elt>an element</elt><no_id>element not to id</no_id></doc>};
  my $parser = new XML::DOM::Parser;
  # here is where the magic happens: instead of calling XML::DOM::Element->new
  # XML::DOM will now call MyElement->new
  subclass( 'XML::DOM::Element' => "MyElement"); 
  my $dom = $parser->parse ( $doc);
  print "DOM modified by Class::SubclassDeep:  ", $dom->toString;
  
  package MyElement;

  # we really want to subclass XML::DOM::Element, not to replace it
  use base 'XML::DOM::Element'; 
  my $i;

  sub new
    { shift @_;
      # MyElement->SUPER is XML::DOM::Element
      my $elt= MyElement->SUPER::new( @_);
      if( $elt->getTagName eq 'elt') { $elt->setAttribute( id => "id" . ++$i); }
      return $elt;
    }

Note that if the class to subclass has several potential constructors (C<XML::DOM>
for example has C<parse> and C<parsefile>), you can put them all, space separated:

    subclass( 'XML::DOM::Parser'    =>'XML::DOM::XPath::Parser (parse parsefile)');
		
=head2 EXPORT

  subclass


=head2 BUGS

  Considering how much you can do with Perl's OO system, I doubt I am covering all
	cases.

  The test suite covers most static (no changing the ISA after the compilation phase)	
	cases, but the modules works also in some funkier cases. It needs to be better tested,
	but I lack the imagination to write some real tricky test cases.
	
=head1 SEE ALSO


=head1 AUTHOR

Michel Rodriguez, E<lt>mirod@cpan.org<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2003 by Michel Rodriguez

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut
