Data/Rap/Engine.pm

## ----------------------------------------------------------------------
##  $Id: Engine.pm,v 1.2 2003/02/20 19:46:33 joko Exp $
## ----------------------------------------------------------------------
##  $Log: Engine.pm,v $
##  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::Code::Ref qw( ref_slot );
use Data::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;

  $self->log("Performing Target '$targetname'.", '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!", 'warning');
    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};

    my @buf;
    foreach (keys %$opts) {
      my $value = $opts->{$_};
      if ($value =~ /\s/) {
        $value = "\"$value\"";
      }
      push @buf, "--$_=$value";
    }
  
    my $cmd = $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);
      run_cmd($cmd);
      # V2: via IPC::Run
      # ....  (TODO)
    
    
  }
  
}


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