libs/DesignPattern/Bridge.pm

## --------------------------------------------------------------------------------
##  $Id: Bridge.pm,v 1.10 2003/02/20 20:50:32 joko Exp $
## --------------------------------------------------------------------------------
##  $Log: Bridge.pm,v $
##  Revision 1.10  2003/02/20 20:50:32  joko
##  + small exception handling: now inheriting from little Exception object
##
##  Revision 1.9  2003/02/18 18:35:30  joko
##  + encapsulated/abstracted some more functionality: sub load_single
##
##  Revision 1.8  2003/02/14 14:20:05  joko
##  + modified mixin behaviour
##
##  Revision 1.7  2003/02/11 10:34:19  joko
##  + loaded module may now lack 'mixin::with' declaration
##  + this gets us the possibility to load modules from any perl namespace
##     + enabled this mechanism
##
##  Revision 1.6  2003/02/09 16:22:51  joko
##  + pseudo constructor mechanism via options
##
##  Revision 1.5  2003/01/31 01:19:50  root
##  + fixed: doesn't need Log::Dispatch any more, but uses it if available
##
##  Revision 1.4  2003/01/20 16:55:15  joko
##  + sub mixinPackage
##  + sub include
##
##  Revision 1.3  2002/12/16 19:57:12  joko
##  + sub unload
##
##  Revision 1.2  2002/12/15 02:06:15  joko
##  + feature to be able to specify module in non-perl-style when loading plugins: e.g. $process->load('Setup/Storage')
##
##  Revision 1.1  2002/12/13 21:46:29  joko
##  + initial check-in
##
## --------------------------------------------------------------------------------


package DesignPattern::Bridge;

use strict;
use warnings;

use base qw( 
  DesignPattern::Object
  DesignPattern::Exception
);


use Data::Dumper;

## ========   object inheritance   ========

# TODO / REFACTORING PROPOSAL
# leading from Data::Storage to code abstracted out into this module - DesignPattern::Bridge
#   - this is no inheritance and it doesn't have to be
#   - implement this module as a bridge to its sub-modules
#   - use the BridgePattern (http://c2.com/cgi/wiki?BridgePattern) 
#       Using patterns was already successfully done with Data::Storage::Handler
#       by implementing the AdapterPattern (http://c2.com/cgi/wiki?AdapterPattern)
#       with Perl's AUTOLOAD-mechanism
#   - try to use Perl's "tie" command to implement this functionality here instead of using AUTOLOAD!
#   - sub getChildNodes
#   - sub run

# 2003-02-11, joko: does this have anything in parallel with CPAN's Class::Inner?


# get logger instance
my $logger = eval { Log::Dispatch::Config->instance; };
  
my $meta;

## ========   object constructor   ========
sub new {
  my $invocant = shift;
  my $class = ref($invocant) || $invocant;
  my @args = ();
  @_ && (@args = @_);
  $logger->debug( __PACKAGE__ . "->new(@args)" ) if $logger;
  my $self = { @_ };

  # trace
    #print "class: $class", "\n";

  # create instance
  bless $self, $class;
  
  return $self;
}


## ========   method overrider   ========
  sub AUTOLOAD2 {
    
    my $self = shift;
    our $AUTOLOAD;
    
    ##print "AUTOLOAD\n";

    my $method = $AUTOLOAD;
    $method =~ s/^.*:://;
  
    $logger->debug( __PACKAGE__ . "->" . $method . "(@_)" . " (AUTOLOAD called, not dispatched)" ) if $logger;

    ## ->DESTROY would - if not declared - trigger an AUTOLOAD also
    return if $method =~ m/::DESTROY$/;
  
##    if ($self->_filter_AUTOLOAD($method)) {
##      $self->_accessStorage();
##      $self->{STORAGEHANDLE}->$method(@_);
##    }
    
  }

  sub _getPluginPackage {
    my $self = shift;
    my $modulename_load = shift;

    # substitute slashes through double double-colons to load modules perl-style
    $modulename_load =~ s/\//::/g;
    
    # build full package name
    my $self_classname = ref $self;
      # name
      my $package = $modulename_load;
      
      # if package is absolute, cut away prefix ('/' or '::')
      if ($package !~ s/^:://) {
        # else: prefix with base classname if above name is relative (lacks of '/' or '::')
        $package = $self_classname . '::' . $package 
      }
    
    return $package;
  }
  
  sub load {

    my $self = shift;
    my $modulename = shift;
    my $options = shift;

    if (ref $modulename eq 'ARRAY') {
      foreach (@$modulename) {
        $self->load_single($_, $options);
      }
    } else {
      $self->load_single($modulename, $options);
    }

  }

  sub load_single {

    my $self = shift;
    my $modulename_load = shift;

    my $options = shift;

    my $self_modulename = ref $self;
    my $package = $self->_getPluginPackage($modulename_load);
    
    if ($meta->{loaded}->{$package}) {
      return 1;
    }
    
    #$logger->info( __PACKAGE__ . "->load: $package" ) if $logger;
    #$logger->info( __PACKAGE__ . "->load: $self_modulename" ) if $logger;
    $logger->debug( $self_modulename . "->load: $package\t[via " . __PACKAGE__ . "]" ) if $logger;

    # this is the module testing phase - use mixin doesn't seem to propagate errors by default
    eval("use $package;");
    $self->checkExceptions();
    
=pod    
    if ($@) {
      $meta->{loaded}->{$package} = 0;
      # include caller information
      my @caller = caller;
      my $caller_msg = $caller[1] . ':' . $caller[2];
      my $msg =  __PACKAGE__ . "->load: $@ ($caller_msg)";
      if ($logger) {
        $logger->error($msg);
      } else {
        print $msg, "\n";
      }
    }
=cut

#print "ref-1: ", ref $self, "\n";
#print "ref-2: ", ref $self::SUPER, "\n";
    
    # V1:
    #bless $self, $package;

    # V2:
    $self->mixinPackage($package);
    
    if (my $method = $options->{method}) {
      $self->$method();
    }

    return 1;
    
  }
  
  sub mixinPackage {
    my $self = shift;
    my $package = shift;
    
    # switch into foreign package and prepare for mixin
    $self->mixin_prepare($package);

    # switch into local package (scope which uses DesignPattern::Bridge) and mixin plugin-module
    $self->mixin_do($package);

  }

  # TODO: maybe refactor to DesignPattern::Object? what about the '$logger'?
  sub mixin_prepare {
    my $self = shift;
    my $package = shift;
    my $self_classname = ref $self;
    eval("package $package; use mixin::with '$self_classname';");

    # FIXME: --- this is redundant ---
    if ($@) {
      $meta->{loaded}->{$package} = 0;
      $logger->error( __PACKAGE__ . "->load: $@" ) if $logger;
    } else {
      $meta->{loaded}->{$package} = 1;
    }
    # FIXME: --- this is redundant ---

  }

  sub mixin_do {
    my $self = shift;
    my $package = shift;
    # switch into foreign package and mixin plugin-module
    my $self_classname = ref $self;
    eval("package $self_classname; use mixin '$package';");
    #eval("use mixin_all '$package';");

    # FIXME: --- this is redundant ---
    if ($@) {
      $meta->{loaded}->{$package} = 0;
      $logger->error( __PACKAGE__ . "->load: $@" ) if $logger;
    } else {
      $meta->{loaded}->{$package} = 1;
    }
    # FIXME: --- this is redundant ---

  }

  sub unload {

    my $self = shift;
    my $modulename_unload = shift;

    my $package = $self->_getPluginPackage($modulename_unload);
    
    if ($meta->{loaded}->{$package}) {
      $meta->{loaded}->{$package} = 0;
      my $where = __PACKAGE__ . ':' . __LINE__;
      $logger->debug( __PACKAGE__ . "->unload: FIXME: DESTROY object is not implemented at '$where'." ) if $logger;
    }

  }


  sub boot {
    my $self = shift;
    $self->_abstract_function('boot');
  }
  
  sub include {
    my $self = shift;
    my $includefile = shift;
    my $package = shift;
    
    # pre-flight checks
    if (!$includefile) {
      $self->raiseException('Filename for inclusion was empty.');
      return;
    }
    
    # go for it ...
    eval("require '$includefile';");
    # ... and handle errors afterwards catching every message from perl itself ...
    return if $self->checkExceptions();
    
    # ... otherwise continue assuming everything is fine
    $self->mixinPackage($package) if $package;
    
  }

1;
__END__
1	joko	1.1	## --------------------------------------------------------------------------------
2	joko	1.11	## $Id: Bridge.pm,v 1.10 2003/02/20 20:50:32 joko Exp $
3	joko	1.1	## --------------------------------------------------------------------------------
4	joko	1.2	## $Log: Bridge.pm,v $
5	joko	1.11	## Revision 1.10 2003/02/20 20:50:32 joko
6			## + small exception handling: now inheriting from little Exception object
7			##
8	joko	1.10	## Revision 1.9 2003/02/18 18:35:30 joko
9			## + encapsulated/abstracted some more functionality: sub load_single
10			##
11	joko	1.9	## Revision 1.8 2003/02/14 14:20:05 joko
12			## + modified mixin behaviour
13			##
14	joko	1.8	## Revision 1.7 2003/02/11 10:34:19 joko
15			## + loaded module may now lack 'mixin::with' declaration
16			## + this gets us the possibility to load modules from any perl namespace
17			## + enabled this mechanism
18			##
19	joko	1.7	## Revision 1.6 2003/02/09 16:22:51 joko
20			## + pseudo constructor mechanism via options
21			##
22	joko	1.6	## Revision 1.5 2003/01/31 01:19:50 root
23			## + fixed: doesn't need Log::Dispatch any more, but uses it if available
24			##
25	root	1.5	## Revision 1.4 2003/01/20 16:55:15 joko
26			## + sub mixinPackage
27			## + sub include
28			##
29	joko	1.4	## Revision 1.3 2002/12/16 19:57:12 joko
30			## + sub unload
31			##
32	joko	1.3	## Revision 1.2 2002/12/15 02:06:15 joko
33			## + feature to be able to specify module in non-perl-style when loading plugins: e.g. $process->load('Setup/Storage')
34			##
35	joko	1.2	## Revision 1.1 2002/12/13 21:46:29 joko
36			## + initial check-in
37			##
38	joko	1.1	## --------------------------------------------------------------------------------
39
40
41			package DesignPattern::Bridge;
42
43			use strict;
44			use warnings;
45
46	joko	1.10	use base qw(
47			DesignPattern::Object
48			DesignPattern::Exception
49			);
50	joko	1.1
51	joko	1.11
52	joko	1.2	use Data::Dumper;
53
54	joko	1.1	## ======== object inheritance ========
55
56	joko	1.7	# TODO / REFACTORING PROPOSAL
57			# leading from Data::Storage to code abstracted out into this module - DesignPattern::Bridge
58	joko	1.1	# - this is no inheritance and it doesn't have to be
59			# - implement this module as a bridge to its sub-modules
60			# - use the BridgePattern (http://c2.com/cgi/wiki?BridgePattern)
61			# Using patterns was already successfully done with Data::Storage::Handler
62			# by implementing the AdapterPattern (http://c2.com/cgi/wiki?AdapterPattern)
63			# with Perl's AUTOLOAD-mechanism
64			# - try to use Perl's "tie" command to implement this functionality here instead of using AUTOLOAD!
65			# - sub getChildNodes
66			# - sub run
67
68	joko	1.7	# 2003-02-11, joko: does this have anything in parallel with CPAN's Class::Inner?
69
70
71	joko	1.1	# get logger instance
72	root	1.5	my $logger = eval { Log::Dispatch::Config->instance; };
73	joko	1.1
74	joko	1.3	my $meta;
75	joko	1.1
76			## ======== object constructor ========
77	joko	1.7	sub new {
78			my $invocant = shift;
79			my $class = ref($invocant) \|\| $invocant;
80			my @args = ();
81			@_ && (@args = @_);
82			$logger->debug( __PACKAGE__ . "->new(@args)" ) if $logger;
83			my $self = { @_ };
84
85			# trace
86	joko	1.1	#print "class: $class", "\n";
87	joko	1.7
88			# create instance
89			bless $self, $class;
90
91			return $self;
92			}
93	joko	1.1
94
95			## ======== method overrider ========
96			sub AUTOLOAD2 {
97
98			my $self = shift;
99			our $AUTOLOAD;
100
101			##print "AUTOLOAD\n";
102
103			my $method = $AUTOLOAD;
104			$method =~ s/^.*:://;
105
106	root	1.5	$logger->debug( __PACKAGE__ . "->" . $method . "(@_)" . " (AUTOLOAD called, not dispatched)" ) if $logger;
107	joko	1.1
108			## ->DESTROY would - if not declared - trigger an AUTOLOAD also
109			return if $method =~ m/::DESTROY$/;
110
111			## if ($self->_filter_AUTOLOAD($method)) {
112			## $self->_accessStorage();
113			## $self->{STORAGEHANDLE}->$method(@_);
114			## }
115
116			}
117	joko	1.3
118			sub _getPluginPackage {
119			my $self = shift;
120			my $modulename_load = shift;
121
122			# substitute slashes through double double-colons to load modules perl-style
123			$modulename_load =~ s/\//::/g;
124
125			# build full package name
126			my $self_classname = ref $self;
127	joko	1.7	# name
128			my $package = $modulename_load;
129
130			# if package is absolute, cut away prefix ('/' or '::')
131			if ($package !~ s/^:://) {
132			# else: prefix with base classname if above name is relative (lacks of '/' or '::')
133			$package = $self_classname . '::' . $package
134			}
135
136	joko	1.3	return $package;
137			}
138	joko	1.1
139			sub load {
140	joko	1.9
141			my $self = shift;
142			my $modulename = shift;
143			my $options = shift;
144
145			if (ref $modulename eq 'ARRAY') {
146			foreach (@$modulename) {
147			$self->load_single($_, $options);
148			}
149			} else {
150			$self->load_single($modulename, $options);
151			}
152
153			}
154
155			sub load_single {
156	joko	1.1
157			my $self = shift;
158	joko	1.3	my $modulename_load = shift;
159	joko	1.1
160	joko	1.6	my $options = shift;
161
162	joko	1.4	my $self_modulename = ref $self;
163	joko	1.3	my $package = $self->_getPluginPackage($modulename_load);
164	joko	1.1
165	joko	1.3	if ($meta->{loaded}->{$package}) {
166			return 1;
167			}
168	joko	1.2
169	root	1.5	#$logger->info( __PACKAGE__ . "->load: $package" ) if $logger;
170			#$logger->info( __PACKAGE__ . "->load: $self_modulename" ) if $logger;
171			$logger->debug( $self_modulename . "->load: $package\t[via " . __PACKAGE__ . "]" ) if $logger;
172	joko	1.1
173			# this is the module testing phase - use mixin doesn't seem to propagate errors by default
174			eval("use $package;");
175	joko	1.10	$self->checkExceptions();
176
177			=pod
178	joko	1.1	if ($@) {
179	joko	1.3	$meta->{loaded}->{$package} = 0;
180	joko	1.2	# include caller information
181			my @caller = caller;
182			my $caller_msg = $caller[1] . ':' . $caller[2];
183	root	1.5	my $msg = __PACKAGE__ . "->load: $@ ($caller_msg)";
184			if ($logger) {
185			$logger->error($msg);
186			} else {
187			print $msg, "\n";
188			}
189	joko	1.1	}
190	joko	1.10	=cut
191	joko	1.1
192			#print "ref-1: ", ref $self, "\n";
193			#print "ref-2: ", ref $self::SUPER, "\n";
194
195			# V1:
196			#bless $self, $package;
197
198			# V2:
199	joko	1.8	$self->mixinPackage($package);
200
201			if (my $method = $options->{method}) {
202			$self->$method();
203			}
204	joko	1.7
205	joko	1.8	return 1;
206
207			}
208
209			sub mixinPackage {
210			my $self = shift;
211			my $package = shift;
212
213	joko	1.7	# switch into foreign package and prepare for mixin
214			$self->mixin_prepare($package);
215
216			# switch into local package (scope which uses DesignPattern::Bridge) and mixin plugin-module
217			$self->mixin_do($package);
218	joko	1.6
219	joko	1.4	}
220
221			# TODO: maybe refactor to DesignPattern::Object? what about the '$logger'?
222	joko	1.7	sub mixin_prepare {
223			my $self = shift;
224			my $package = shift;
225			my $self_classname = ref $self;
226			eval("package $package; use mixin::with '$self_classname';");
227
228			# FIXME: --- this is redundant ---
229			if ($@) {
230			$meta->{loaded}->{$package} = 0;
231			$logger->error( __PACKAGE__ . "->load: $@" ) if $logger;
232			} else {
233			$meta->{loaded}->{$package} = 1;
234			}
235			# FIXME: --- this is redundant ---
236
237			}
238
239			sub mixin_do {
240	joko	1.4	my $self = shift;
241			my $package = shift;
242			# switch into foreign package and mixin plugin-module
243	joko	1.3	my $self_classname = ref $self;
244	joko	1.1	eval("package $self_classname; use mixin '$package';");
245			#eval("use mixin_all '$package';");
246	joko	1.7
247			# FIXME: --- this is redundant ---
248	joko	1.1	if ($@) {
249	joko	1.3	$meta->{loaded}->{$package} = 0;
250	root	1.5	$logger->error( __PACKAGE__ . "->load: $@" ) if $logger;
251	joko	1.3	} else {
252			$meta->{loaded}->{$package} = 1;
253	joko	1.1	}
254	joko	1.7	# FIXME: --- this is redundant ---
255
256	joko	1.3	}
257
258			sub unload {
259
260			my $self = shift;
261			my $modulename_unload = shift;
262
263			my $package = $self->_getPluginPackage($modulename_unload);
264	joko	1.1
265	joko	1.3	if ($meta->{loaded}->{$package}) {
266			$meta->{loaded}->{$package} = 0;
267			my $where = __PACKAGE__ . ':' . __LINE__;
268	root	1.5	$logger->debug( __PACKAGE__ . "->unload: FIXME: DESTROY object is not implemented at '$where'." ) if $logger;
269	joko	1.3	}
270
271	joko	1.1	}
272	joko	1.3
273	joko	1.1
274			sub boot {
275			my $self = shift;
276			$self->_abstract_function('boot');
277	joko	1.4	}
278
279			sub include {
280			my $self = shift;
281			my $includefile = shift;
282			my $package = shift;
283	joko	1.11
284			# pre-flight checks
285			if (!$includefile) {
286			$self->raiseException('Filename for inclusion was empty.');
287			return;
288			}
289
290			# go for it ...
291			eval("require '$includefile';");
292			# ... and handle errors afterwards catching every message from perl itself ...
293			return if $self->checkExceptions();
294
295			# ... otherwise continue assuming everything is fine
296	joko	1.4	$self->mixinPackage($package) if $package;
297	joko	1.11
298	joko	1.1	}
299
300			1;
301	joko	1.7	__END__
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26