/[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.3 by joko, Fri Feb 21 01:46:17 2003 UTC
# Line 2  Line 2 
2  ##  $Id$  ##  $Id$
3  ## ----------------------------------------------------------------------  ## ----------------------------------------------------------------------
4  ##  $Log$  ##  $Log$
5    ##  Revision 1.3  2003/02/21 01:46:17  joko
6    ##  renamed core function
7    ##
8    ##  Revision 1.2  2003/02/20 19:46:33  joko
9    ##  renamed and revamped some of modules
10    ##  renamed methods
11    ##  + sub run_executable
12    ##
13  ##  Revision 1.1  2003/02/18 15:35:25  joko  ##  Revision 1.1  2003/02/18 15:35:25  joko
14  ##  + initial commit  ##  + initial commit
15  ##  ##
# Line 15  use warnings; Line 23  use warnings;
23    
24    
25  use Data::Dumper;  use Data::Dumper;
 use Data::Transform::Deep qw( refexpr2perlref );  
 use Iterate;  
26  use Hash::Merge qw( merge );  use Hash::Merge qw( merge );
27    use Iterate;
28    
29    use shortcuts qw( run_cmd );
30    use Data::Code::Ref qw( ref_slot );
31    use Data::Transform::Deep qw( expand );
32    
33    
34  sub performTarget {  sub performTarget {
35    my $self = shift;    my $self = shift;
36    my $targetname = shift;    my $targetname = shift;
37    my $target = $self->getTargetMetadata($targetname);    $self->perform_target($targetname);
38    }
39    
40    sub perform_target {
41      my $self = shift;
42      my $targetname = shift;
43    
44      $self->log("Performing Target '$targetname'.", 'notice');
45    
46      #exit;
47    
48      my $target = $self->getTargetDetails($targetname);
49    
50    # trace    # trace
51      #print Dumper($target);      #print Dumper($target);
52      #exit;      #exit;
53            
54      $self->perform_dependencies($target);
55      $self->perform_details($target);
56    
57    }
58    
59    sub perform_dependencies {
60      my $self = shift;
61      my $target = shift;
62    # resolve dependencies (just run prior)    # resolve dependencies (just run prior)
63    if (my $targetname_dep = $target->{attrib}->{depends}) {    if (my $targetname_dep = $target->{attrib}->{depends}) {
64      $self->performTarget($targetname_dep);      my @targets = split(/,\s|,/, $targetname_dep);
65        #print Dumper(@targets);
66        #$self->perform($targetname_dep);
67        #delete $target->{attrib}->{depends};
68        foreach (@targets) {
69          if (!$self->{__rap}->{dependencies}->{resolved}->{$_}++) {
70            $self->perform_target($_);
71          }
72        }
73      delete $target->{attrib}->{depends};      delete $target->{attrib}->{depends};
74    }    }
75    }
76    
77    sub perform_details {
78      my $self = shift;
79      my $target = shift;
80      
81      #print Dumper($target);
82      #exit;
83      
84    foreach my $entry (@{$target->{content}}) {    foreach my $entry (@{$target->{content}}) {
85      my $command = $entry->{name};      my $command = $entry->{name};
86      my $args = $entry->{attrib};      my $args = $entry->{attrib};
87      $self->run_command($command, $args);      $self->perform_command($command, $args);
88        # check recursiveness
89        if ($entry->{content} && ref $entry->{content}) {
90          $self->perform_details($entry);
91        }
92    }    }
93  }  }
94    
95  sub rc {  sub rc {
96    my $self = shift;    my $self = shift;
97    return $self->run_command(@_);    return $self->perform_command(@_);
98  }  }
99    
100  sub run_command {  sub perform_command {
101    my $self = shift;    my $self = shift;
102    my $command = shift;    my $command = shift;
103      
104    if (!$command) {    if (!$command) {
105      $self->log("Command was empty!", 'warning');      $self->log("Command was empty!", 'warning');
106      return;      return;
107    }    }
108    
109      # FIXME: make '__PACKAGE__' go one level deeper properly!
110      $self->log( __PACKAGE__ . "->perform_command: " . $command, 'debug');
111        
112    my $args_list = shift;    my $args_list = shift;
113    my $args = {};    my $args = {};
# Line 69  sub run_command { Line 122  sub run_command {
122      }      }
123    }    }
124    $command = '_' . $command;    $command = '_' . $command;
125    if ($self->can($command)) {    
126      $self->$command($args);    
127      # determine container
128      my $container; # = $self->getInstance();
129      $container ||= $self;
130      
131      if ($container->can($command)) {
132        $container->$command($args);
133    } else {    } else {
134      $self->log("Command \"$command\" not implemented.", "warning");      $self->log("Command '$command' not implemented.", "warning");
135    }    }
136      
137  }  }
138    
 sub set_property {  
   my $self = shift;  
   my $args = shift;  
139    
140    my $name;  sub merge_properties {
141    my $value;    my $self = shift;
142        my $name = shift;
143    if (ref $args) {    my $data = shift;
     $self->interpolate($args) ;  
     $name = $args->{name};  
     $value = $args->{value};  
144    
145    } else {    $self->log("merge-name: $name");
146      $name = $args;    #print "name: $name", "\n";
147      $value = shift;    #print Dumper($data);
148    }    #exit;
149    
150    # check if slot (or childs of it) is/are already occupied    # check if slot (or childs of it) is/are already occupied
151    if (my $oldvalue = refexpr2perlref($self, $name, undef, '.')) {    #if (my $data_old = ref_slot($self, $name, undef, '.')) {
152      if (my $data_old = $self->get_property($name)) {
153        #print "old:", "\n";
154        #print Dumper($data_old);
155        
156      # FIXME: review - any options for 'merge' here?      # FIXME: review - any options for 'merge' here?
157      $value = merge($oldvalue, $value);      my $data_new = merge($data_old, $data);
158        #print "DATA NEE! - MERGE!", "\n";
159        #print Dumper($data_new);
160        #exit;
161        #merge_to($self, $data_new);
162        $self->set_property( { name => $name, value => $data_new } );
163        
164      } else {
165    
166    =pod    
167        # make up a dummy hash matching the structure of the destination one
168          my $dummy = {};
169          ref_slot($dummy, $name, $data, '.');
170          print Dumper($dummy);
171        
172        # mix into destination
173          mixin($self, $dummy, { init => 1 });
174    =cut
175    
176          ref_slot($self, $name, $data, '.');
177    
178    }    }
179      
180      
181      #print Dumper($self);
182      #exit;
183      #$self->
184    
185    }
186    
187    sub set_property {
188      my $self = shift;
189      my $args = shift;
190    
191      $self->interpolate($args) ;
192      my $name = $args->{name};
193      my $value = $args->{value};
194      $name = '__rap.properties.' . $name;
195    
196      $self->log("set-name: $name");
197    
198    # fill property slot with given value    # fill property slot with given value
199    if ($value) {    if ($value) {
200      refexpr2perlref($self, $name, $value, '.');      ref_slot($self, $name, $value, '.');
201    }    }
202        
203      #print Dumper($self);
204      
205    # FIXME!!!    # FIXME!!!
206    return if ! ref $args;    #return if ! ref $args;
207    
208    # 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
209    if (my $file = $args->{file}) {    if (my $file = $args->{file}) {
# Line 123  sub set_property { Line 221  sub set_property {
221      }      }
222    
223    } elsif (my $command = $args->{command}) {    } elsif (my $command = $args->{command}) {
224      $self->run_command($command, $args);      $self->perform_command($command, $args);
225        
226    }    }
227    
# Line 137  sub get_property { Line 235  sub get_property {
235    #$self->interpolate($args);    #$self->interpolate($args);
236    
237    #my $name = $args->{name};    #my $name = $args->{name};
238      my $result;
239    
240      if (!$name) {
241        $self->log( __PACKAGE__ . ": no name!", 'critical');
242        
243      } elsif ($name eq '/') {
244        $result = expand($self);
245    
246    # get property slot and return value    } elsif ($name eq '.') {
247    return refexpr2perlref($self, $name, undef, '.');      if (my $instance = $self->getInstance()) {
248          $result = expand($instance);
249        } else {
250          $result = ref_slot($self, '__rap.properties', undef, '.');
251          
252        }
253    
254      } else {
255    
256        $name = '__rap.properties.' . $name;
257        
258        $self->log("get-name: $name");
259        
260        # get property slot and return value
261        $result = ref_slot($self, $name, undef, '.');
262        
263        # FIXME: Is this okay? It's provided for now in order not
264        # to deliver an 'undef' to the regex below inside 'interpolate'.
265        # revamp this, maybe!
266        #$result ||= '';    # NO!!!
267      }
268        
269      return $result;
270  }  }
271    
272  sub interpolate {  sub interpolate {
# Line 152  sub interpolate { Line 278  sub interpolate {
278    }    }
279  }  }
280    
281    sub run_executable {
282      my $self = shift;
283      my $opts = shift;
284    
285      if ($opts->{executable}) {
286    
287        my $program = $opts->{executable};
288        delete $opts->{executable};
289    
290        my @buf;
291        foreach (keys %$opts) {
292          my $value = $opts->{$_};
293          if ($value =~ /\s/) {
294            $value = "\"$value\"";
295          }
296          push @buf, "--$_=$value";
297        }
298      
299        my $cmd = $program . ' ' . join(' ', @buf);
300        
301        # trace
302          #print "command: $cmd", "\n";
303        
304        # start process
305          # V1: via shortcut
306          #$ENV{PERL5LIB} = join(' ', @INC);
307          
308          # FIXME!!! what about the other slots of @INC?
309          $ENV{PERL5LIB} = $INC[0];
310          
311          #print Dumper(%ENV);
312          run_cmd($cmd);
313          # V2: via IPC::Run
314          # ....  (TODO)
315        
316        
317      }
318      
319    }
320    
321    
322  1;  1;
323  __END__  __END__
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.3
MailToCvsAdmin">MailToCvsAdmin
 ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed