/[cvs]/nfo/perl/libs/DesignPattern/Bridge.pm
ViewVC logotype

Diff of /nfo/perl/libs/DesignPattern/Bridge.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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