/[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.4 by joko, Mon Jan 20 16:55:15 2003 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  ##  Revision 1.4  2003/01/20 16:55:15  joko
30  ##  + sub mixinPackage  ##  + sub mixinPackage
31  ##  + sub include  ##  + sub include
# Line 23  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;  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 40  use Data::Dumper; Line 69  use Data::Dumper;
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;  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 74  my $meta; Line 107  my $meta;
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 95  my $meta; Line 128  my $meta;
128            
129      # build full package name      # build full package name
130      my $self_classname = ref $self;      my $self_classname = ref $self;
131      my $package = $self_classname . '::' . $modulename_load;        # 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;      return $package;
141    }    }
142        
143    sub load {    sub load {
144    
145      my $self = shift;      my $self = shift;
146        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;      my $self_modulename = ref $self;
167      my $package = $self->_getPluginPackage($modulename_load);      my $package = $self->_getPluginPackage($modulename_load);
168            
# Line 111  my $meta; Line 170  my $meta;
170        return 1;        return 1;
171      }      }
172            
173      #$logger->info( __PACKAGE__ . "->load: $package" );      #$logger->info( __PACKAGE__ . "->load: $package" ) if $logger;
174      #$logger->info( __PACKAGE__ . "->load: $self_modulename" );      #$logger->info( __PACKAGE__ . "->load: $self_modulename" ) if $logger;
175      $logger->debug( $self_modulename . "->load: $package\t[via " . __PACKAGE__ . "]" );      $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        $meta->{loaded}->{$package} = 0;        $meta->{loaded}->{$package} = 0;
184        # include caller information        # include caller information
185        my @caller = caller;        my @caller = caller;
186        my $caller_msg = $caller[1] . ':' . $caller[2];        my $caller_msg = $caller[1] . ':' . $caller[2];
187        $logger->error( __PACKAGE__ . "->load: $@ ($caller_msg)" );        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 132  my $meta; Line 200  my $meta;
200      #bless $self, $package;      #bless $self, $package;
201    
202      # V2:      # V2:
     # switch into foreign package and mixin plugin-module  
203      $self->mixinPackage($package);      $self->mixinPackage($package);
204        
205        if (my $method = $options->{method}) {
206          $self->$method();
207        }
208    
209      return 1;      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'?    # TODO: maybe refactor to DesignPattern::Object? what about the '$logger'?
226    sub mixinPackage {    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;      my $self = shift;
245      my $package = shift;      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;      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        $meta->{loaded}->{$package} = 0;        $meta->{loaded}->{$package} = 0;
254        $logger->error( __PACKAGE__ . "->load: $@" );        $logger->error( __PACKAGE__ . "->load: $@" ) if $logger;
255      } else {      } else {
256        $meta->{loaded}->{$package} = 1;        $meta->{loaded}->{$package} = 1;
257      }      }
258        # FIXME: --- this is redundant ---
259    
260    }    }
261    
262    sub unload {    sub unload {
# Line 165  my $meta; Line 269  my $meta;
269      if ($meta->{loaded}->{$package}) {      if ($meta->{loaded}->{$package}) {
270        $meta->{loaded}->{$package} = 0;        $meta->{loaded}->{$package} = 0;
271        my $where = __PACKAGE__ . ':' . __LINE__;        my $where = __PACKAGE__ . ':' . __LINE__;
272        $logger->debug( __PACKAGE__ . "->unload: FIXME: DESTROY object is not implemented at '$where'." );        $logger->debug( __PACKAGE__ . "->unload: FIXME: DESTROY object is not implemented at '$where'." ) if $logger;
273      }      }
274    
275    }    }
# Line 180  my $meta; Line 284  my $meta;
284      my $self = shift;      my $self = shift;
285      my $includefile = shift;      my $includefile = shift;
286      my $package = shift;      my $package = shift;
287      # TODO: do better error-detection here / prevent dies under all circumstances!      
288      require $includefile;      # 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;      $self->mixinPackage($package) if $package;
301        
302    }    }
303    
304  1;  1;
305    __END__
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.11
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed