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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (hide annotations)
Sat Mar 29 07:11:54 2003 UTC (21 years, 3 months ago) by joko
Branch: MAIN
Changes since 1.7: +74 -7 lines
modified: sub run_executable
new: sub run_script

1 joko 1.1 ## ----------------------------------------------------------------------
2 joko 1.8 ## $Id: Engine.pm,v 1.7 2003/03/28 07:02:56 joko Exp $
3 joko 1.1 ## ----------------------------------------------------------------------
4 joko 1.2 ## $Log: Engine.pm,v $
5 joko 1.8 ## Revision 1.7 2003/03/28 07:02:56 joko
6     ## modified structure around '$wrapper_program'
7     ##
8 joko 1.7 ## Revision 1.6 2003/03/27 15:31:05 joko
9     ## fixes to modules regarding new namespace(s) below Data::Mungle::*
10     ##
11 joko 1.6 ## Revision 1.5 2003/03/27 15:03:03 joko
12     ## enhanced 'sub run_executable'
13     ##
14 joko 1.5 ## Revision 1.4 2003/02/22 16:51:21 joko
15     ## + enhanced run_executable
16     ## modified logging output
17     ##
18 joko 1.4 ## Revision 1.3 2003/02/21 01:46:17 joko
19     ## renamed core function
20     ##
21 joko 1.3 ## Revision 1.2 2003/02/20 19:46:33 joko
22     ## renamed and revamped some of modules
23     ## renamed methods
24     ## + sub run_executable
25     ##
26 joko 1.2 ## Revision 1.1 2003/02/18 15:35:25 joko
27     ## + initial commit
28     ##
29 joko 1.1 ## ----------------------------------------------------------------------
30    
31    
32     package Data::Rap::Engine;
33    
34     use strict;
35     use warnings;
36    
37    
38     use Data::Dumper;
39 joko 1.2 use Hash::Merge qw( merge );
40 joko 1.1 use Iterate;
41 joko 1.2
42     use shortcuts qw( run_cmd );
43 joko 1.6 use Data::Mungle::Code::Ref qw( ref_slot );
44 joko 1.8 use Data::Mungle::Transform::Deep qw( expand deep_copy );
45     use File::Temp qw/ tempfile tempdir /;
46 joko 1.1
47    
48     sub performTarget {
49     my $self = shift;
50     my $targetname = shift;
51 joko 1.2 $self->perform_target($targetname);
52     }
53    
54     sub perform_target {
55     my $self = shift;
56     my $targetname = shift;
57    
58 joko 1.4 my $header = ("- " x 12) . " " . $targetname . " " . ("- " x 6);
59    
60 joko 1.8 # V1
61 joko 1.4 #$self->log("- " x 35, 'notice');
62     #$self->log("Performing Target '$targetname'.", 'notice');
63    
64 joko 1.8 # V2
65     #$self->log($header, 'notice');
66    
67     # V3
68     $self->log("- " x 35, 'info');
69     $self->log("Performing Target '$targetname'.", 'notice');
70 joko 1.2
71     #exit;
72    
73     my $target = $self->getTargetDetails($targetname);
74 joko 1.1
75     # trace
76     #print Dumper($target);
77     #exit;
78    
79 joko 1.2 $self->perform_dependencies($target);
80     $self->perform_details($target);
81    
82     }
83    
84     sub perform_dependencies {
85     my $self = shift;
86     my $target = shift;
87 joko 1.1 # resolve dependencies (just run prior)
88     if (my $targetname_dep = $target->{attrib}->{depends}) {
89 joko 1.2 my @targets = split(/,\s|,/, $targetname_dep);
90     #print Dumper(@targets);
91     #$self->perform($targetname_dep);
92     #delete $target->{attrib}->{depends};
93     foreach (@targets) {
94     if (!$self->{__rap}->{dependencies}->{resolved}->{$_}++) {
95     $self->perform_target($_);
96     }
97     }
98 joko 1.1 delete $target->{attrib}->{depends};
99     }
100 joko 1.2 }
101 joko 1.1
102 joko 1.2 sub perform_details {
103     my $self = shift;
104     my $target = shift;
105    
106     #print Dumper($target);
107     #exit;
108    
109 joko 1.1 foreach my $entry (@{$target->{content}}) {
110     my $command = $entry->{name};
111     my $args = $entry->{attrib};
112 joko 1.8 my $content = $entry->{content};
113     $self->perform_command($command, $args, $content);
114 joko 1.2 # check recursiveness
115     if ($entry->{content} && ref $entry->{content}) {
116     $self->perform_details($entry);
117     }
118 joko 1.1 }
119     }
120    
121     sub rc {
122     my $self = shift;
123 joko 1.2 return $self->perform_command(@_);
124 joko 1.1 }
125    
126 joko 1.2 sub perform_command {
127 joko 1.1 my $self = shift;
128     my $command = shift;
129 joko 1.8 my $args_list = shift;
130     my $content = shift;
131 joko 1.2
132 joko 1.1 if (!$command) {
133 joko 1.4 $self->log("Command was empty!", 'debug');
134 joko 1.1 return;
135     }
136 joko 1.2
137     # FIXME: make '__PACKAGE__' go one level deeper properly!
138     $self->log( __PACKAGE__ . "->perform_command: " . $command, 'debug');
139 joko 1.1
140     my $args = {};
141     #print Dumper($args_list);
142     if ($args_list) {
143     if (ref $args_list eq 'ARRAY') {
144     foreach (@$args_list) {
145     $args = merge($args, $_);
146     }
147     } else {
148     $args = $args_list;
149     }
150     }
151     $command = '_' . $command;
152 joko 1.2
153    
154     # determine container
155     my $container; # = $self->getInstance();
156     $container ||= $self;
157    
158     if ($container->can($command)) {
159 joko 1.8 $container->$command($args, $content);
160 joko 1.1 } else {
161 joko 1.2 $self->log("Command '$command' not implemented.", "warning");
162 joko 1.1 }
163 joko 1.2
164 joko 1.1 }
165    
166 joko 1.2
167     sub merge_properties {
168 joko 1.1 my $self = shift;
169 joko 1.2 my $name = shift;
170     my $data = shift;
171 joko 1.1
172 joko 1.2 $self->log("merge-name: $name");
173     #print "name: $name", "\n";
174     #print Dumper($data);
175     #exit;
176 joko 1.1
177 joko 1.2 # check if slot (or childs of it) is/are already occupied
178     #if (my $data_old = ref_slot($self, $name, undef, '.')) {
179     if (my $data_old = $self->get_property($name)) {
180     #print "old:", "\n";
181     #print Dumper($data_old);
182    
183     # FIXME: review - any options for 'merge' here?
184     my $data_new = merge($data_old, $data);
185     #print "DATA NEE! - MERGE!", "\n";
186     #print Dumper($data_new);
187     #exit;
188 joko 1.3 #merge_to($self, $data_new);
189 joko 1.2 $self->set_property( { name => $name, value => $data_new } );
190    
191 joko 1.1 } else {
192 joko 1.2
193     =pod
194     # make up a dummy hash matching the structure of the destination one
195     my $dummy = {};
196     ref_slot($dummy, $name, $data, '.');
197     print Dumper($dummy);
198    
199     # mix into destination
200     mixin($self, $dummy, { init => 1 });
201     =cut
202    
203     ref_slot($self, $name, $data, '.');
204    
205 joko 1.1 }
206 joko 1.2
207    
208     #print Dumper($self);
209     #exit;
210     #$self->
211    
212     }
213 joko 1.1
214 joko 1.2 sub set_property {
215     my $self = shift;
216     my $args = shift;
217    
218     $self->interpolate($args) ;
219     my $name = $args->{name};
220     my $value = $args->{value};
221     $name = '__rap.properties.' . $name;
222    
223     $self->log("set-name: $name");
224 joko 1.1
225     # fill property slot with given value
226     if ($value) {
227 joko 1.2 ref_slot($self, $name, $value, '.');
228 joko 1.1 }
229    
230 joko 1.2 #print Dumper($self);
231    
232 joko 1.1 # FIXME!!!
233 joko 1.2 #return if ! ref $args;
234 joko 1.1
235     # fill property slot with (probably bigger) data structure from property-/configuration-style - file
236     if (my $file = $args->{file}) {
237     my $type = $args->{type};
238     if (!$type) {
239     die("default file (no type specified) is not implemented yet!");
240    
241     } elsif ($type eq 'perl-eval') {
242     #die($type);
243     $self->loadFromPerlFile($file, $name, $args->{'varnames'});
244    
245     } elsif ($type eq 'App::Config') {
246     die("not implemented: $type");
247    
248     }
249    
250     } elsif (my $command = $args->{command}) {
251 joko 1.2 $self->perform_command($command, $args);
252 joko 1.1
253     }
254    
255     }
256    
257     sub get_property {
258     my $self = shift;
259     #my $args = shift;
260     my $name = shift;
261    
262     #$self->interpolate($args);
263    
264     #my $name = $args->{name};
265 joko 1.2 my $result;
266    
267     if (!$name) {
268     $self->log( __PACKAGE__ . ": no name!", 'critical');
269    
270     } elsif ($name eq '/') {
271     $result = expand($self);
272    
273     } elsif ($name eq '.') {
274     if (my $instance = $self->getInstance()) {
275     $result = expand($instance);
276     } else {
277     $result = ref_slot($self, '__rap.properties', undef, '.');
278    
279     }
280 joko 1.1
281 joko 1.2 } else {
282    
283     $name = '__rap.properties.' . $name;
284    
285     $self->log("get-name: $name");
286    
287     # get property slot and return value
288     $result = ref_slot($self, $name, undef, '.');
289    
290     # FIXME: Is this okay? It's provided for now in order not
291     # to deliver an 'undef' to the regex below inside 'interpolate'.
292     # revamp this, maybe!
293     #$result ||= ''; # NO!!!
294     }
295 joko 1.1
296 joko 1.2 return $result;
297 joko 1.1 }
298    
299     sub interpolate {
300     my $self = shift;
301     my $ref = shift;
302     IterHash %$ref, sub {
303     #print $_[1], "\n";
304     $_[1] =~ s/\${(.+)}/$self->get_property($1)/e;
305     }
306     }
307 joko 1.2
308     sub run_executable {
309     my $self = shift;
310     my $opts = shift;
311    
312 joko 1.8 my $meta = deep_copy($opts);
313    
314     delete $opts->{caption};
315     delete $opts->{async};
316    
317     #print Dumper($meta);
318    
319 joko 1.2 if ($opts->{executable}) {
320    
321     my $program = $opts->{executable};
322     delete $opts->{executable};
323    
324 joko 1.5 # determine execution method
325     my $wrapper_program = '';
326    
327     # check if program is a namespace-string (contains '::') - use 'do' in this case!
328     if ($program =~ /::/) {
329 joko 1.7 #$wrapper_program = 'rap.pl';
330     $wrapper_program = $0;
331 joko 1.5 }
332    
333     # prepare arguments
334 joko 1.2 my @buf;
335     foreach (keys %$opts) {
336     my $value = $opts->{$_};
337 joko 1.4 if (m/^_/) {
338     if ($_ eq '_switches') {
339     my @switches = split(/,\s|,/, $value);
340     foreach my $switch (@switches) {
341     push @buf, '--' . $switch;
342     }
343     }
344     next;
345     }
346    
347 joko 1.2 if ($value =~ /\s/) {
348     $value = "\"$value\"";
349     }
350     push @buf, "--$_=$value";
351     }
352 joko 1.5
353     # build {program} & {arguments}
354 joko 1.7 my $cmd = ($wrapper_program ? $wrapper_program . ' ' : '') . $program . ' ' . join(' ', @buf);
355 joko 1.2
356     # trace
357     #print "command: $cmd", "\n";
358    
359     # start process
360     # V1: via shortcut
361     #$ENV{PERL5LIB} = join(' ', @INC);
362    
363     # FIXME!!! what about the other slots of @INC?
364     $ENV{PERL5LIB} = $INC[0];
365    
366     #print Dumper(%ENV);
367 joko 1.5
368 joko 1.7 #print "command: '$cmd'", "\n";
369 joko 1.5
370     # V1 - basic
371     #run_cmd($cmd);
372    
373     # V1.b - enhanced: variable local method
374 joko 1.8 $meta->{caption} ||= '';
375     $meta->{async} ||= 0;
376     my $evalstr = "run_cmd('$cmd', '$meta->{caption}', { async => $meta->{async} });";
377 joko 1.5 eval($evalstr);
378     #my $res = do "$cmd";
379     #print $res, "\n" if $res;
380    
381     #$self->log("run_executable: $evalstr", 'info');
382     $self->raiseException("run_executable: $evalstr\n$@") if $@;
383    
384 joko 1.2 # V2: via IPC::Run
385     # .... (TODO)
386 joko 1.7
387 joko 1.2
388     }
389    
390     }
391    
392 joko 1.8
393     sub run_script {
394    
395     my $self = shift;
396     my $args = shift;
397     my $code = shift;
398    
399     if ($args->{language} eq 'msdos/bat') {
400    
401     #print "code: $code", "\n";
402    
403     # reporting
404     $self->log("Executing some arbitrary unsigned code (probably unsafe). [language=$args->{language}]", 'info');
405     $self->log("\n<code>\n$code\n</code>", 'info');
406    
407     # create temporary intermediate file to execute code
408     my $tmpdir = '/tmp/rap';
409     mkdir $tmpdir;
410     (my $fh, my $filename) = tempfile( DIR => $tmpdir, SUFFIX => '.bat' );
411     print $fh $code, "\n";
412     run_cmd( $filename, '', { async => 1 } );
413    
414     # FIXME: DELETE code inside temp-files as soon as possible!
415     #print $fh '';
416    
417     # TODO: delete FILE completely!
418     # required for this: wait until execution has finished, then unlink....
419     # but: "how to wait until execution is finished"?
420     # i believe the best is to spawn *another* process directly from here,
421     # let's call it 'watcher-agent'.
422     # This one should monitor a certain running process and delete its
423     # executable file after it has finished execution.
424     # Possible extensions could be:
425     # keep track of all stuff sent to STDOUT or STDERR and
426     # send that stuff to the task-owner indirectly (not via shell/console)
427     # (e.g. via email, by posting report to a newsgroup or publishing on a specified web-page: use mod-dav!)
428    
429     } elsif ($args->{language} eq 'bash') {
430     $self->log("FIXME: - - - - - -- - - -- BASH - - - - - - - -- - ", 'error');
431    
432     } else {
433     $self->log("FIXME: Script language '$args->{language}' not implemented.", 'error');
434    
435     }
436    
437     }
438 joko 1.1
439     1;
440     __END__

MailToCvsAdmin">MailToCvsAdmin
ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed