Data/Rap/Engine.pm

## ----------------------------------------------------------------------
##  $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'
##
##  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 RUNNING_IN_HELL RUNNING_IN_HEAVEN );
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;
  $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}) {
    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};
    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->perform_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!", 'debug') if $DEBUG;
    return;
  }

  # FIXME: make '__PACKAGE__' go one level deeper properly!
  $self->log( __PACKAGE__ . "->perform_command: " . $command, 'debug') if $DEBUG;
  
  
  # 1. make arguments from list of arguments(?)

  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;
    }
  }
  
  
  # 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 {
    my $level = "debug";
    $level = "warning" if $options->{warn};
    $self->log("Command '$command' not implemented.", $level) if $DEBUG;
  }
  
}


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");

  #print Dumper($name, $value, '.');

  # fill property slot with given 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;

  # 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") 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 {
  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;

  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!
      # 2004-06-16 - found out delimiter required for PERL5LIB, reverting back to V1!
      
      # 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];
      # V3: mix V1+V2 (because V1 doesn't fit at freeBSD..)
      if(RUNNING_IN_HEAVEN()) {
        $ENV{PERL5LIB} = $INC[1];
      } else {
        my $delimiter = ':';
        $delimiter = ';' if RUNNING_IN_HELL();
        $ENV{PERL5LIB} = join($delimiter, @INC);
      }
      
      #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<code>\n$code\n</code>", '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<code>\n$code\n</code>", 'info');
    
    # do it
    #eval($code);
    #$self->log("\n<code>\n$code\n</code>", 'error') if $@;
    
  } else {
    $self->log("FIXME: Script language '$args->{language}' not implemented.", 'error');
    
  }

}

1;
__END__
1	joko	1.1	## ----------------------------------------------------------------------
2	jonen	1.16	## $Id: Engine.pm,v 1.15 2004/06/16 16:37:59 joko Exp $
3	joko	1.1	## ----------------------------------------------------------------------
4	joko	1.2	## $Log: Engine.pm,v $
5	jonen	1.16	## Revision 1.15 2004/06/16 16:37:59 joko
6			## attempt to get things going in a generic way (Linux/FreeBSD/Win32)
7			##
8	joko	1.15	## Revision 1.14 2004/05/12 14:23:31 jonen
9			## add comment/code related to PERL5LIB var at different OS's
10			##
11	jonen	1.14	## Revision 1.13 2003/12/05 05:02:08 joko
12			## + minor update: disabled some unnecessary loggers or changed to debug-level
13			##
14	joko	1.13	## Revision 1.12 2003/06/24 20:59:51 jonen
15			## added option 'detach'
16			##
17	jonen	1.12	## Revision 1.11 2003/06/23 17:54:32 joko
18			## prepared execution of in-process perl-code via eval (not activated yet!)
19			##
20	joko	1.11	## Revision 1.10 2003/05/13 07:56:12 joko
21			## enhanced: hierarchical containers for context handling
22			## fixes: some pre-flight checks
23			## new: propagate "end-tag" event to e.g. close containers
24			##
25	joko	1.10	## Revision 1.9 2003/04/04 17:23:11 joko
26			## minor update: debugging output
27			##
28	joko	1.9	## Revision 1.8 2003/03/29 07:11:54 joko
29			## modified: sub run_executable
30			## new: sub run_script
31			##
32	joko	1.8	## Revision 1.7 2003/03/28 07:02:56 joko
33			## modified structure around '$wrapper_program'
34			##
35	joko	1.7	## Revision 1.6 2003/03/27 15:31:05 joko
36			## fixes to modules regarding new namespace(s) below Data::Mungle::*
37			##
38	joko	1.6	## Revision 1.5 2003/03/27 15:03:03 joko
39			## enhanced 'sub run_executable'
40			##
41	joko	1.5	## Revision 1.4 2003/02/22 16:51:21 joko
42			## + enhanced run_executable
43			## modified logging output
44			##
45	joko	1.4	## Revision 1.3 2003/02/21 01:46:17 joko
46			## renamed core function
47			##
48	joko	1.3	## Revision 1.2 2003/02/20 19:46:33 joko
49			## renamed and revamped some of modules
50			## renamed methods
51			## + sub run_executable
52			##
53	joko	1.2	## Revision 1.1 2003/02/18 15:35:25 joko
54			## + initial commit
55			##
56	joko	1.1	## ----------------------------------------------------------------------
57
58
59			package Data::Rap::Engine;
60
61			use strict;
62			use warnings;
63
64
65			use Data::Dumper;
66	joko	1.2	use Hash::Merge qw( merge );
67	joko	1.1	use Iterate;
68	joko	1.2
69	jonen	1.16	use shortcuts qw( run_cmd RUNNING_IN_HELL RUNNING_IN_HEAVEN );
70	joko	1.6	use Data::Mungle::Code::Ref qw( ref_slot );
71	joko	1.8	use Data::Mungle::Transform::Deep qw( expand deep_copy );
72			use File::Temp qw/ tempfile tempdir /;
73	joko	1.1
74	joko	1.13	my $DEBUG = 0;
75	joko	1.1
76			sub performTarget {
77			my $self = shift;
78			my $targetname = shift;
79	joko	1.2	$self->perform_target($targetname);
80			}
81
82			sub perform_target {
83			my $self = shift;
84			my $targetname = shift;
85
86	joko	1.10	# pre-flight checks
87			if (!$targetname) {
88			$self->log("Target name empty. Please try to specify (e.g.) on the command line.", 'critical');
89			return;
90			}
91
92	joko	1.4	my $header = ("- " x 12) . " " . $targetname . " " . ("- " x 6);
93
94	joko	1.8	# V1
95	joko	1.4	#$self->log("- " x 35, 'notice');
96			#$self->log("Performing Target '$targetname'.", 'notice');
97
98	joko	1.8	# V2
99			#$self->log($header, 'notice');
100
101			# V3
102	joko	1.13	#$self->log("- " x 20, 'info');
103	joko	1.8	$self->log("Performing Target '$targetname'.", 'notice');
104	joko	1.2
105			#exit;
106
107			my $target = $self->getTargetDetails($targetname);
108	joko	1.1
109			# trace
110			#print Dumper($target);
111			#exit;
112
113	joko	1.2	$self->perform_dependencies($target);
114			$self->perform_details($target);
115	joko	1.10
116			return 1;
117	joko	1.2
118			}
119
120			sub perform_dependencies {
121			my $self = shift;
122			my $target = shift;
123	joko	1.1	# resolve dependencies (just run prior)
124			if (my $targetname_dep = $target->{attrib}->{depends}) {
125	joko	1.2	my @targets = split(/,\s\|,/, $targetname_dep);
126			#print Dumper(@targets);
127			#$self->perform($targetname_dep);
128			#delete $target->{attrib}->{depends};
129			foreach (@targets) {
130			if (!$self->{__rap}->{dependencies}->{resolved}->{$_}++) {
131			$self->perform_target($_);
132			}
133			}
134	joko	1.1	delete $target->{attrib}->{depends};
135			}
136	joko	1.2	}
137	joko	1.1
138	joko	1.2	sub perform_details {
139			my $self = shift;
140			my $target = shift;
141
142			#print Dumper($target);
143			#exit;
144
145	joko	1.1	foreach my $entry (@{$target->{content}}) {
146			my $command = $entry->{name};
147			my $args = $entry->{attrib};
148	joko	1.8	my $content = $entry->{content};
149	joko	1.10	$self->perform_command($command, $args, $content, { warn => 1 } );
150	joko	1.2	# check recursiveness
151	jonen	1.12	# new condition: don't recurse if node is flagged to have inline-args (2003-04-17)
152	joko	1.10	my $has_inline_args = ($entry->{attrib}->{_args} && $entry->{attrib}->{_args} eq 'inline');
153			if ($entry->{content} && ref $entry->{content} && !$has_inline_args) {
154	joko	1.2	$self->perform_details($entry);
155			}
156	joko	1.10	# new of 2003-05-08
157	jonen	1.12	$command \|\|= '';
158	joko	1.10	$self->perform_command($command . '_end', undef, undef, { warn => 0 } );
159	joko	1.1	}
160			}
161
162			sub rc {
163			my $self = shift;
164	joko	1.2	return $self->perform_command(@_);
165	joko	1.1	}
166
167	joko	1.2	sub perform_command {
168	joko	1.1	my $self = shift;
169			my $command = shift;
170	joko	1.8	my $args_list = shift;
171			my $content = shift;
172	joko	1.10	my $options = shift;
173	joko	1.2
174	joko	1.1	if (!$command) {
175	joko	1.13	$self->log("Command was empty!", 'debug') if $DEBUG;
176	joko	1.1	return;
177			}
178	joko	1.2
179			# FIXME: make '__PACKAGE__' go one level deeper properly!
180	joko	1.13	$self->log( __PACKAGE__ . "->perform_command: " . $command, 'debug') if $DEBUG;
181	joko	1.1
182	joko	1.10
183			# 1. make arguments from list of arguments(?)
184
185	joko	1.1	my $args = {};
186			#print Dumper($args_list);
187			if ($args_list) {
188			if (ref $args_list eq 'ARRAY') {
189			foreach (@$args_list) {
190			$args = merge($args, $_);
191			}
192			} else {
193			$args = $args_list;
194			}
195			}
196	joko	1.2
197
198	joko	1.10	# 2. prepare command
199
200			# default setting for internal rap commands
201			my $method_prefix_default = '_';
202			# setting from property database
203			my $method_prefix_setting = $self->get_property('core.method_prefix');
204			#print "setting: ", $method_prefix_setting, "\n";
205			my $prefix = $method_prefix_setting;
206			if (not defined $prefix) {
207			$prefix = $method_prefix_default;
208			}
209			$command = $prefix . $command;
210
211
212			# 3. determine container
213	joko	1.2	my $container; # = $self->getInstance();
214	joko	1.10	#$container \|\|= $self->getInstance();
215	joko	1.2	$container \|\|= $self;
216
217	joko	1.10	# 4. run method
218	joko	1.2	if ($container->can($command)) {
219	joko	1.8	$container->$command($args, $content);
220	joko	1.1	} else {
221	joko	1.10	my $level = "debug";
222			$level = "warning" if $options->{warn};
223	joko	1.13	$self->log("Command '$command' not implemented.", $level) if $DEBUG;
224	joko	1.1	}
225	joko	1.2
226	joko	1.1	}
227
228	joko	1.2
229			sub merge_properties {
230	joko	1.1	my $self = shift;
231	joko	1.2	my $name = shift;
232			my $data = shift;
233	joko	1.1
234	joko	1.2	$self->log("merge-name: $name");
235			#print "name: $name", "\n";
236			#print Dumper($data);
237			#exit;
238	joko	1.1
239	joko	1.2	# check if slot (or childs of it) is/are already occupied
240			#if (my $data_old = ref_slot($self, $name, undef, '.')) {
241			if (my $data_old = $self->get_property($name)) {
242			#print "old:", "\n";
243			#print Dumper($data_old);
244
245			# FIXME: review - any options for 'merge' here?
246			my $data_new = merge($data_old, $data);
247			#print "DATA NEE! - MERGE!", "\n";
248			#print Dumper($data_new);
249			#exit;
250	joko	1.3	#merge_to($self, $data_new);
251	joko	1.2	$self->set_property( { name => $name, value => $data_new } );
252
253	joko	1.1	} else {
254	joko	1.2
255			=pod
256			# make up a dummy hash matching the structure of the destination one
257			my $dummy = {};
258			ref_slot($dummy, $name, $data, '.');
259			print Dumper($dummy);
260
261			# mix into destination
262			mixin($self, $dummy, { init => 1 });
263			=cut
264
265			ref_slot($self, $name, $data, '.');
266
267	joko	1.1	}
268	joko	1.2
269
270			#print Dumper($self);
271			#exit;
272			#$self->
273
274			}
275	joko	1.1
276	joko	1.2	sub set_property {
277			my $self = shift;
278			my $args = shift;
279
280			$self->interpolate($args) ;
281			my $name = $args->{name};
282			my $value = $args->{value};
283			$name = '__rap.properties.' . $name;
284
285			$self->log("set-name: $name");
286	joko	1.1
287	joko	1.10	#print Dumper($name, $value, '.');
288
289	joko	1.1	# fill property slot with given value
290	joko	1.10	# fix (2003-04-17): always do fill if value is defined!!!
291			if (defined $value) {
292	joko	1.2	ref_slot($self, $name, $value, '.');
293	joko	1.1	}
294
295	joko	1.2	#print Dumper($self);
296
297	joko	1.1	# FIXME!!!
298	joko	1.2	#return if ! ref $args;
299	joko	1.1
300			# fill property slot with (probably bigger) data structure from property-/configuration-style - file
301			if (my $file = $args->{file}) {
302			my $type = $args->{type};
303			if (!$type) {
304			die("default file (no type specified) is not implemented yet!");
305
306			} elsif ($type eq 'perl-eval') {
307			#die($type);
308			$self->loadFromPerlFile($file, $name, $args->{'varnames'});
309
310			} elsif ($type eq 'App::Config') {
311			die("not implemented: $type");
312
313			}
314
315			} elsif (my $command = $args->{command}) {
316	joko	1.2	$self->perform_command($command, $args);
317	joko	1.1
318			}
319
320			}
321
322			sub get_property {
323			my $self = shift;
324			#my $args = shift;
325			my $name = shift;
326
327			#$self->interpolate($args);
328
329			#my $name = $args->{name};
330	joko	1.2	my $result;
331
332			if (!$name) {
333			$self->log( __PACKAGE__ . ": no name!", 'critical');
334
335			} elsif ($name eq '/') {
336			$result = expand($self);
337
338			} elsif ($name eq '.') {
339			if (my $instance = $self->getInstance()) {
340			$result = expand($instance);
341			} else {
342			$result = ref_slot($self, '__rap.properties', undef, '.');
343
344			}
345	joko	1.1
346	joko	1.2	} else {
347
348			$name = '__rap.properties.' . $name;
349
350	joko	1.13	$self->log("get-name: $name") if $DEBUG;
351	joko	1.2
352			# get property slot and return value
353			$result = ref_slot($self, $name, undef, '.');
354
355			# FIXME: Is this okay? It's provided for now in order not
356			# to deliver an 'undef' to the regex below inside 'interpolate'.
357			# revamp this, maybe!
358			#$result \|\|= ''; # NO!!!
359			}
360	joko	1.1
361	joko	1.2	return $result;
362	joko	1.1	}
363
364			sub interpolate {
365			my $self = shift;
366			my $ref = shift;
367			IterHash %$ref, sub {
368			#print $_[1], "\n";
369			$_[1] =~ s/\${(.+)}/$self->get_property($1)/e;
370			}
371			}
372	joko	1.2
373			sub run_executable {
374			my $self = shift;
375			my $opts = shift;
376
377	joko	1.8	my $meta = deep_copy($opts);
378
379			delete $opts->{caption};
380			delete $opts->{async};
381	jonen	1.12	delete $opts->{detach};
382	joko	1.8
383			#print Dumper($meta);
384
385	joko	1.2	if ($opts->{executable}) {
386
387			my $program = $opts->{executable};
388			delete $opts->{executable};
389
390	joko	1.5	# determine execution method
391			my $wrapper_program = '';
392
393			# check if program is a namespace-string (contains '::') - use 'do' in this case!
394			if ($program =~ /::/) {
395	joko	1.7	#$wrapper_program = 'rap.pl';
396			$wrapper_program = $0;
397	joko	1.5	}
398
399			# prepare arguments
400	joko	1.2	my @buf;
401			foreach (keys %$opts) {
402			my $value = $opts->{$_};
403	joko	1.4	if (m/^_/) {
404			if ($_ eq '_switches') {
405			my @switches = split(/,\s\|,/, $value);
406			foreach my $switch (@switches) {
407			push @buf, '--' . $switch;
408			}
409			}
410			next;
411			}
412
413	joko	1.2	if ($value =~ /\s/) {
414			$value = "\"$value\"";
415			}
416			push @buf, "--$_=$value";
417			}
418	joko	1.5
419			# build {program} & {arguments}
420	joko	1.7	my $cmd = ($wrapper_program ? $wrapper_program . ' ' : '') . $program . ' ' . join(' ', @buf);
421	joko	1.2
422			# trace
423			#print "command: $cmd", "\n";
424
425			# start process
426	joko	1.15	# 2004-05-11 - seems like only ONE args is valid at PERL5LIB, so we use V2!
427			# 2004-06-16 - found out delimiter required for PERL5LIB, reverting back to V1!
428
429	jonen	1.14	# V1: join all args
430	jonen	1.16	#my $delimiter = ':';
431			#$delimiter = ';' if RUNNING_IN_HELL();
432			#$ENV{PERL5LIB} = join($delimiter, @INC);
433	jonen	1.14	# V2: insert only FIRST arg
434	joko	1.15	#$ENV{PERL5LIB} = $INC[0];
435	jonen	1.14	# WARNING: at (free)BSD our var is the SECOND, NOT FIRST!!
436			# FIXME!! Do this in an abstract way!!
437			#$ENV{PERL5LIB} = $INC[1];
438	jonen	1.16	# V3: mix V1+V2 (because V1 doesn't fit at freeBSD..)
439			if(RUNNING_IN_HEAVEN()) {
440			$ENV{PERL5LIB} = $INC[1];
441			} else {
442			my $delimiter = ':';
443			$delimiter = ';' if RUNNING_IN_HELL();
444			$ENV{PERL5LIB} = join($delimiter, @INC);
445			}
446	joko	1.2
447			#print Dumper(%ENV);
448	joko	1.5
449	joko	1.7	#print "command: '$cmd'", "\n";
450	joko	1.5
451			# V1 - basic
452			#run_cmd($cmd);
453
454			# V1.b - enhanced: variable local method
455	joko	1.8	$meta->{caption} \|\|= '';
456			$meta->{async} \|\|= 0;
457	jonen	1.12	$meta->{detach} \|\|= 0;
458	joko	1.10	# new of 2003-05-08: USE_PATH!
459			$meta->{USE_PATH} \|\|= 0;
460	jonen	1.12	my $evalstr = "run_cmd('$cmd', '$meta->{caption}', { async => $meta->{async}, detach => $meta->{detach}, USE_PATH => $meta->{USE_PATH} });";
461	joko	1.5	eval($evalstr);
462			#my $res = do "$cmd";
463			#print $res, "\n" if $res;
464
465			#$self->log("run_executable: $evalstr", 'info');
466			$self->raiseException("run_executable: $evalstr\n$@") if $@;
467
468	joko	1.2	# V2: via IPC::Run
469			# .... (TODO)
470	joko	1.7
471	joko	1.2
472			}
473
474			}
475
476	joko	1.8
477			sub run_script {
478
479			my $self = shift;
480			my $args = shift;
481			my $code = shift;
482
483			if ($args->{language} eq 'msdos/bat') {
484
485			#print "code: $code", "\n";
486
487			# reporting
488			$self->log("Executing some arbitrary unsigned code (probably unsafe). [language=$args->{language}]", 'info');
489			$self->log("\n<code>\n$code\n</code>", 'info');
490
491			# create temporary intermediate file to execute code
492			my $tmpdir = '/tmp/rap';
493			mkdir $tmpdir;
494			(my $fh, my $filename) = tempfile( DIR => $tmpdir, SUFFIX => '.bat' );
495			print $fh $code, "\n";
496			run_cmd( $filename, '', { async => 1 } );
497
498			# FIXME: DELETE code inside temp-files as soon as possible!
499			#print $fh '';
500
501			# TODO: delete FILE completely!
502			# required for this: wait until execution has finished, then unlink....
503			# but: "how to wait until execution is finished"?
504			# i believe the best is to spawn another process directly from here,
505			# let's call it 'watcher-agent'.
506			# This one should monitor a certain running process and delete its
507			# executable file after it has finished execution.
508			# Possible extensions could be:
509			# keep track of all stuff sent to STDOUT or STDERR and
510			# send that stuff to the task-owner indirectly (not via shell/console)
511			# (e.g. via email, by posting report to a newsgroup or publishing on a specified web-page: use mod-dav!)
512
513			} elsif ($args->{language} eq 'bash') {
514			$self->log("FIXME: - - - - - -- - - -- BASH - - - - - - - -- - ", 'error');
515	joko	1.11
516			} elsif ($args->{language} eq 'perl') {
517
518			# reporting
519			#$self->log("Executing some arbitrary unsigned code (probably unsafe). [language=$args->{language}]", 'info');
520			#$self->log("\n<code>\n$code\n</code>", 'info');
521
522			# do it
523			#eval($code);
524			#$self->log("\n<code>\n$code\n</code>", 'error') if $@;
525	joko	1.8
526			} else {
527			$self->log("FIXME: Script language '$args->{language}' not implemented.", 'error');
528
529			}
530
531			}
532	joko	1.1
533			1;
534			__END__
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26