perl/libs/shortcuts.pm

## ---------------------------------------------------------------------------
##  $Id: shortcuts.pm,v 1.10 2003/06/23 15:59:16 joko Exp $
## ---------------------------------------------------------------------------
##  $Log: shortcuts.pm,v $
##  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
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 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*.*/) {
    # NEW 2003-06-23 - needed if used with IPC::Session (at Linux)
    #  whats about Win32?
    $application = 'perl ';
  } else {
    $application = './';
  }
  return $application;
}

sub get_executable_wrapper {
  my $cmd = shift;
  my $application = '';
  # Required to adapt to IPC::Run on win32.
  #if (RUNNING_IN_HELL()) {
    #$application = 'cmd.exe /C';
  #}
  return $application;
}


sub run_cmd {
  my $cmd = shift;
  my $caption = shift;
  my $options = shift;
  #$cmd = 'perl ' . $cmd;
  
  #print Dumper($options);
  
  # report - header
  my $sep = "-" x 60;
  print $sep, "\n";
  #print "  ", $cmd, "\n";
  #print "  ", "  $caption", "\n" if $caption;
  print "  ", $cmd;
  print " - ", $caption if $caption;
  print "\n";
  print $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 .= './';
  }
  $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}) {

    #$cmd = "$application $cmd" if $application;
    #my $application = get_executable_wrapper($cmd);
    
    print "run_cmd: IPC::Run: $cmd", "\n";
    #run \@cmd, \$in, \$out, \$err, timeout( 10 ) or die "cat: $?";
        
    my @cmd = split(' ', $cmd);
    
    
    # V3.1 - using IPC::Run
    #
    # tests:
    #my $in; my $out; my $err;
    #print "IPC::Run: $cmd", "\n";
    #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(2)) 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'.");


    # 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 = 2;
    # set session name (default: cmd as string):
    my $session_name = $cmd;
    # create session:
    my $session = new IPC::Session($session_name, $session_timeout);
    # send 'cmd' to session:
    $session->send(\@cmd);
    # optional switch case:
    #for ($session->stdout()) {
    #}
    # optional get error:
    #my $err = session->stderr();

    
  } else {
    print "run_cmd: system('$cmd').", "\n";
    system($cmd);
  }
  
  print "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');
}

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

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