Object1->Constructor Object2->Constructor Object2->Doit Object1->Doit #!/usr/bin/perl use strict; use warnings; package Interface; our (@IfStack) = (); # Toolset handle stack sub Push { push (@IfStack, @_); # push onto stack } sub Factory { sub Stacker { # Recursively build the object stack # Begin # Inherit base object. # If end of stack, # Spawn the created object (base object) # Else # Recursive into parent. # Relate us with our child. # Call constructor. # End #.. my ($stack, $package) = @_; # current__PACKAGE__ my ($base, $self); if ( scalar (@$stack) ) { # inherit 'base' $base = pop (@$stack); eval "@"."$package"."::ISA=\"$base\""; } if ( scalar (@$stack) == 0 ) { # base class .. spawn $self = eval( "$package->Spawn()" ); } else { # unroll next object $self = Stacker ($stack, $base); $self = bless ($self, $package); } $self->Constructor(); return ($self); } my (@stack) = @IfStack; # clone stack my ($self); die "ERROR: Interface -- object stack empty.\n" if ( ! scalar (@stack) ); $self = Stacker( \@stack, pop(@stack) ) || die "ERROR: cannot build stack.\n"; return $self; } package Interface::Base; Interface::Push( "Interface::Base" ); # push onto stack sub Spawn { my ($obclass) = shift; my ($class) = ref($obclass) || $obclass; my ($self) = {}; return bless($self, $class); } ############################################### # Object1 #.. package MyObject1; sub Constructor { print "Object1->Constructor\n"; } sub Doit { my ($self) = shift; print "Object1->Doit\n"; $self->SUPER::Doit() # chain if ($self->can("SUPER::Doit")); } ############################################### # Object2 #.. package MyObject2; sub Constructor { print "Object2->Constructor\n"; } sub Doit { my ($self) = shift; print "Object2->Doit\n"; $self->SUPER::Doit() # chain if ($self->can("SUPER::Doit")); } ############################################### # TEST MAIN #. package main; my ($ts); print "Main\n"; Interface::Push( "MyObject1" ); # push onto stack Interface::Push( "MyObject2" ); # push onto stack $ts = Interface::Factory(); # create object $ts->Doit(); # call 1;