Data/Rap/Engine.pm

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