Data/Rap/Engine.pm

## ----------------------------------------------------------------------
##  $Id: Engine.pm,v 1.5 2003/03/27 15:03:03 joko Exp $
## ----------------------------------------------------------------------
##  $Log: Engine.pm,v $
##  Revision 1.5  2003/03/27 15:03:03  joko
##  enhanced 'sub run_executable'
##
##  Revision 1.4  2003/02/22 16:51:21  joko
##  + enhanced run_executable
##  modified logging output
##
##  Revision 1.3  2003/02/21 01:46:17  joko
##  renamed core function
##
##  Revision 1.2  2003/02/20 19:46:33  joko
##  renamed and revamped some of modules
##  renamed methods
##  + sub run_executable
##
##  Revision 1.1  2003/02/18 15:35:25  joko
##  + initial commit
##
## ----------------------------------------------------------------------


package Data::Rap::Engine;

use strict;
use warnings;


use Data::Dumper;
use Hash::Merge qw( merge );
use Iterate;

use shortcuts qw( run_cmd );
use Data::Mungle::Code::Ref qw( ref_slot );
use Data::Mungle::Transform::Deep qw( expand );


sub performTarget {
  my $self = shift;
  my $targetname = shift;
  $self->perform_target($targetname);
}

sub perform_target {
  my $self = shift;
  my $targetname = shift;

  my $header = ("- " x 12) . "   " . $targetname . "   " . ("- " x 6);
  
  #$self->log("- " x 35, 'notice');
  #$self->log("Performing Target '$targetname'.", 'notice');

  $self->log($header, 'notice');

  #exit;

  my $target = $self->getTargetDetails($targetname);

  # trace
    #print Dumper($target);
    #exit;
    
  $self->perform_dependencies($target);
  $self->perform_details($target);

}

sub perform_dependencies {
  my $self = shift;
  my $target = shift;
  # resolve dependencies (just run prior)
  if (my $targetname_dep = $target->{attrib}->{depends}) {
    my @targets = split(/,\s|,/, $targetname_dep);
    #print Dumper(@targets);
    #$self->perform($targetname_dep);
    #delete $target->{attrib}->{depends};
    foreach (@targets) {
      if (!$self->{__rap}->{dependencies}->{resolved}->{$_}++) {
        $self->perform_target($_);
      }
    }
    delete $target->{attrib}->{depends};
  }
}

sub perform_details {
  my $self = shift;
  my $target = shift;
  
  #print Dumper($target);
  #exit;
  
  foreach my $entry (@{$target->{content}}) {
    my $command = $entry->{name};
    my $args = $entry->{attrib};
    $self->perform_command($command, $args);
    # check recursiveness
    if ($entry->{content} && ref $entry->{content}) {
      $self->perform_details($entry);
    }
  }
}

sub rc {
  my $self = shift;
  return $self->perform_command(@_);
}

sub perform_command {
  my $self = shift;
  my $command = shift;

  if (!$command) {
    $self->log("Command was empty!", 'debug');
    return;
  }

  # FIXME: make '__PACKAGE__' go one level deeper properly!
  $self->log( __PACKAGE__ . "->perform_command: " . $command, 'debug');
  
  my $args_list = shift;
  my $args = {};
  #print Dumper($args_list);
  if ($args_list) {
    if (ref $args_list eq 'ARRAY') {
      foreach (@$args_list) {
        $args = merge($args, $_);
      }
    } else {
      $args = $args_list;
    }
  }
  $command = '_' . $command;
  
  
  # determine container
  my $container; # = $self->getInstance();
  $container ||= $self;
  
  if ($container->can($command)) {
    $container->$command($args);
  } else {
    $self->log("Command '$command' not implemented.", "warning");
  }
  
}


sub merge_properties {
  my $self = shift;
  my $name = shift;
  my $data = shift;

  $self->log("merge-name: $name");
  #print "name: $name", "\n";
  #print Dumper($data);
  #exit;

  # check if slot (or childs of it) is/are already occupied
  #if (my $data_old = ref_slot($self, $name, undef, '.')) {
  if (my $data_old = $self->get_property($name)) {
    #print "old:", "\n";
    #print Dumper($data_old);
    
    # FIXME: review - any options for 'merge' here?
    my $data_new = merge($data_old, $data);
    #print "DATA NEE! - MERGE!", "\n";
    #print Dumper($data_new);
    #exit;
    #merge_to($self, $data_new);
    $self->set_property( { name => $name, value => $data_new } );
    
  } else {

=pod    
    # make up a dummy hash matching the structure of the destination one
      my $dummy = {};
      ref_slot($dummy, $name, $data, '.');
      print Dumper($dummy);
    
    # mix into destination
      mixin($self, $dummy, { init => 1 });
=cut

      ref_slot($self, $name, $data, '.');

  }
  
  
  #print Dumper($self);
  #exit;
  #$self->

}

sub set_property {
  my $self = shift;
  my $args = shift;

  $self->interpolate($args) ;
  my $name = $args->{name};
  my $value = $args->{value};
  $name = '__rap.properties.' . $name;

  $self->log("set-name: $name");

  # fill property slot with given value
  if ($value) {
    ref_slot($self, $name, $value, '.');
  }
  
  #print Dumper($self);
  
  # FIXME!!!
  #return if ! ref $args;

  # fill property slot with (probably bigger) data structure from property-/configuration-style - file
  if (my $file = $args->{file}) {
    my $type = $args->{type};
    if (!$type) {
      die("default file (no type specified) is not implemented yet!");
    
    } elsif ($type eq 'perl-eval') {
      #die($type);
      $self->loadFromPerlFile($file, $name, $args->{'varnames'});
      
    } elsif ($type eq 'App::Config') {
      die("not implemented: $type");
      
    }

  } elsif (my $command = $args->{command}) {
    $self->perform_command($command, $args);
  
  }

}

sub get_property {
  my $self = shift;
  #my $args = shift;
  my $name = shift;

  #$self->interpolate($args);

  #my $name = $args->{name};
  my $result;

  if (!$name) {
    $self->log( __PACKAGE__ . ": no name!", 'critical');
    
  } elsif ($name eq '/') {
    $result = expand($self);

  } elsif ($name eq '.') {
    if (my $instance = $self->getInstance()) {
      $result = expand($instance);
    } else {
      $result = ref_slot($self, '__rap.properties', undef, '.');
      
    }

  } else {

    $name = '__rap.properties.' . $name;
    
    $self->log("get-name: $name");
    
    # get property slot and return value
    $result = ref_slot($self, $name, undef, '.');
    
    # FIXME: Is this okay? It's provided for now in order not
    # to deliver an 'undef' to the regex below inside 'interpolate'.
    # revamp this, maybe!
    #$result ||= '';    # NO!!!
  }
  
  return $result;
}

sub interpolate {
  my $self = shift;
  my $ref = shift;
  IterHash %$ref, sub {
    #print $_[1], "\n";
    $_[1] =~ s/\${(.+)}/$self->get_property($1)/e;
  }
}

sub run_executable {
  my $self = shift;
  my $opts = shift;

  if ($opts->{executable}) {

    my $program = $opts->{executable};
    delete $opts->{executable};

    # determine execution method
    my $method = 'run_cmd';
    my $wrapper_program = '';
    
    # check if program is a namespace-string (contains '::') - use 'do' in this case!
    if ($program =~ /::/) {
    #if ($program =~ s/::/\\/g) {
      #$program = '.\\' . $program;
      #$method = 'require';
      #do "$program";
      #return;
      #$method = 'rap.';
      
      $wrapper_program = 'rap.pl';
      
    }

    # prepare arguments
    my @buf;
    foreach (keys %$opts) {
      my $value = $opts->{$_};
      if (m/^_/) {
        if ($_ eq '_switches') {
          my @switches = split(/,\s|,/, $value);
          foreach my $switch (@switches) {
            push @buf, '--' . $switch;
          }
        }
        next;
      }
      
      if ($value =~ /\s/) {
        $value = "\"$value\"";
      }
      push @buf, "--$_=$value";
    }

    # build {program} & {arguments}  
    my $cmd = join(' ', $wrapper_program, $program) . ' ' . join(' ', @buf);
    
    # trace
      #print "command: $cmd", "\n";
    
    # start process
      # V1: via shortcut
      #$ENV{PERL5LIB} = join(' ', @INC);
      
      # FIXME!!! what about the other slots of @INC?
      $ENV{PERL5LIB} = $INC[0];
      
      #print Dumper(%ENV);
      
      print "command: '$cmd'", "\n";

      # V1 - basic
      #run_cmd($cmd);

      # V1.b - enhanced: variable local method
      my $evalstr = "$method('$cmd');";
      eval($evalstr);
      #my $res = do "$cmd";
      #print $res, "\n" if $res;

      #$self->log("run_executable: $evalstr", 'info');
      $self->raiseException("run_executable: $evalstr\n$@") if $@;

      # V2: via IPC::Run
      # ....  (TODO)
    
    
  }
  
}


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