/[cvs]/nfo/perl/libs/Data/Rap/Command.pm
ViewVC logotype

Diff of /nfo/perl/libs/Data/Rap/Command.pm

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

revision 1.1 by joko, Tue Feb 18 15:35:06 2003 UTC revision 1.7 by joko, Tue May 13 07:52:14 2003 UTC
# Line 2  Line 2 
2  ##  $Id$  ##  $Id$
3  ## ----------------------------------------------------------------------  ## ----------------------------------------------------------------------
4  ##  $Log$  ##  $Log$
5    ##  Revision 1.7  2003/05/13 07:52:14  joko
6    ##  enhanced: *hierarchical* containers for context handling
7    ##  making methods from foreign context(s) available
8    ##  started: import of targets from foreign topics
9    ##
10    ##  Revision 1.6  2003/03/29 07:10:42  joko
11    ##  + sub _script:
12    ##    new rap-command: '<script language="msdos/bat|bash|...">...</script>'
13    ##
14    ##  Revision 1.5  2003/03/27 15:31:04  joko
15    ##  fixes to modules regarding new namespace(s) below Data::Mungle::*
16    ##
17    ##  Revision 1.4  2003/02/22 16:48:58  joko
18    ##  modified rapcall behaviour
19    ##
20    ##  Revision 1.3  2003/02/21 07:39:13  joko
21    ##  modified 'rapcall' processing
22    ##  modified merging of options/arguments in there
23    ##
24    ##  Revision 1.2  2003/02/20 19:37:09  joko
25    ##  renamed modules
26    ##  - removed command 'exec'
27    ##  + enhanced command 'rapcall' - now handles various different modes and behaviours
28    ##  renamed methods
29    ##  + command 'exit'
30    ##  + command 'use' - switch to foreign namespaces using contexts
31    ##
32  ##  Revision 1.1  2003/02/18 15:35:06  joko  ##  Revision 1.1  2003/02/18 15:35:06  joko
33  ##  + initial commit  ##  + initial commit
34  ##  ##
# Line 16  use warnings; Line 43  use warnings;
43    
44  use Data::Dumper;  use Data::Dumper;
45  use Hash::Merge qw( merge );  use Hash::Merge qw( merge );
 use shortcuts qw( run_cmd );  
 use DesignPattern::Object;  
46    
47    use DesignPattern::Object;
48    use Data::Mungle::Transform::Deep qw( merge_to );
49    use shortcuts qw( run_cmd );
50    
 sub _exec {  
   my $script = shift;  
   my $task = shift;  
     if ($script) {  
       my @buf;  
       foreach (keys %$task) {  
         my $value = $task->{$_};  
         if ($value =~ /\s/) {  
           $value = "\"$value\"";  
         }  
         push @buf, "--$_=$value";  
       }  
       my $cmd = $script . ' ' . join(' ', @buf);  
       run_cmd($cmd);  
     } else {  
       #$bizProcess->runSync($task);  
     }  
 }  
51    
52  sub _echo {  sub _echo {
53    my $self = shift;    my $self = shift;
# Line 65  sub _echo { Line 75  sub _echo {
75  sub _context {  sub _context {
76    my $self = shift;    my $self = shift;
77    my $args = shift;    my $args = shift;
78    #print Dumper($args);    print "_context-args: ", Dumper($args);
79    foreach my $task_command (keys %$args) {    foreach my $task_command (keys %$args) {
80      my $bunch = $args->{$task_command};      my $bunch = $args->{$task_command};
81      foreach my $task_args (@$bunch) {      foreach my $task_args (@$bunch) {
82        #print Dumper($task_args);        #print Dumper($task_args);
83        $self->run_command($task_command, $task_args);        $self->perform_command($task_command, $task_args);
84      }      }
85    }    }
86  }  }
# Line 81  sub _id {} Line 91  sub _id {}
91  # FIXME  # FIXME
92  sub _description {}  sub _description {}
93    
94  sub _feed {  # NEW [2003-05-08]: Hierarchical handling (stack push/pop instead of set/get).
95    # TODO: Named Containers.
96    sub _container {
97    my $self = shift;    my $self = shift;
98        my $args = shift;
99      $self->pushContainer($args);
100  }  }
101    
102  sub _bootDatabases {  sub _container_end {
103    my $self = shift;    my $self = shift;
104  #print Dumper($self->{config}->{databases});    my $args = shift;
105      $self->popContainer();
106    $self->log("Using Database(s): " . join(', ', @{$self->{use_databases}}), 'info');  }
107    
108    my $dbcfg;  sub _sync {
109    my $container = DesignPattern::Object->fromPackage('Data::Storage::Container');    my $self = shift;
110      my $args = shift;
111      
112      #print Dumper($args);
113      
114      # V1
115      #$bizProcess->runSync($task);
116      
117      #V2
118      my $container = $self->getInstance();
119      $container ||= $self;
120      $container->runSync($args);
121        
   # just boot specified databases  
   if (my $dbkeys = $self->{use_databases}) {  
     foreach (@$dbkeys) {  
       $dbcfg->{$_} = $self->{config}->{databases}->{$_};  
     }  
       
   # boot all databases  
   } else {  
     $dbcfg = $self->{config}->{databases};  
   }  
   
   foreach (keys %$dbcfg) {  
     $container->addConfig($_, $dbcfg->{$_});  
   }  
   
   $container->initLocators();  
   $container->initStorages();  
   
   foreach (keys %{$container->{storage}}) {  
     $self->{storage}->{$_} = $container->{storage}->{$_};  
   }  
122  }  }
123    
124  sub _depends_old {  sub _depends_old {
# Line 129  sub _dump { Line 132  sub _dump {
132    my $self = shift;    my $self = shift;
133    my $args = shift;    my $args = shift;
134    my $name = $args->{name};    my $name = $args->{name};
135    my $message = Dumper($self->{$name});    my $message = Dumper($self->get_property($name));
136    $self->rc('echo', $message, $args->{level});    $self->rc('echo', "\n" . $message, $args->{level});
137  }  }
138    
139    
140  sub _plugin {  sub _plugin {
141    my $self = shift;    my $self = shift;
142    my $args = shift;    my $args = shift;
143    if (my $name = $args->{name}) {    my $content = shift;
144      $self->load($name);  
145      if (my $instance = $args->{instance}) {
146        #$self->{$instance} = DesignPattern::Object->fromPackage($args->{module});
147        my $object = DesignPattern::Object->fromPackage($args->{module});
148        #$self->{$instance}
149        #print Dumper($object);
150        #$object->constructor() if $object->can('constructor');
151      
152      } elsif (my $name = $args->{name}) {
153        
154        # 1. namespaces - load module into current scope or foreign namespace?
155          my $container;
156          if (my $namespace = $args->{namespace}) {
157            
158            $self->log("Loading plugin '$name' into foreign namespace '$namespace'.", 'info');
159            
160            eval qq{
161    
162              # 0. pre-flight check|trace
163                #print "YAI";
164                #$self->log('YAIYAI', 'info');    # FIXME!
165              
166              # 1. work in foreign namespace
167                package $namespace;
168                use strict;
169                use warnings;
170              # 2. mungle with/the
171                #   - package namespace (llp)
172                #   - object (lloo)
173                #   - inheritance (lloo)
174                #   - plugin (hlf)
175                # symbols for scopes:
176                #   - llp = low-level perl
177                #   - lloo = low-level oo
178                #   - hlf = high-level framework
179                # bless larry for perl having this implemented in an orthogonal way
180              # 2.1: behaviour=coerce
181                #use base qw( $name );
182              # 2.2: behaviour=plugin
183                use base qw( DesignPattern::Bridge );
184              1;
185            };
186            $self->checkExceptions();
187            $container = $namespace->new();
188    
189          } elsif (my $instance = $self->getInstance()) {
190            $self->log("Loading plugin '$name' into foreign namespace of instance '" . (ref $instance) . "'.", 'info');
191            $container = $instance;
192    
193          } else {
194            #$self->log("Loading plugin '$name' into local scope's namespace (ref \$self='" . (ref $self) . "').", 'info');
195            $self->log("Loading plugin '$name' into local namespace '" . (ref $self) . "'.", 'info');
196            $container = $self;
197          }
198    
199        # 1.b. intermediate checks
200          if (!$container) {
201            $self->log("No container to load '$name' into!", 'warning');
202            return;
203          }
204          
205        # 1.c. inheritance of (e.g.) properties
206          if (my $inherit = $args->{inherit}) {
207            my $properties = $self->get_property($inherit);
208            merge_to($container, { $inherit => $properties }, { init => 1 } );
209          }
210    
211        # 2. plugin - load module into container
212          $container->load($name);
213    
214        # 3. methods - run object methods    
215    
216          # payload inside $content is the $args to the $method
217          # convert xml-style payload inside $content to trivial (not-nested) perl hash
218          # using just encapsulated text of the nodes as hash values
219          my $method_args;
220          foreach (@$content) {
221            my $key = $_->{name};
222            my $value = $_->{content}->[0]->{content};
223            $method_args->{$key} = $value;
224          }
225          # convert hashref to arrayref
226          $method_args = [ %$method_args ] if ref $method_args eq 'HASH';
227    
228          if (my $methods = $args->{methods}) {
229            my @methods = split(/,|,\s/, $methods);
230            foreach (@methods) {
231              $self->log("Running method '$_'.", 'info');
232              #print Dumper($method_args);
233              # check for existance of method
234              if ($container->can($_)) {
235                # dispatch call by being with or without arguments
236                print "method_args: ", Dumper($method_args);
237                if ($method_args) {
238                  $container->$_(@$method_args);
239                } else {
240                  $container->$_();
241                }
242              }
243            }
244          }
245          
246        # 4. instances - create references in local scope
247          if (my $instances = $args->{instances}) {
248            my @instances = split(/,|,\s/, $instances);
249            foreach (@instances) {
250              $self->log("Creating instance '$_'.", 'info');
251              $self->{$_} = $container;
252            }
253          }
254        
255        
256    }    }
257  }  }
258    
259  sub _rapcall {  sub _rapcall {
260    my $self = shift;    my $self = shift;
261    my $args = shift;    my $args = shift;
262    
263      # merge container arguments to local ones if desired/requested/forced
264      if (my $container = $self->getContainer()) {
265        #my $opts = merge($container, $args);
266        #print Dumper($container);
267        merge_to($args, $container, { init => 1 });
268      }
269      
270      # trace
271      #print Dumper($args);
272    
273      # action dispatcher, either do:
274      #   - run an executable program [ext]
275      #   - call a command (?) [rap]
276      #   - a rap target [rap]
277      #   - a code method [ext]
278      
279      if ($args->{executable}) {
280        $self->run_executable($args);
281        return;
282      }
283    
284    if (my $command = $args->{command}) {    if (my $command = $args->{command}) {
285      $self->run_command($command, $args);      $self->perform_command($command, $args);
286        return;
287      }
288    
289      if (my $target = $args->{target}) {
290        $self->performTarget($target, $args);
291        return;
292      }
293    
294      if (my $method = $args->{method}) {
295        #$self->performTarget($target, $args);
296        if (my $refkey = $args->{base}) {
297          #eval($namespace . '::' . $method . '();');
298          #die($@) if $@;
299          #print Dumper($self);
300          
301          #if ($args->{args} && lc $args->{args} eq 'array') {
302            #print Dumper($args);
303            #print Dumper($self);
304          #}
305          
306          # V1 - no arguments were being propagated
307          #$self->{$refkey}->$method();
308          # V2 - trying this....
309          $self->{$refkey}->$method();
310    
311        } elsif (my $ref = $self->getInstance()) {
312          $ref->$method();
313        }
314        
315        return;
316    
317      }
318      
319    }
320    
321    sub _exit {
322      exit;
323    }
324    
325    sub _use {
326      my $self = shift;
327      my $args = shift;
328      
329      # new of ~2003-04-15: making methods from foreign context(s) available
330      if (my $name = $args->{name}) {
331        $args->{type} ||= '';
332        $self->log("Switching to $args->{type} '$name'.", 'info');
333        $self->setInstance($self->{$name}) if $args->{type} eq 'instance';
334      }
335      
336      # new of ~2003-04-15: making methods from foreign context(s) available
337      if (exists $args->{method_prefix}) {
338        #print "YAI", "\n";
339        #print Dumper($args);
340        $self->set_property( { name => 'core.method_prefix', value => $args->{method_prefix} } );
341    }    }
342        
343      # TODO: (possible feature)
344      # check for $args->{export_rap_commands} to export core rap-commands
345      # from rap engine's scope to the worker's
346      
347  }  }
348    
349    sub _script {
350      my $self = shift;
351      my $args = shift;
352      my $content = shift;
353      
354      # trace
355      #print Dumper($args);
356      #print Dumper($content);
357    
358      my $code = $content->[0]->{content};
359      $code ||= '';
360    
361      $self->run_script($args, $code);
362      
363    }
364    
365    sub _import {
366      my $self = shift;
367      my $args = shift;
368      #my $content = shift;
369    
370      if (!$args->{topic}) {
371        $self->log("Please specify topic.", 'warning');
372        return;
373      }
374    
375      $self->log("Importing all targets from topic '$args->{topic}'.", 'info');
376      
377      #print Dumper($self);
378      # FIXME: This was started off, but not finished!
379      print "registry: ", Dumper($Data::Rap::registry);
380      
381    }
382    
383  1;  1;
384  __END__  __END__
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.7
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed