/[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.6 by joko, Thu Mar 27 15:31:05 2003 UTC
# Line 2  Line 2 
2  ##  $Id$  ##  $Id$
3  ## ----------------------------------------------------------------------  ## ----------------------------------------------------------------------
4  ##  $Log$  ##  $Log$
5    ##  Revision 1.6  2003/03/27 15:31:05  joko
6    ##  fixes to modules regarding new namespace(s) below Data::Mungle::*
7    ##
8    ##  Revision 1.5  2003/03/27 15:03:03  joko
9    ##  enhanced 'sub run_executable'
10    ##
11    ##  Revision 1.4  2003/02/22 16:51:21  joko
12    ##  + enhanced run_executable
13    ##  modified logging output
14    ##
15    ##  Revision 1.3  2003/02/21 01:46:17  joko
16    ##  renamed core function
17    ##
18    ##  Revision 1.2  2003/02/20 19:46:33  joko
19    ##  renamed and revamped some of modules
20    ##  renamed methods
21    ##  + sub run_executable
22    ##
23  ##  Revision 1.1  2003/02/18 15:35:25  joko  ##  Revision 1.1  2003/02/18 15:35:25  joko
24  ##  + initial commit  ##  + initial commit
25  ##  ##
# Line 15  use warnings; Line 33  use warnings;
33    
34    
35  use Data::Dumper;  use Data::Dumper;
 use Data::Transform::Deep qw( refexpr2perlref );  
 use Iterate;  
36  use Hash::Merge qw( merge );  use Hash::Merge qw( merge );
37    use Iterate;
38    
39    use shortcuts qw( run_cmd );
40    use Data::Mungle::Code::Ref qw( ref_slot );
41    use Data::Mungle::Transform::Deep qw( expand );
42    
43    
44  sub performTarget {  sub performTarget {
45    my $self = shift;    my $self = shift;
46    my $targetname = shift;    my $targetname = shift;
47    my $target = $self->getTargetMetadata($targetname);    $self->perform_target($targetname);
48    }
49    
50    sub perform_target {
51      my $self = shift;
52      my $targetname = shift;
53    
54      my $header = ("- " x 12) . "   " . $targetname . "   " . ("- " x 6);
55      
56      #$self->log("- " x 35, 'notice');
57      #$self->log("Performing Target '$targetname'.", 'notice');
58    
59      $self->log($header, 'notice');
60    
61      #exit;
62    
63      my $target = $self->getTargetDetails($targetname);
64    
65    # trace    # trace
66      #print Dumper($target);      #print Dumper($target);
67      #exit;      #exit;
68            
69      $self->perform_dependencies($target);
70      $self->perform_details($target);
71    
72    }
73    
74    sub perform_dependencies {
75      my $self = shift;
76      my $target = shift;
77    # resolve dependencies (just run prior)    # resolve dependencies (just run prior)
78    if (my $targetname_dep = $target->{attrib}->{depends}) {    if (my $targetname_dep = $target->{attrib}->{depends}) {
79      $self->performTarget($targetname_dep);      my @targets = split(/,\s|,/, $targetname_dep);
80        #print Dumper(@targets);
81        #$self->perform($targetname_dep);
82        #delete $target->{attrib}->{depends};
83        foreach (@targets) {
84          if (!$self->{__rap}->{dependencies}->{resolved}->{$_}++) {
85            $self->perform_target($_);
86          }
87        }
88      delete $target->{attrib}->{depends};      delete $target->{attrib}->{depends};
89    }    }
90    }
91    
92    sub perform_details {
93      my $self = shift;
94      my $target = shift;
95      
96      #print Dumper($target);
97      #exit;
98      
99    foreach my $entry (@{$target->{content}}) {    foreach my $entry (@{$target->{content}}) {
100      my $command = $entry->{name};      my $command = $entry->{name};
101      my $args = $entry->{attrib};      my $args = $entry->{attrib};
102      $self->run_command($command, $args);      $self->perform_command($command, $args);
103        # check recursiveness
104        if ($entry->{content} && ref $entry->{content}) {
105          $self->perform_details($entry);
106        }
107    }    }
108  }  }
109    
110  sub rc {  sub rc {
111    my $self = shift;    my $self = shift;
112    return $self->run_command(@_);    return $self->perform_command(@_);
113  }  }
114    
115  sub run_command {  sub perform_command {
116    my $self = shift;    my $self = shift;
117    my $command = shift;    my $command = shift;
118      
119    if (!$command) {    if (!$command) {
120      $self->log("Command was empty!", 'warning');      $self->log("Command was empty!", 'debug');
121      return;      return;
122    }    }
123    
124      # FIXME: make '__PACKAGE__' go one level deeper properly!
125      $self->log( __PACKAGE__ . "->perform_command: " . $command, 'debug');
126        
127    my $args_list = shift;    my $args_list = shift;
128    my $args = {};    my $args = {};
# Line 69  sub run_command { Line 137  sub run_command {
137      }      }
138    }    }
139    $command = '_' . $command;    $command = '_' . $command;
140    if ($self->can($command)) {    
141      $self->$command($args);    
142      # determine container
143      my $container; # = $self->getInstance();
144      $container ||= $self;
145      
146      if ($container->can($command)) {
147        $container->$command($args);
148    } else {    } else {
149      $self->log("Command \"$command\" not implemented.", "warning");      $self->log("Command '$command' not implemented.", "warning");
150    }    }
151      
152  }  }
153    
 sub set_property {  
   my $self = shift;  
   my $args = shift;  
154    
155    my $name;  sub merge_properties {
156    my $value;    my $self = shift;
157        my $name = shift;
158    if (ref $args) {    my $data = shift;
     $self->interpolate($args) ;  
     $name = $args->{name};  
     $value = $args->{value};  
159    
160    } else {    $self->log("merge-name: $name");
161      $name = $args;    #print "name: $name", "\n";
162      $value = shift;    #print Dumper($data);
163    }    #exit;
164    
165    # check if slot (or childs of it) is/are already occupied    # check if slot (or childs of it) is/are already occupied
166    if (my $oldvalue = refexpr2perlref($self, $name, undef, '.')) {    #if (my $data_old = ref_slot($self, $name, undef, '.')) {
167      if (my $data_old = $self->get_property($name)) {
168        #print "old:", "\n";
169        #print Dumper($data_old);
170        
171      # FIXME: review - any options for 'merge' here?      # FIXME: review - any options for 'merge' here?
172      $value = merge($oldvalue, $value);      my $data_new = merge($data_old, $data);
173        #print "DATA NEE! - MERGE!", "\n";
174        #print Dumper($data_new);
175        #exit;
176        #merge_to($self, $data_new);
177        $self->set_property( { name => $name, value => $data_new } );
178        
179      } else {
180    
181    =pod    
182        # make up a dummy hash matching the structure of the destination one
183          my $dummy = {};
184          ref_slot($dummy, $name, $data, '.');
185          print Dumper($dummy);
186        
187        # mix into destination
188          mixin($self, $dummy, { init => 1 });
189    =cut
190    
191          ref_slot($self, $name, $data, '.');
192    
193    }    }
194      
195      
196      #print Dumper($self);
197      #exit;
198      #$self->
199    
200    }
201    
202    sub set_property {
203      my $self = shift;
204      my $args = shift;
205    
206      $self->interpolate($args) ;
207      my $name = $args->{name};
208      my $value = $args->{value};
209      $name = '__rap.properties.' . $name;
210    
211      $self->log("set-name: $name");
212    
213    # fill property slot with given value    # fill property slot with given value
214    if ($value) {    if ($value) {
215      refexpr2perlref($self, $name, $value, '.');      ref_slot($self, $name, $value, '.');
216    }    }
217        
218      #print Dumper($self);
219      
220    # FIXME!!!    # FIXME!!!
221    return if ! ref $args;    #return if ! ref $args;
222    
223    # 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
224    if (my $file = $args->{file}) {    if (my $file = $args->{file}) {
# Line 123  sub set_property { Line 236  sub set_property {
236      }      }
237    
238    } elsif (my $command = $args->{command}) {    } elsif (my $command = $args->{command}) {
239      $self->run_command($command, $args);      $self->perform_command($command, $args);
240        
241    }    }
242    
# Line 137  sub get_property { Line 250  sub get_property {
250    #$self->interpolate($args);    #$self->interpolate($args);
251    
252    #my $name = $args->{name};    #my $name = $args->{name};
253      my $result;
254    
255      if (!$name) {
256        $self->log( __PACKAGE__ . ": no name!", 'critical');
257        
258      } elsif ($name eq '/') {
259        $result = expand($self);
260    
261      } elsif ($name eq '.') {
262        if (my $instance = $self->getInstance()) {
263          $result = expand($instance);
264        } else {
265          $result = ref_slot($self, '__rap.properties', undef, '.');
266          
267        }
268    
269    # get property slot and return value    } else {
270    return refexpr2perlref($self, $name, undef, '.');  
271        $name = '__rap.properties.' . $name;
272        
273        $self->log("get-name: $name");
274        
275        # get property slot and return value
276        $result = ref_slot($self, $name, undef, '.');
277        
278        # FIXME: Is this okay? It's provided for now in order not
279        # to deliver an 'undef' to the regex below inside 'interpolate'.
280        # revamp this, maybe!
281        #$result ||= '';    # NO!!!
282      }
283        
284      return $result;
285  }  }
286    
287  sub interpolate {  sub interpolate {
# Line 152  sub interpolate { Line 293  sub interpolate {
293    }    }
294  }  }
295    
296    sub run_executable {
297      my $self = shift;
298      my $opts = shift;
299    
300      if ($opts->{executable}) {
301    
302        my $program = $opts->{executable};
303        delete $opts->{executable};
304    
305        # determine execution method
306        my $method = 'run_cmd';
307        my $wrapper_program = '';
308        
309        # check if program is a namespace-string (contains '::') - use 'do' in this case!
310        if ($program =~ /::/) {
311        #if ($program =~ s/::/\\/g) {
312          #$program = '.\\' . $program;
313          #$method = 'require';
314          #do "$program";
315          #return;
316          #$method = 'rap.';
317          
318          $wrapper_program = 'rap.pl';
319          
320        }
321    
322        # prepare arguments
323        my @buf;
324        foreach (keys %$opts) {
325          my $value = $opts->{$_};
326          if (m/^_/) {
327            if ($_ eq '_switches') {
328              my @switches = split(/,\s|,/, $value);
329              foreach my $switch (@switches) {
330                push @buf, '--' . $switch;
331              }
332            }
333            next;
334          }
335          
336          if ($value =~ /\s/) {
337            $value = "\"$value\"";
338          }
339          push @buf, "--$_=$value";
340        }
341    
342        # build {program} & {arguments}  
343        my $cmd = join(' ', $wrapper_program, $program) . ' ' . join(' ', @buf);
344        
345        # trace
346          #print "command: $cmd", "\n";
347        
348        # start process
349          # V1: via shortcut
350          #$ENV{PERL5LIB} = join(' ', @INC);
351          
352          # FIXME!!! what about the other slots of @INC?
353          $ENV{PERL5LIB} = $INC[0];
354          
355          #print Dumper(%ENV);
356          
357          print "command: '$cmd'", "\n";
358    
359          # V1 - basic
360          #run_cmd($cmd);
361    
362          # V1.b - enhanced: variable local method
363          my $evalstr = "$method('$cmd');";
364          eval($evalstr);
365          #my $res = do "$cmd";
366          #print $res, "\n" if $res;
367    
368          #$self->log("run_executable: $evalstr", 'info');
369          $self->raiseException("run_executable: $evalstr\n$@") if $@;
370    
371          # V2: via IPC::Run
372          # ....  (TODO)
373        
374        
375      }
376      
377    }
378    
379    
380  1;  1;
381  __END__  __END__
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.6
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed