/[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.10 by joko, Thu Feb 20 20:50:32 2003 UTC
# Line 2  Line 2 
2  ##  $Id$  ##  $Id$
3  ## --------------------------------------------------------------------------------  ## --------------------------------------------------------------------------------
4  ##  $Log$  ##  $Log$
5    ##  Revision 1.10  2003/02/20 20:50:32  joko
6    ##  + small exception handling: now inheriting from little Exception object
7    ##
8    ##  Revision 1.9  2003/02/18 18:35:30  joko
9    ##  + encapsulated/abstracted some more functionality: sub load_single
10    ##
11    ##  Revision 1.8  2003/02/14 14:20:05  joko
12    ##  + modified mixin behaviour
13    ##
14    ##  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    ##  Revision 1.6  2003/02/09 16:22:51  joko
20    ##  + pseudo constructor mechanism via options
21    ##
22    ##  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    ##  Revision 1.4  2003/01/20 16:55:15  joko
26    ##  + sub mixinPackage
27    ##  + sub include
28    ##
29    ##  Revision 1.3  2002/12/16 19:57:12  joko
30    ##  + sub unload
31    ##
32    ##  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  ##  Revision 1.1  2002/12/13 21:46:29  joko  ##  Revision 1.1  2002/12/13 21:46:29  joko
36  ##  + initial check-in  ##  + initial check-in
37  ##  ##
# Line 13  package DesignPattern::Bridge; Line 43  package DesignPattern::Bridge;
43  use strict;  use strict;
44  use warnings;  use warnings;
45    
46  use base qw( DesignPattern::Object );  use base qw(
47      DesignPattern::Object
48      DesignPattern::Exception
49    );
50    
51    use Data::Dumper;
52    
53  ## ========   object inheritance   ========  ## ========   object inheritance   ========
54    
55  # TODO:  # TODO / REFACTORING PROPOSAL
56    # leading from Data::Storage to code abstracted out into this module - DesignPattern::Bridge
57  #   - this is no inheritance and it doesn't have to be  #   - this is no inheritance and it doesn't have to be
58  #   - implement this module as a bridge to its sub-modules  #   - implement this module as a bridge to its sub-modules
59  #   - 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 64  use base qw( DesignPattern::Object );
64  #   - sub getChildNodes  #   - sub getChildNodes
65  #   - sub run  #   - sub run
66    
67    # 2003-02-11, joko: does this have anything in parallel with CPAN's Class::Inner?
68    
69    
70  # get logger instance  # get logger instance
71  my $logger = Log::Dispatch::Config->instance;  my $logger = eval { Log::Dispatch::Config->instance; };
72        
73    my $meta;
74    
75  ## ========   object constructor   ========  ## ========   object constructor   ========
76    sub new {  sub new {
77      my $invocant = shift;    my $invocant = shift;
78      my $class = ref($invocant) || $invocant;    my $class = ref($invocant) || $invocant;
79      my @args = ();    my @args = ();
80      @_ && (@args = @_);    @_ && (@args = @_);
81      $logger->debug( __PACKAGE__ . "->new(@args)" );    $logger->debug( __PACKAGE__ . "->new(@args)" ) if $logger;
82      my $self = { @_ };    my $self = { @_ };
83    
84      # trace
85      #print "class: $class", "\n";      #print "class: $class", "\n";
86      bless $self, $class;  
87      ##if (my $bizWorks = shift) {    # create instance
88        ##$self->boot($bizWorks);    bless $self, $class;
89      ##}    
90          return $self;
91      return $self;  }
   }  
92    
93    
94  ## ========   method overrider   ========  ## ========   method overrider   ========
# Line 61  my $logger = Log::Dispatch::Config->inst Line 102  my $logger = Log::Dispatch::Config->inst
102      my $method = $AUTOLOAD;      my $method = $AUTOLOAD;
103      $method =~ s/^.*:://;      $method =~ s/^.*:://;
104        
105      $logger->debug( __PACKAGE__ . "->" . $method . "(@_)" . " (AUTOLOAD called, not dispatched)" );      $logger->debug( __PACKAGE__ . "->" . $method . "(@_)" . " (AUTOLOAD called, not dispatched)" ) if $logger;
106    
107      ## ->DESTROY would - if not declared - trigger an AUTOLOAD also      ## ->DESTROY would - if not declared - trigger an AUTOLOAD also
108      return if $method =~ m/::DESTROY$/;      return if $method =~ m/::DESTROY$/;
# Line 72  my $logger = Log::Dispatch::Config->inst Line 113  my $logger = Log::Dispatch::Config->inst
113  ##    }  ##    }
114            
115    }    }
116    
117      sub _getPluginPackage {
118        my $self = shift;
119        my $modulename_load = shift;
120    
121        # substitute slashes through double double-colons to load modules perl-style
122        $modulename_load =~ s/\//::/g;
123        
124        # build full package name
125        my $self_classname = ref $self;
126          # name
127          my $package = $modulename_load;
128          
129          # if package is absolute, cut away prefix ('/' or '::')
130          if ($package !~ s/^:://) {
131            # else: prefix with base classname if above name is relative (lacks of '/' or '::')
132            $package = $self_classname . '::' . $package
133          }
134        
135        return $package;
136      }
137        
138    sub load {    sub load {
139    
140      my $self = shift;      my $self = shift;
141      my $self_classname = ref $self;      my $modulename = shift;
142        my $options = shift;
143    
144        if (ref $modulename eq 'ARRAY') {
145          foreach (@$modulename) {
146            $self->load_single($_, $options);
147          }
148        } else {
149          $self->load_single($modulename, $options);
150        }
151    
152      }
153    
154      sub load_single {
155    
156        my $self = shift;
157      my $modulename_load = shift;      my $modulename_load = shift;
158    
159        my $options = shift;
160    
161        my $self_modulename = ref $self;
162        my $package = $self->_getPluginPackage($modulename_load);
163        
164        if ($meta->{loaded}->{$package}) {
165          return 1;
166        }
167            
168      my $package = $self_classname . '::' . $modulename_load;      #$logger->info( __PACKAGE__ . "->load: $package" ) if $logger;
169      $logger->info( __PACKAGE__ . "->load: $package" );      #$logger->info( __PACKAGE__ . "->load: $self_modulename" ) if $logger;
170        $logger->debug( $self_modulename . "->load: $package\t[via " . __PACKAGE__ . "]" ) if $logger;
171    
172      # 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
173      eval("use $package;");      eval("use $package;");
174        $self->checkExceptions();
175        
176    =pod    
177      if ($@) {      if ($@) {
178        $logger->error( __PACKAGE__ . "->load: $@" );        $meta->{loaded}->{$package} = 0;
179          # include caller information
180          my @caller = caller;
181          my $caller_msg = $caller[1] . ':' . $caller[2];
182          my $msg =  __PACKAGE__ . "->load: $@ ($caller_msg)";
183          if ($logger) {
184            $logger->error($msg);
185          } else {
186            print $msg, "\n";
187          }
188      }      }
189    =cut
190    
191  #print "ref-1: ", ref $self, "\n";  #print "ref-1: ", ref $self, "\n";
192  #print "ref-2: ", ref $self::SUPER, "\n";  #print "ref-2: ", ref $self::SUPER, "\n";
# Line 96  my $logger = Log::Dispatch::Config->inst Line 195  my $logger = Log::Dispatch::Config->inst
195      #bless $self, $package;      #bless $self, $package;
196    
197      # V2:      # V2:
198        $self->mixinPackage($package);
199        
200        if (my $method = $options->{method}) {
201          $self->$method();
202        }
203    
204        return 1;
205        
206      }
207      
208      sub mixinPackage {
209        my $self = shift;
210        my $package = shift;
211        
212        # switch into foreign package and prepare for mixin
213        $self->mixin_prepare($package);
214    
215        # switch into local package (scope which uses DesignPattern::Bridge) and mixin plugin-module
216        $self->mixin_do($package);
217    
218      }
219    
220      # TODO: maybe refactor to DesignPattern::Object? what about the '$logger'?
221      sub mixin_prepare {
222        my $self = shift;
223        my $package = shift;
224        my $self_classname = ref $self;
225        eval("package $package; use mixin::with '$self_classname';");
226    
227        # FIXME: --- this is redundant ---
228        if ($@) {
229          $meta->{loaded}->{$package} = 0;
230          $logger->error( __PACKAGE__ . "->load: $@" ) if $logger;
231        } else {
232          $meta->{loaded}->{$package} = 1;
233        }
234        # FIXME: --- this is redundant ---
235    
236      }
237    
238      sub mixin_do {
239        my $self = shift;
240        my $package = shift;
241      # switch into foreign package and mixin plugin-module      # switch into foreign package and mixin plugin-module
242        my $self_classname = ref $self;
243      eval("package $self_classname; use mixin '$package';");      eval("package $self_classname; use mixin '$package';");
244      #eval("use mixin_all '$package';");      #eval("use mixin_all '$package';");
245    
246        # FIXME: --- this is redundant ---
247      if ($@) {      if ($@) {
248        $logger->error( __PACKAGE__ . "->load: $@" );        $meta->{loaded}->{$package} = 0;
249          $logger->error( __PACKAGE__ . "->load: $@" ) if $logger;
250        } else {
251          $meta->{loaded}->{$package} = 1;
252      }      }
253        # FIXME: --- this is redundant ---
254    
255      }
256    
257      sub unload {
258    
259        my $self = shift;
260        my $modulename_unload = shift;
261    
262        my $package = $self->_getPluginPackage($modulename_unload);
263            
264        if ($meta->{loaded}->{$package}) {
265          $meta->{loaded}->{$package} = 0;
266          my $where = __PACKAGE__ . ':' . __LINE__;
267          $logger->debug( __PACKAGE__ . "->unload: FIXME: DESTROY object is not implemented at '$where'." ) if $logger;
268        }
269    
270    }    }
271    
272    
273    sub boot {    sub boot {
274      my $self = shift;      my $self = shift;
275      $self->_abstract_function('boot');      $self->_abstract_function('boot');
276    }    }
277      
278      sub include {
279        my $self = shift;
280        my $includefile = shift;
281        my $package = shift;
282        # TODO: do better error-detection here / prevent dies under all circumstances!
283        require $includefile;
284        $self->mixinPackage($package) if $package;
285      }
286    
287  1;  1;
288    __END__
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.10
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed