--- nfo/perl/libs/Data/Rap/Engine.pm 2003/02/18 15:35:25 1.1
+++ nfo/perl/libs/Data/Rap/Engine.pm 2004/05/12 14:23:31 1.14
@@ -1,7 +1,52 @@
## ----------------------------------------------------------------------
-## $Id: Engine.pm,v 1.1 2003/02/18 15:35:25 joko Exp $
+## $Id: Engine.pm,v 1.14 2004/05/12 14:23:31 jonen Exp $
## ----------------------------------------------------------------------
## $Log: Engine.pm,v $
+## Revision 1.14 2004/05/12 14:23:31 jonen
+## add comment/code related to PERL5LIB var at different OS's
+##
+## Revision 1.13 2003/12/05 05:02:08 joko
+## + minor update: disabled some unnecessary loggers or changed to debug-level
+##
+## Revision 1.12 2003/06/24 20:59:51 jonen
+## added option 'detach'
+##
+## Revision 1.11 2003/06/23 17:54:32 joko
+## prepared execution of in-process perl-code via eval (not activated yet!)
+##
+## Revision 1.10 2003/05/13 07:56:12 joko
+## enhanced: *hierarchical* containers for context handling
+## fixes: some pre-flight checks
+## new: propagate "end-tag" event to e.g. close containers
+##
+## Revision 1.9 2003/04/04 17:23:11 joko
+## minor update: debugging output
+##
+## Revision 1.8 2003/03/29 07:11:54 joko
+## modified: sub run_executable
+## new: sub run_script
+##
+## Revision 1.7 2003/03/28 07:02:56 joko
+## modified structure around '$wrapper_program'
+##
+## Revision 1.6 2003/03/27 15:31:05 joko
+## fixes to modules regarding new namespace(s) below Data::Mungle::*
+##
+## 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
##
@@ -15,48 +60,125 @@
use Data::Dumper;
-use Data::Transform::Deep qw( refexpr2perlref );
-use Iterate;
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 deep_copy );
+use File::Temp qw/ tempfile tempdir /;
+
+my $DEBUG = 0;
sub performTarget {
my $self = shift;
my $targetname = shift;
- my $target = $self->getTargetMetadata($targetname);
+ $self->perform_target($targetname);
+}
+
+sub perform_target {
+ my $self = shift;
+ my $targetname = shift;
+
+ # pre-flight checks
+ if (!$targetname) {
+ $self->log("Target name empty. Please try to specify (e.g.) on the command line.", 'critical');
+ return;
+ }
+
+ my $header = ("- " x 12) . " " . $targetname . " " . ("- " x 6);
+
+ # V1
+ #$self->log("- " x 35, 'notice');
+ #$self->log("Performing Target '$targetname'.", 'notice');
+
+ # V2
+ #$self->log($header, 'notice');
+
+ # V3
+ #$self->log("- " x 20, 'info');
+ $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);
+
+ return 1;
+
+}
+
+sub perform_dependencies {
+ my $self = shift;
+ my $target = shift;
# resolve dependencies (just run prior)
if (my $targetname_dep = $target->{attrib}->{depends}) {
- $self->performTarget($targetname_dep);
+ 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->run_command($command, $args);
+ my $content = $entry->{content};
+ $self->perform_command($command, $args, $content, { warn => 1 } );
+ # check recursiveness
+ # new condition: don't recurse if node is flagged to have inline-args (2003-04-17)
+ my $has_inline_args = ($entry->{attrib}->{_args} && $entry->{attrib}->{_args} eq 'inline');
+ if ($entry->{content} && ref $entry->{content} && !$has_inline_args) {
+ $self->perform_details($entry);
+ }
+ # new of 2003-05-08
+ $command ||= '';
+ $self->perform_command($command . '_end', undef, undef, { warn => 0 } );
}
}
sub rc {
my $self = shift;
- return $self->run_command(@_);
+ return $self->perform_command(@_);
}
-sub run_command {
+sub perform_command {
my $self = shift;
my $command = shift;
-
+ my $args_list = shift;
+ my $content = shift;
+ my $options = shift;
+
if (!$command) {
- $self->log("Command was empty!", 'warning');
+ $self->log("Command was empty!", 'debug') if $DEBUG;
return;
}
+
+ # FIXME: make '__PACKAGE__' go one level deeper properly!
+ $self->log( __PACKAGE__ . "->perform_command: " . $command, 'debug') if $DEBUG;
- my $args_list = shift;
+
+ # 1. make arguments from list of arguments(?)
+
my $args = {};
#print Dumper($args_list);
if ($args_list) {
@@ -68,44 +190,109 @@
$args = $args_list;
}
}
- $command = '_' . $command;
- if ($self->can($command)) {
- $self->$command($args);
+
+
+ # 2. prepare command
+
+ # default setting for internal rap commands
+ my $method_prefix_default = '_';
+ # setting from property database
+ my $method_prefix_setting = $self->get_property('core.method_prefix');
+ #print "setting: ", $method_prefix_setting, "\n";
+ my $prefix = $method_prefix_setting;
+ if (not defined $prefix) {
+ $prefix = $method_prefix_default;
+ }
+ $command = $prefix . $command;
+
+
+ # 3. determine container
+ my $container; # = $self->getInstance();
+ #$container ||= $self->getInstance();
+ $container ||= $self;
+
+ # 4. run method
+ if ($container->can($command)) {
+ $container->$command($args, $content);
} else {
- $self->log("Command \"$command\" not implemented.", "warning");
+ my $level = "debug";
+ $level = "warning" if $options->{warn};
+ $self->log("Command '$command' not implemented.", $level) if $DEBUG;
}
+
}
-sub set_property {
- my $self = shift;
- my $args = shift;
- my $name;
- my $value;
-
- if (ref $args) {
- $self->interpolate($args) ;
- $name = $args->{name};
- $value = $args->{value};
+sub merge_properties {
+ my $self = shift;
+ my $name = shift;
+ my $data = shift;
- } else {
- $name = $args;
- $value = 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 $oldvalue = refexpr2perlref($self, $name, undef, '.')) {
+ #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?
- $value = merge($oldvalue, $value);
+ 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");
+
+ #print Dumper($name, $value, '.');
# fill property slot with given value
- if ($value) {
- refexpr2perlref($self, $name, $value, '.');
+ # fix (2003-04-17): always do fill if value is *defined*!!!
+ if (defined $value) {
+ ref_slot($self, $name, $value, '.');
}
+ #print Dumper($self);
+
# FIXME!!!
- return if ! ref $args;
+ #return if ! ref $args;
# fill property slot with (probably bigger) data structure from property-/configuration-style - file
if (my $file = $args->{file}) {
@@ -123,7 +310,7 @@
}
} elsif (my $command = $args->{command}) {
- $self->run_command($command, $args);
+ $self->perform_command($command, $args);
}
@@ -137,10 +324,38 @@
#$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 {
- # get property slot and return value
- return refexpr2perlref($self, $name, undef, '.');
+ $name = '__rap.properties.' . $name;
+
+ $self->log("get-name: $name") if $DEBUG;
+
+ # 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 {
@@ -152,5 +367,154 @@
}
}
+sub run_executable {
+ my $self = shift;
+ my $opts = shift;
+
+ my $meta = deep_copy($opts);
+
+ delete $opts->{caption};
+ delete $opts->{async};
+ delete $opts->{detach};
+
+ #print Dumper($meta);
+
+ if ($opts->{executable}) {
+
+ my $program = $opts->{executable};
+ delete $opts->{executable};
+
+ # determine execution method
+ my $wrapper_program = '';
+
+ # check if program is a namespace-string (contains '::') - use 'do' in this case!
+ if ($program =~ /::/) {
+ #$wrapper_program = 'rap.pl';
+ $wrapper_program = $0;
+ }
+
+ # 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 = ($wrapper_program ? $wrapper_program . ' ' : '') . $program . ' ' . join(' ', @buf);
+
+ # trace
+ #print "command: $cmd", "\n";
+
+ # start process
+ # 2004-05-11 - seems like only ONE args is valid at PERL5LIB,
+ # so we use V2!
+ # V1: join all args
+ #$ENV{PERL5LIB} = join(' ', @INC);
+ # V2: insert only FIRST arg
+ $ENV{PERL5LIB} = $INC[0];
+ # WARNING: at (free)BSD our var is the SECOND, NOT FIRST!!
+ # FIXME!! Do this in an abstract way!!
+ #$ENV{PERL5LIB} = $INC[1];
+
+ #print Dumper(%ENV);
+
+ #print "command: '$cmd'", "\n";
+
+ # V1 - basic
+ #run_cmd($cmd);
+
+ # V1.b - enhanced: variable local method
+ $meta->{caption} ||= '';
+ $meta->{async} ||= 0;
+ $meta->{detach} ||= 0;
+ # new of 2003-05-08: USE_PATH!
+ $meta->{USE_PATH} ||= 0;
+ my $evalstr = "run_cmd('$cmd', '$meta->{caption}', { async => $meta->{async}, detach => $meta->{detach}, USE_PATH => $meta->{USE_PATH} });";
+ 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)
+
+
+ }
+
+}
+
+
+sub run_script {
+
+ my $self = shift;
+ my $args = shift;
+ my $code = shift;
+
+ if ($args->{language} eq 'msdos/bat') {
+
+ #print "code: $code", "\n";
+
+ # reporting
+ $self->log("Executing some arbitrary unsigned code (probably unsafe). [language=$args->{language}]", 'info');
+ $self->log("\n\n$code\n", 'info');
+
+ # create temporary intermediate file to execute code
+ my $tmpdir = '/tmp/rap';
+ mkdir $tmpdir;
+ (my $fh, my $filename) = tempfile( DIR => $tmpdir, SUFFIX => '.bat' );
+ print $fh $code, "\n";
+ run_cmd( $filename, '', { async => 1 } );
+
+ # FIXME: DELETE code inside temp-files as soon as possible!
+ #print $fh '';
+
+ # TODO: delete FILE completely!
+ # required for this: wait until execution has finished, then unlink....
+ # but: "how to wait until execution is finished"?
+ # i believe the best is to spawn *another* process directly from here,
+ # let's call it 'watcher-agent'.
+ # This one should monitor a certain running process and delete its
+ # executable file after it has finished execution.
+ # Possible extensions could be:
+ # keep track of all stuff sent to STDOUT or STDERR and
+ # send that stuff to the task-owner indirectly (not via shell/console)
+ # (e.g. via email, by posting report to a newsgroup or publishing on a specified web-page: use mod-dav!)
+
+ } elsif ($args->{language} eq 'bash') {
+ $self->log("FIXME: - - - - - -- - - -- BASH - - - - - - - -- - ", 'error');
+
+ } elsif ($args->{language} eq 'perl') {
+
+ # reporting
+ #$self->log("Executing some arbitrary unsigned code (probably unsafe). [language=$args->{language}]", 'info');
+ #$self->log("\n\n$code\n", 'info');
+
+ # do it
+ #eval($code);
+ #$self->log("\n\n$code\n", 'error') if $@;
+
+ } else {
+ $self->log("FIXME: Script language '$args->{language}' not implemented.", 'error');
+
+ }
+
+}
+
1;
__END__