/[cvs]/nfo/perl/libs/shortcuts.pm
ViewVC logotype

Diff of /nfo/perl/libs/shortcuts.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.12

MailToCvsAdmin">MailToCvsAdmin
ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed