perl/libs/shortcuts.pm

## ---------------------------------------------------------------------------
##  $Id: shortcuts.pm,v 1.12 2003/06/23 19:43:19 joko Exp $
## ---------------------------------------------------------------------------
##  $Log: shortcuts.pm,v $
##  Revision 1.12  2003/06/23 19:43:19  joko
##  minor cleanup
##  now using IPC::Session::NoShell
##
##  Revision 1.11  2003/06/23 17:41:50  jonen
##  + NEW - used IPC::Session instead of IPC::Run to get better results at linux
##
##  Revision 1.10  2003/06/23 15:59:16  joko
##  major/minor fixes?
##
##  Revision 1.9  2003/05/13 05:36:24  joko
##  heavy modifications to run_cmd
##  + sub get_executable
##  + sub get_executable_wrapper
##
##  Revision 1.8  2003/04/04 17:31:59  joko
##  + sub make_guid
##
##  Revision 1.7  2003/03/29 07:24:10  joko
##  enhanced 'run_cmd': now tries to execute program with appropriate application (e.g. 'cmd.exe' or 'perl')
##
##  Revision 1.6  2003/03/28 06:58:06  joko
##  new: 'run_cmd' now asynchronous! (via IPC::Run...)
##
##  Revision 1.5  2003/02/22 17:26:13  joko
##  + enhanced unix compatibility fix
##
##  Revision 1.4  2003/02/22 17:19:36  joko
##  + unix compatibility fix
##
##  Revision 1.3  2003/02/14 14:17:04  joko
##  - shortened seperator
##
##  Revision 1.2  2003/02/11 05:14:28  joko
##  + refactored code from libp.pm
##
##  Revision 1.1  2003/02/09 04:49:45  joko
##  + shortcuts now refactored to this file
##
## ---------------------------------------------------------------------------


package shortcuts;

use strict;
use warnings;

require Exporter;
our @ISA = qw( Exporter );
our @EXPORT_OK = qw( 
  strftime
  now today
  run_cmd run_cmds
  get_chomped
  bool2status
  make_guid
);


use Data::Dumper;
use POSIX qw( strftime );
#use IPC::Run qw( run timeout );
use IPC::Run qw( start pump finish timeout run ) ;
use Carp;

# NEW - 2003-06-23 for Linux (what about *BSD?)
use IPC::Session;


# $now_string = strftime "%a %b %e %H:%M:%S %Y", localtime;
# see "perldoc -f localtime"
sub now {
  my $options = shift;
  my $pattern = "%Y-%m-%d %H:%M:%S";
  $pattern = "%Y-%m-%d_%H-%M-%S" if $options->{fs};
  my $result = strftime($pattern, localtime);
  return $result;
}

sub today {
  return strftime("%Y-%m-%d", localtime);
}

sub RUNNING_IN_HELL () { $^O eq 'MSWin32' }


sub get_executable {
  my $cmd = shift;
  # FIXME: detect type of program and run with proper application/interpreter
  # using IPC::Run we have to dispatch this on our own! *no* os-interaction or interpolation here!?
  # => better use absolute path-names only?!
  my $application = '';
  if ($cmd =~ m/\w+\.pl\s*.*/) {
      $application = get_interpreter_wrapper($cmd, 'perl');
      #$cmd = "$application $cmd" if $application;
      $application .= ' ';
    
  } else {
    $application = './';
  }
  return $application;
}

sub get_interpreter_wrapper {
  my $cmd = shift;
  my $language = shift;
  $language ||= '';

  my $wrapper = '';

  if ($language eq 'perl') {
  
    if (RUNNING_IN_HELL()) {
      # Required to adapt to IPC::Run on win32.
      $wrapper = 'cmd.exe /C perl';
    } else {
      # NEW 2003-06-23 - needed if used with IPC::Session (at Linux)
      #  whats about Win32?
      $wrapper = 'perl';
    }
    
  } else {
    die("No wrapper for language '$language'.");
  }
  
  return $wrapper;
}


sub run_cmd {
  my $cmd = shift;
  my $caption = shift;
  my $options = shift;
  
  #print Dumper($options);
  
  # report - header
  my $sep = "-" x 60;
  print STDERR $sep, "\n";
  print STDERR "  ", $cmd;
  print STDERR " - ", $caption if $caption;
  print STDERR "\n", $sep, "\n";
  
  # strip name of executable from full command string
  $cmd =~ m/(.+?)\s/;
  my $executable = $1;
  
=pod
  # for unix: check if executable is in local directory, if so - prefix with './'
  if (!RUNNING_IN_HELL()) {
    #if ($cmd !~ m/\//) {
    if (-e $executable) {
    }
  }
=cut

  # new of 2003-05-07: basedir option to be prepended to command string
  my $basedir = $options->{BASEDIR};
  my $use_path = $options->{USE_PATH};

  # for all systems: check existance of files - use basedir if given, try current directory otherwise
  if ($basedir) {
    -e "$basedir/$executable" or die("$basedir/$executable does not exist.");
    $basedir .= '/';
  } elsif ($use_path) {
    $basedir = "";
  } else {
    -e $executable or die("$executable does not exist.");
    #$basedir = ".";
    #$basedir .= './';
    $basedir = "";
  }
  $cmd = "$basedir$cmd";

  # V1 - backticks or qq{}
  #`$cmd`;
  #qq{$cmd};
  
  # V2 - via 'system'
  #system($cmd);

  if (not $use_path) {
    my $application = get_executable($cmd);
    $cmd = "$application$cmd" if $application;
  }

  # V3 - using IPC (optional)
  if ($options->{async}) {

    #run \@cmd, \$in, \$out, \$err, timeout( 10 ) or die "cat: $?";
    my @cmd = split(' ', $cmd);
    
    
    # V3.1 - using IPC::Run
    #
    # tests:
    
    if (RUNNING_IN_HELL()) {
    
      #my $in; my $out; my $err;
      print STDERR "run_cmd: IPC::Run: $cmd", "\n";
      
      # no success!
      #start \@cmd, timeout(0) or croak("run_cmd: IPC::Run could not start '$cmd'.");
      #
      # success on Win32, but seems broken at 'timeout' on linux:
      run(\@cmd, timeout(4)) or croak("run_cmd: IPC::Run could not start '$cmd'.");
          
      # other tests ;)
      #$IPC::Run::Timer::timeout = 2000;
      #start $cmd or die("IPC::Run could not start '$cmd'.");
      
    } else {

      print STDERR "run_cmd: IPC::Session: $cmd", "\n";

      # V3.2 - using IPC::Session
      #  success on Linux AND Win32 ??
      #
      # set timeout:
      #  (don't really know why we needs 2 secconds
      #   to wait for init of process !?!)
      my $session_timeout = 3;
      # set session name (default: cmd as string):
      my $session_name = $cmd;
      # create session:
      my $session = IPC::Session->new($session_name, $session_timeout);
      
      # send 'cmd' to session - not required since complete command is sent via constructor above
      $session->send(\@cmd);
      
      #print $session->stdout(), "\n";
      
      # optional switch case:
      #for ($session->stdout()) {
      #}
      # optional get error:
      #my $err = session->stderr();
    }
    
  } else {
    print STDERR "run_cmd: system('$cmd').", "\n";
    system($cmd);
  }
  
  print STDERR "run_cmd: ready.", "\n";
  
}

sub run_cmds {
  my $options = {};
  if (ref $_[$#_] eq 'HASH') {
    #print "YAI", "\n";
    $options = pop @_;
  }
  foreach (@_) {
    run_cmd($_, '', $options);
  }
}

sub get_chomped {
  my $str = shift;
  chomp($str);
  return $str;
}

sub bool2status {
  my $bool = shift;
  return ($bool ? 'ok' : 'failed');
}

# create global unique identifers using Data::UUID
# if updating this code, please also modify Tangram::Storage::make_guid
sub make_guid 
  {
    my $self = shift;

    my $guid;

    # try to use Data::UUID first ...
    eval("use Data::UUID;");
    if (!$@) {
      my $ug = Data::UUID->new();
      $guid = $ug->create_str();
      
    # ... if this fails, try to fallback to Data::UUID::PurePerl instead ...
    } else {
      eval("use Data::UUID::PurePerl;");
      if (!$@) {
        $guid = Data::UUID::PurePerl::generate_id();
      } else {
        croak "couldn't create globally unique identifier";
      }
    }
    
    return $guid;
  }

1;
__END__
1	joko	1.1	## ---------------------------------------------------------------------------
2	joko	1.13	## $Id: shortcuts.pm,v 1.12 2003/06/23 19:43:19 joko Exp $
3	joko	1.1	## ---------------------------------------------------------------------------
4			## $Log: shortcuts.pm,v $
5	joko	1.13	## Revision 1.12 2003/06/23 19:43:19 joko
6			## minor cleanup
7			## now using IPC::Session::NoShell
8			##
9	joko	1.12	## Revision 1.11 2003/06/23 17:41:50 jonen
10			## + NEW - used IPC::Session instead of IPC::Run to get better results at linux
11			##
12	jonen	1.11	## Revision 1.10 2003/06/23 15:59:16 joko
13			## major/minor fixes?
14			##
15	joko	1.10	## Revision 1.9 2003/05/13 05:36:24 joko
16			## heavy modifications to run_cmd
17			## + sub get_executable
18			## + sub get_executable_wrapper
19			##
20	joko	1.9	## Revision 1.8 2003/04/04 17:31:59 joko
21			## + sub make_guid
22			##
23	joko	1.8	## Revision 1.7 2003/03/29 07:24:10 joko
24			## enhanced 'run_cmd': now tries to execute program with appropriate application (e.g. 'cmd.exe' or 'perl')
25			##
26	joko	1.7	## Revision 1.6 2003/03/28 06:58:06 joko
27			## new: 'run_cmd' now asynchronous! (via IPC::Run...)
28			##
29	joko	1.6	## Revision 1.5 2003/02/22 17:26:13 joko
30			## + enhanced unix compatibility fix
31			##
32	joko	1.5	## Revision 1.4 2003/02/22 17:19:36 joko
33			## + unix compatibility fix
34			##
35	joko	1.4	## Revision 1.3 2003/02/14 14:17:04 joko
36			## - shortened seperator
37			##
38	joko	1.3	## Revision 1.2 2003/02/11 05:14:28 joko
39			## + refactored code from libp.pm
40			##
41	joko	1.2	## Revision 1.1 2003/02/09 04:49:45 joko
42			## + shortcuts now refactored to this file
43			##
44	joko	1.1	## ---------------------------------------------------------------------------
45
46
47			package shortcuts;
48
49			use strict;
50			use warnings;
51
52			require Exporter;
53			our @ISA = qw( Exporter );
54			our @EXPORT_OK = qw(
55			strftime
56			now today
57			run_cmd run_cmds
58			get_chomped
59	joko	1.2	bool2status
60	joko	1.8	make_guid
61	joko	1.1	);
62
63
64			use Data::Dumper;
65	joko	1.6	use POSIX qw( strftime );
66			#use IPC::Run qw( run timeout );
67	joko	1.9	use IPC::Run qw( start pump finish timeout run ) ;
68	joko	1.8	use Carp;
69
70	joko	1.13	# NEW - 2003-06-23 for Linux (what about *BSD?)
71			use IPC::Session;
72	joko	1.8
73	joko	1.1
74			# $now_string = strftime "%a %b %e %H:%M:%S %Y", localtime;
75			# see "perldoc -f localtime"
76			sub now {
77			my $options = shift;
78			my $pattern = "%Y-%m-%d %H:%M:%S";
79			$pattern = "%Y-%m-%d_%H-%M-%S" if $options->{fs};
80			my $result = strftime($pattern, localtime);
81			return $result;
82			}
83
84			sub today {
85			return strftime("%Y-%m-%d", localtime);
86			}
87
88	joko	1.12	sub RUNNING_IN_HELL () { $^O eq 'MSWin32' }
89
90
91	joko	1.9	sub get_executable {
92			my $cmd = shift;
93			# FIXME: detect type of program and run with proper application/interpreter
94			# using IPC::Run we have to dispatch this on our own! no os-interaction or interpolation here!?
95			# => better use absolute path-names only?!
96			my $application = '';
97			if ($cmd =~ m/\w+\.pl\s./) {
98	joko	1.13	$application = get_interpreter_wrapper($cmd, 'perl');
99			#$cmd = "$application $cmd" if $application;
100			$application .= ' ';
101
102	joko	1.10	} else {
103			$application = './';
104	joko	1.9	}
105			return $application;
106			}
107
108	joko	1.13	sub get_interpreter_wrapper {
109	joko	1.9	my $cmd = shift;
110	joko	1.13	my $language = shift;
111			$language \|\|= '';
112
113			my $wrapper = '';
114
115			if ($language eq 'perl') {
116
117			if (RUNNING_IN_HELL()) {
118			# Required to adapt to IPC::Run on win32.
119			$wrapper = 'cmd.exe /C perl';
120			} else {
121			# NEW 2003-06-23 - needed if used with IPC::Session (at Linux)
122			# whats about Win32?
123			$wrapper = 'perl';
124			}
125
126			} else {
127			die("No wrapper for language '$language'.");
128			}
129
130			return $wrapper;
131	joko	1.9	}
132
133
134	joko	1.1	sub run_cmd {
135			my $cmd = shift;
136			my $caption = shift;
137	joko	1.6	my $options = shift;
138
139	joko	1.9	#print Dumper($options);
140
141	joko	1.6	# report - header
142	joko	1.3	my $sep = "-" x 60;
143	joko	1.12	print STDERR $sep, "\n";
144			print STDERR " ", $cmd;
145			print STDERR " - ", $caption if $caption;
146			print STDERR "\n", $sep, "\n";
147	joko	1.4
148	joko	1.5	# strip name of executable from full command string
149			$cmd =~ m/(.+?)\s/;
150			my $executable = $1;
151
152	joko	1.9	=pod
153	joko	1.5	# for unix: check if executable is in local directory, if so - prefix with './'
154	joko	1.4	if (!RUNNING_IN_HELL()) {
155	joko	1.5	#if ($cmd !~ m/\//) {
156			if (-e $executable) {
157	joko	1.4	}
158			}
159	joko	1.9	=cut
160
161			# new of 2003-05-07: basedir option to be prepended to command string
162			my $basedir = $options->{BASEDIR};
163			my $use_path = $options->{USE_PATH};
164
165			# for all systems: check existance of files - use basedir if given, try current directory otherwise
166			if ($basedir) {
167			-e "$basedir/$executable" or die("$basedir/$executable does not exist.");
168			$basedir .= '/';
169			} elsif ($use_path) {
170			$basedir = "";
171			} else {
172			-e $executable or die("$executable does not exist.");
173			#$basedir = ".";
174	joko	1.10	#$basedir .= './';
175	joko	1.12	$basedir = "";
176	joko	1.9	}
177			$cmd = "$basedir$cmd";
178
179	joko	1.6	# V1 - backticks or qq{}
180	joko	1.1	#`$cmd`;
181	joko	1.6	#qq{$cmd};
182
183			# V2 - via 'system'
184			#system($cmd);
185
186	joko	1.10	if (not $use_path) {
187			my $application = get_executable($cmd);
188			$cmd = "$application$cmd" if $application;
189			}
190
191	jonen	1.11	# V3 - using IPC (optional)
192	joko	1.6	if ($options->{async}) {
193	jonen	1.11
194	joko	1.6	#run \@cmd, \$in, \$out, \$err, timeout( 10 ) or die "cat: $?";
195	jonen	1.11	my @cmd = split(' ', $cmd);
196	joko	1.6
197
198	jonen	1.11	# V3.1 - using IPC::Run
199			#
200			# tests:
201	joko	1.13
202			if (RUNNING_IN_HELL()) {
203
204			#my $in; my $out; my $err;
205			print STDERR "run_cmd: IPC::Run: $cmd", "\n";
206
207			# no success!
208			#start \@cmd, timeout(0) or croak("run_cmd: IPC::Run could not start '$cmd'.");
209			#
210			# success on Win32, but seems broken at 'timeout' on linux:
211			run(\@cmd, timeout(4)) or croak("run_cmd: IPC::Run could not start '$cmd'.");
212
213			# other tests ;)
214			#$IPC::Run::Timer::timeout = 2000;
215			#start $cmd or die("IPC::Run could not start '$cmd'.");
216
217			} else {
218
219			print STDERR "run_cmd: IPC::Session: $cmd", "\n";
220
221			# V3.2 - using IPC::Session
222			# success on Linux AND Win32 ??
223			#
224			# set timeout:
225			# (don't really know why we needs 2 secconds
226			# to wait for init of process !?!)
227			my $session_timeout = 3;
228			# set session name (default: cmd as string):
229			my $session_name = $cmd;
230			# create session:
231			my $session = IPC::Session->new($session_name, $session_timeout);
232
233			# send 'cmd' to session - not required since complete command is sent via constructor above
234			$session->send(\@cmd);
235
236			#print $session->stdout(), "\n";
237
238			# optional switch case:
239			#for ($session->stdout()) {
240			#}
241			# optional get error:
242			#my $err = session->stderr();
243			}
244	joko	1.6
245			} else {
246	joko	1.12	print STDERR "run_cmd: system('$cmd').", "\n";
247	joko	1.6	system($cmd);
248			}
249
250	joko	1.12	print STDERR "run_cmd: ready.", "\n";
251	joko	1.6
252	joko	1.1	}
253
254			sub run_cmds {
255	joko	1.9	my $options = {};
256			if (ref $_[$#_] eq 'HASH') {
257			#print "YAI", "\n";
258			$options = pop @_;
259			}
260	joko	1.1	foreach (@_) {
261	joko	1.9	run_cmd($_, '', $options);
262	joko	1.1	}
263			}
264
265			sub get_chomped {
266			my $str = shift;
267			chomp($str);
268			return $str;
269	joko	1.2	}
270
271			sub bool2status {
272			my $bool = shift;
273			return ($bool ? 'ok' : 'failed');
274	joko	1.1	}
275	joko	1.4
276	joko	1.8	# create global unique identifers using Data::UUID
277			# if updating this code, please also modify Tangram::Storage::make_guid
278			sub make_guid
279			{
280			my $self = shift;
281
282			my $guid;
283
284			# try to use Data::UUID first ...
285			eval("use Data::UUID;");
286			if (!$@) {
287			my $ug = Data::UUID->new();
288			$guid = $ug->create_str();
289
290			# ... if this fails, try to fallback to Data::UUID::PurePerl instead ...
291			} else {
292			eval("use Data::UUID::PurePerl;");
293			if (!$@) {
294			$guid = Data::UUID::PurePerl::generate_id();
295			} else {
296			croak "couldn't create globally unique identifier";
297			}
298			}
299
300			return $guid;
301			}
302	jonen	1.11
303	joko	1.1	1;
304	joko	1.12	__END__
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26