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

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

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

revision 1.1 by joko, Tue Feb 18 15:35:25 2003 UTC revision 1.13 by joko, Fri Dec 5 05:02:08 2003 UTC
# Line 2  Line 2 
2  ##  $Id$  ##  $Id$
3  ## ----------------------------------------------------------------------  ## ----------------------------------------------------------------------
4  ##  $Log$  ##  $Log$
5    ##  Revision 1.13  2003/12/05 05:02:08  joko
6    ##  + minor update: disabled some unnecessary loggers or changed to debug-level
7    ##
8    ##  Revision 1.12  2003/06/24 20:59:51  jonen
9    ##  added option 'detach'
10    ##
11    ##  Revision 1.11  2003/06/23 17:54:32  joko
12    ##  prepared execution of in-process perl-code via eval (not activated yet!)
13    ##
14    ##  Revision 1.10  2003/05/13 07:56:12  joko
15    ##  enhanced: *hierarchical* containers for context handling
16    ##  fixes: some pre-flight checks
17    ##  new: propagate "end-tag" event to e.g. close containers
18    ##
19    ##  Revision 1.9  2003/04/04 17:23:11  joko
20    ##  minor update: debugging output
21    ##
22    ##  Revision 1.8  2003/03/29 07:11:54  joko
23    ##  modified: sub run_executable
24    ##  new: sub run_script
25    ##
26    ##  Revision 1.7  2003/03/28 07:02:56  joko
27    ##  modified structure around '$wrapper_program'
28    ##
29    ##  Revision 1.6  2003/03/27 15:31:05  joko
30    ##  fixes to modules regarding new namespace(s) below Data::Mungle::*
31    ##
32    ##  Revision 1.5  2003/03/27 15:03:03  joko
33    ##  enhanced 'sub run_executable'
34    ##
35    ##  Revision 1.4  2003/02/22 16:51:21  joko
36    ##  + enhanced run_executable
37    ##  modified logging output
38    ##
39    ##  Revision 1.3  2003/02/21 01:46:17  joko
40    ##  renamed core function
41    ##
42    ##  Revision 1.2  2003/02/20 19:46:33  joko
43    ##  renamed and revamped some of modules
44    ##  renamed methods
45    ##  + sub run_executable
46    ##
47  ##  Revision 1.1  2003/02/18 15:35:25  joko  ##  Revision 1.1  2003/02/18 15:35:25  joko
48  ##  + initial commit  ##  + initial commit
49  ##  ##
# Line 15  use warnings; Line 57  use warnings;
57    
58    
59  use Data::Dumper;  use Data::Dumper;
 use Data::Transform::Deep qw( refexpr2perlref );  
 use Iterate;  
60  use Hash::Merge qw( merge );  use Hash::Merge qw( merge );
61    use Iterate;
62    
63    use shortcuts qw( run_cmd );
64    use Data::Mungle::Code::Ref qw( ref_slot );
65    use Data::Mungle::Transform::Deep qw( expand deep_copy );
66    use File::Temp qw/ tempfile tempdir /;
67    
68    my $DEBUG = 0;
69    
70  sub performTarget {  sub performTarget {
71    my $self = shift;    my $self = shift;
72    my $targetname = shift;    my $targetname = shift;
73    my $target = $self->getTargetMetadata($targetname);    $self->perform_target($targetname);
74    }
75    
76    sub perform_target {
77      my $self = shift;
78      my $targetname = shift;
79    
80      # pre-flight checks
81      if (!$targetname) {
82        $self->log("Target name empty. Please try to specify (e.g.) on the command line.", 'critical');
83        return;
84      }
85    
86      my $header = ("- " x 12) . "   " . $targetname . "   " . ("- " x 6);
87      
88      # V1
89      #$self->log("- " x 35, 'notice');
90      #$self->log("Performing Target '$targetname'.", 'notice');
91    
92      # V2
93      #$self->log($header, 'notice');
94    
95      # V3
96      #$self->log("- " x 20, 'info');
97      $self->log("Performing Target '$targetname'.", 'notice');
98    
99      #exit;
100    
101      my $target = $self->getTargetDetails($targetname);
102    
103    # trace    # trace
104      #print Dumper($target);      #print Dumper($target);
105      #exit;      #exit;
106            
107      $self->perform_dependencies($target);
108      $self->perform_details($target);
109      
110      return 1;
111    
112    }
113    
114    sub perform_dependencies {
115      my $self = shift;
116      my $target = shift;
117    # resolve dependencies (just run prior)    # resolve dependencies (just run prior)
118    if (my $targetname_dep = $target->{attrib}->{depends}) {    if (my $targetname_dep = $target->{attrib}->{depends}) {
119      $self->performTarget($targetname_dep);      my @targets = split(/,\s|,/, $targetname_dep);
120        #print Dumper(@targets);
121        #$self->perform($targetname_dep);
122        #delete $target->{attrib}->{depends};
123        foreach (@targets) {
124          if (!$self->{__rap}->{dependencies}->{resolved}->{$_}++) {
125            $self->perform_target($_);
126          }
127        }
128      delete $target->{attrib}->{depends};      delete $target->{attrib}->{depends};
129    }    }
130    }
131    
132    sub perform_details {
133      my $self = shift;
134      my $target = shift;
135      
136      #print Dumper($target);
137      #exit;
138      
139    foreach my $entry (@{$target->{content}}) {    foreach my $entry (@{$target->{content}}) {
140      my $command = $entry->{name};      my $command = $entry->{name};
141      my $args = $entry->{attrib};      my $args = $entry->{attrib};
142      $self->run_command($command, $args);      my $content = $entry->{content};
143        $self->perform_command($command, $args, $content, { warn => 1 } );
144        # check recursiveness
145        # new condition: don't recurse if node is flagged to have inline-args (2003-04-17)
146        my $has_inline_args = ($entry->{attrib}->{_args} && $entry->{attrib}->{_args} eq 'inline');
147        if ($entry->{content} && ref $entry->{content} && !$has_inline_args) {
148          $self->perform_details($entry);
149        }
150        # new of 2003-05-08
151        $command ||= '';
152        $self->perform_command($command . '_end', undef, undef, { warn => 0 } );
153    }    }
154  }  }
155    
156  sub rc {  sub rc {
157    my $self = shift;    my $self = shift;
158    return $self->run_command(@_);    return $self->perform_command(@_);
159  }  }
160    
161  sub run_command {  sub perform_command {
162    my $self = shift;    my $self = shift;
163    my $command = shift;    my $command = shift;
164        my $args_list = shift;
165      my $content = shift;
166      my $options = shift;
167    
168    if (!$command) {    if (!$command) {
169      $self->log("Command was empty!", 'warning');      $self->log("Command was empty!", 'debug') if $DEBUG;
170      return;      return;
171    }    }
172    
173      # FIXME: make '__PACKAGE__' go one level deeper properly!
174      $self->log( __PACKAGE__ . "->perform_command: " . $command, 'debug') if $DEBUG;
175        
176    my $args_list = shift;    
177      # 1. make arguments from list of arguments(?)
178    
179    my $args = {};    my $args = {};
180    #print Dumper($args_list);    #print Dumper($args_list);
181    if ($args_list) {    if ($args_list) {
# Line 68  sub run_command { Line 187  sub run_command {
187        $args = $args_list;        $args = $args_list;
188      }      }
189    }    }
190    $command = '_' . $command;    
191    if ($self->can($command)) {    
192      $self->$command($args);    # 2. prepare command
193      
194      # default setting for internal rap commands
195      my $method_prefix_default = '_';
196      # setting from property database
197      my $method_prefix_setting = $self->get_property('core.method_prefix');
198      #print "setting: ", $method_prefix_setting, "\n";
199      my $prefix = $method_prefix_setting;
200      if (not defined $prefix) {
201        $prefix = $method_prefix_default;
202      }
203      $command = $prefix . $command;
204      
205      
206      # 3. determine container
207      my $container; # = $self->getInstance();
208      #$container ||= $self->getInstance();
209      $container ||= $self;
210      
211      # 4. run method
212      if ($container->can($command)) {
213        $container->$command($args, $content);
214    } else {    } else {
215      $self->log("Command \"$command\" not implemented.", "warning");      my $level = "debug";
216        $level = "warning" if $options->{warn};
217        $self->log("Command '$command' not implemented.", $level) if $DEBUG;
218    }    }
219      
220  }  }
221    
 sub set_property {  
   my $self = shift;  
   my $args = shift;  
222    
223    my $name;  sub merge_properties {
224    my $value;    my $self = shift;
225        my $name = shift;
226    if (ref $args) {    my $data = shift;
     $self->interpolate($args) ;  
     $name = $args->{name};  
     $value = $args->{value};  
227    
228    } else {    $self->log("merge-name: $name");
229      $name = $args;    #print "name: $name", "\n";
230      $value = shift;    #print Dumper($data);
231    }    #exit;
232    
233    # check if slot (or childs of it) is/are already occupied    # check if slot (or childs of it) is/are already occupied
234    if (my $oldvalue = refexpr2perlref($self, $name, undef, '.')) {    #if (my $data_old = ref_slot($self, $name, undef, '.')) {
235      if (my $data_old = $self->get_property($name)) {
236        #print "old:", "\n";
237        #print Dumper($data_old);
238        
239      # FIXME: review - any options for 'merge' here?      # FIXME: review - any options for 'merge' here?
240      $value = merge($oldvalue, $value);      my $data_new = merge($data_old, $data);
241        #print "DATA NEE! - MERGE!", "\n";
242        #print Dumper($data_new);
243        #exit;
244        #merge_to($self, $data_new);
245        $self->set_property( { name => $name, value => $data_new } );
246        
247      } else {
248    
249    =pod    
250        # make up a dummy hash matching the structure of the destination one
251          my $dummy = {};
252          ref_slot($dummy, $name, $data, '.');
253          print Dumper($dummy);
254        
255        # mix into destination
256          mixin($self, $dummy, { init => 1 });
257    =cut
258    
259          ref_slot($self, $name, $data, '.');
260    
261    }    }
262      
263      
264      #print Dumper($self);
265      #exit;
266      #$self->
267    
268    }
269    
270    sub set_property {
271      my $self = shift;
272      my $args = shift;
273    
274      $self->interpolate($args) ;
275      my $name = $args->{name};
276      my $value = $args->{value};
277      $name = '__rap.properties.' . $name;
278    
279      $self->log("set-name: $name");
280    
281      #print Dumper($name, $value, '.');
282    
283    # fill property slot with given value    # fill property slot with given value
284    if ($value) {    # fix (2003-04-17): always do fill if value is *defined*!!!
285      refexpr2perlref($self, $name, $value, '.');    if (defined $value) {
286        ref_slot($self, $name, $value, '.');
287    }    }
288        
289      #print Dumper($self);
290      
291    # FIXME!!!    # FIXME!!!
292    return if ! ref $args;    #return if ! ref $args;
293    
294    # fill property slot with (probably bigger) data structure from property-/configuration-style - file    # fill property slot with (probably bigger) data structure from property-/configuration-style - file
295    if (my $file = $args->{file}) {    if (my $file = $args->{file}) {
# Line 123  sub set_property { Line 307  sub set_property {
307      }      }
308    
309    } elsif (my $command = $args->{command}) {    } elsif (my $command = $args->{command}) {
310      $self->run_command($command, $args);      $self->perform_command($command, $args);
311        
312    }    }
313    
# Line 137  sub get_property { Line 321  sub get_property {
321    #$self->interpolate($args);    #$self->interpolate($args);
322    
323    #my $name = $args->{name};    #my $name = $args->{name};
324      my $result;
325    
326    # get property slot and return value    if (!$name) {
327    return refexpr2perlref($self, $name, undef, '.');      $self->log( __PACKAGE__ . ": no name!", 'critical');
328        
329      } elsif ($name eq '/') {
330        $result = expand($self);
331    
332      } elsif ($name eq '.') {
333        if (my $instance = $self->getInstance()) {
334          $result = expand($instance);
335        } else {
336          $result = ref_slot($self, '__rap.properties', undef, '.');
337          
338        }
339    
340      } else {
341    
342        $name = '__rap.properties.' . $name;
343        
344        $self->log("get-name: $name") if $DEBUG;
345        
346        # get property slot and return value
347        $result = ref_slot($self, $name, undef, '.');
348        
349        # FIXME: Is this okay? It's provided for now in order not
350        # to deliver an 'undef' to the regex below inside 'interpolate'.
351        # revamp this, maybe!
352        #$result ||= '';    # NO!!!
353      }
354        
355      return $result;
356  }  }
357    
358  sub interpolate {  sub interpolate {
# Line 152  sub interpolate { Line 364  sub interpolate {
364    }    }
365  }  }
366    
367    sub run_executable {
368      my $self = shift;
369      my $opts = shift;
370    
371      my $meta = deep_copy($opts);
372    
373      delete $opts->{caption};
374      delete $opts->{async};
375      delete $opts->{detach};
376    
377      #print Dumper($meta);
378    
379      if ($opts->{executable}) {
380    
381        my $program = $opts->{executable};
382        delete $opts->{executable};
383    
384        # determine execution method
385        my $wrapper_program = '';
386        
387        # check if program is a namespace-string (contains '::') - use 'do' in this case!
388        if ($program =~ /::/) {
389          #$wrapper_program = 'rap.pl';
390          $wrapper_program = $0;
391        }
392    
393        # prepare arguments
394        my @buf;
395        foreach (keys %$opts) {
396          my $value = $opts->{$_};
397          if (m/^_/) {
398            if ($_ eq '_switches') {
399              my @switches = split(/,\s|,/, $value);
400              foreach my $switch (@switches) {
401                push @buf, '--' . $switch;
402              }
403            }
404            next;
405          }
406          
407          if ($value =~ /\s/) {
408            $value = "\"$value\"";
409          }
410          push @buf, "--$_=$value";
411        }
412    
413        # build {program} & {arguments}  
414        my $cmd = ($wrapper_program ? $wrapper_program . ' ' : '') . $program . ' ' . join(' ', @buf);
415        
416        # trace
417          #print "command: $cmd", "\n";
418        
419        # start process
420          # V1: via shortcut
421          #$ENV{PERL5LIB} = join(' ', @INC);
422          
423          # FIXME!!! what about the other slots of @INC?
424          $ENV{PERL5LIB} = $INC[0];
425          
426          #print Dumper(%ENV);
427          
428          #print "command: '$cmd'", "\n";
429    
430          # V1 - basic
431          #run_cmd($cmd);
432    
433          # V1.b - enhanced: variable local method
434          $meta->{caption} ||= '';
435          $meta->{async} ||= 0;
436          $meta->{detach} ||= 0;
437          # new of 2003-05-08: USE_PATH!
438          $meta->{USE_PATH} ||= 0;
439          my $evalstr = "run_cmd('$cmd', '$meta->{caption}', { async => $meta->{async}, detach => $meta->{detach}, USE_PATH => $meta->{USE_PATH} });";
440          eval($evalstr);
441          #my $res = do "$cmd";
442          #print $res, "\n" if $res;
443    
444          #$self->log("run_executable: $evalstr", 'info');
445          $self->raiseException("run_executable: $evalstr\n$@") if $@;
446    
447          # V2: via IPC::Run
448          # ....  (TODO)
449          
450        
451      }
452      
453    }
454    
455    
456    sub run_script {
457    
458      my $self = shift;
459      my $args = shift;
460      my $code = shift;
461    
462      if ($args->{language} eq 'msdos/bat') {
463        
464        #print "code: $code", "\n";
465        
466        # reporting
467        $self->log("Executing some arbitrary unsigned code (probably unsafe). [language=$args->{language}]", 'info');
468        $self->log("\n<code>\n$code\n</code>", 'info');
469        
470        # create temporary intermediate file to execute code
471        my $tmpdir = '/tmp/rap';
472        mkdir $tmpdir;
473        (my $fh, my $filename) = tempfile( DIR => $tmpdir, SUFFIX => '.bat' );
474        print $fh $code, "\n";
475        run_cmd( $filename, '', { async => 1 } );
476        
477        # FIXME: DELETE code inside temp-files as soon as possible!
478        #print $fh '';
479        
480        # TODO: delete FILE completely!
481        # required for this: wait until execution has finished, then unlink....
482        # but: "how to wait until execution is finished"?
483        # i believe the best is to spawn *another* process directly from here,
484        # let's call it 'watcher-agent'.
485        # This one should monitor a certain running process and delete its
486        # executable file after it has finished execution.
487        # Possible extensions could be:
488        #   keep track of all stuff sent to STDOUT or STDERR and
489        #   send that stuff to the task-owner indirectly (not via shell/console)
490        #   (e.g. via email, by posting report to a newsgroup or publishing on a specified web-page: use mod-dav!)
491        
492      } elsif ($args->{language} eq 'bash') {
493        $self->log("FIXME: - - - - - -- - - --  BASH -  - -    -  - -   -    --   - ", 'error');
494    
495      } elsif ($args->{language} eq 'perl') {
496        
497        # reporting
498        #$self->log("Executing some arbitrary unsigned code (probably unsafe). [language=$args->{language}]", 'info');
499        #$self->log("\n<code>\n$code\n</code>", 'info');
500        
501        # do it
502        #eval($code);
503        #$self->log("\n<code>\n$code\n</code>", 'error') if $@;
504        
505      } else {
506        $self->log("FIXME: Script language '$args->{language}' not implemented.", 'error');
507        
508      }
509    
510    }
511    
512  1;  1;
513  __END__  __END__
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.13
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed