--- nfo/perl/libs/Data/Rap/Engine.pm 2003/03/27 15:03:03 1.5
+++ nfo/perl/libs/Data/Rap/Engine.pm 2004/06/16 16:37:59 1.15
@@ -1,7 +1,40 @@
## ----------------------------------------------------------------------
-## $Id: Engine.pm,v 1.5 2003/03/27 15:03:03 joko Exp $
+## $Id: Engine.pm,v 1.15 2004/06/16 16:37:59 joko Exp $
## ----------------------------------------------------------------------
## $Log: Engine.pm,v $
+## Revision 1.15 2004/06/16 16:37:59 joko
+## attempt to get things going in a generic way (Linux/FreeBSD/Win32)
+##
+## 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'
##
@@ -33,10 +66,12 @@
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 );
+use shortcuts qw( run_cmd RUNNING_IN_HELL );
+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;
@@ -48,12 +83,24 @@
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');
- $self->log($header, 'notice');
+ # V2
+ #$self->log($header, 'notice');
+
+ # V3
+ #$self->log("- " x 20, 'info');
+ $self->log("Performing Target '$targetname'.", 'notice');
#exit;
@@ -65,6 +112,8 @@
$self->perform_dependencies($target);
$self->perform_details($target);
+
+ return 1;
}
@@ -96,11 +145,17 @@
foreach my $entry (@{$target->{content}}) {
my $command = $entry->{name};
my $args = $entry->{attrib};
- $self->perform_command($command, $args);
+ my $content = $entry->{content};
+ $self->perform_command($command, $args, $content, { warn => 1 } );
# check recursiveness
- if ($entry->{content} && ref $entry->{content}) {
+ # 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 } );
}
}
@@ -112,16 +167,21 @@
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!", 'debug');
+ $self->log("Command was empty!", 'debug') if $DEBUG;
return;
}
# FIXME: make '__PACKAGE__' go one level deeper properly!
- $self->log( __PACKAGE__ . "->perform_command: " . $command, 'debug');
+ $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) {
@@ -133,17 +193,34 @@
$args = $args_list;
}
}
- $command = '_' . $command;
- # determine container
+ # 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);
+ $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;
}
}
@@ -207,8 +284,11 @@
$self->log("set-name: $name");
+ #print Dumper($name, $value, '.');
+
# fill property slot with given value
- if ($value) {
+ # fix (2003-04-17): always do fill if value is *defined*!!!
+ if (defined $value) {
ref_slot($self, $name, $value, '.');
}
@@ -267,7 +347,7 @@
$name = '__rap.properties.' . $name;
- $self->log("get-name: $name");
+ $self->log("get-name: $name") if $DEBUG;
# get property slot and return value
$result = ref_slot($self, $name, undef, '.');
@@ -294,26 +374,26 @@
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 $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';
-
+ #$wrapper_program = 'rap.pl';
+ $wrapper_program = $0;
}
# prepare arguments
@@ -337,27 +417,39 @@
}
# build {program} & {arguments}
- my $cmd = join(' ', $wrapper_program, $program) . ' ' . join(' ', @buf);
+ my $cmd = ($wrapper_program ? $wrapper_program . ' ' : '') . $program . ' ' . join(' ', @buf);
# trace
#print "command: $cmd", "\n";
# start process
- # V1: via shortcut
- #$ENV{PERL5LIB} = join(' ', @INC);
+ # 2004-05-11 - seems like only ONE args is valid at PERL5LIB, so we use V2!
+ # 2004-06-16 - found out delimiter required for PERL5LIB, reverting back to V1!
- # FIXME!!! what about the other slots of @INC?
- $ENV{PERL5LIB} = $INC[0];
+ # V1: join all args
+ my $delimiter = ':';
+ $delimiter = ';' if RUNNING_IN_HELL();
+ $ENV{PERL5LIB} = join($delimiter, @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";
+ #print "command: '$cmd'", "\n";
# V1 - basic
#run_cmd($cmd);
# V1.b - enhanced: variable local method
- my $evalstr = "$method('$cmd');";
+ $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;
@@ -367,12 +459,68 @@
# 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__