[Bio] / FigKernelPackages / SeedAware.pm Repository:
ViewVC logotype

Annotation of /FigKernelPackages/SeedAware.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (view) (download) (as text)

1 : golsen 1.1 package SeedAware;
2 :    
3 :     # This is a SAS component.
4 :    
5 :     #===============================================================================
6 :     #
7 :     # This is a small set of utilities that handle differences for running
8 :     # software in the SEED environment, versus outside of it, and a small
9 :     # number of other commands for safely running external programs from
10 :     # within a perl script.
11 :     #
12 :     #===============================================================================
13 :     # Commands that run, read from, or write to a process, allowing control over
14 :     # the other input streams, as would normally be handled by a shell.
15 :     #
16 :     # $status = system_with_redirect( \%redirects, @cmd_and_args )
17 :     # $status = system_with_redirect( \%redirects, \@cmd_and_args )
18 :     # $fh = write_to_pipe_with_redirect( \%redirects, @cmd_and_args )
19 :     # $fh = write_to_pipe_with_redirect( \%redirects, \@cmd_and_args )
20 :     # $fh = read_from_pipe_with_redirect( \%redirects, @cmd_and_args )
21 :     # $fh = read_from_pipe_with_redirect( \%redirects, \@cmd_and_args )
22 :     #
23 :     # $status = system_with_redirect( @cmd_and_args, \%redirects )
24 :     # $status = system_with_redirect( \@cmd_and_args, \%redirects )
25 :     # $fh = write_to_pipe_with_redirect( @cmd_and_args, \%redirects )
26 :     # $fh = write_to_pipe_with_redirect( \@cmd_and_args, \%redirects )
27 :     # $fh = read_from_pipe_with_redirect( @cmd_and_args, \%redirects )
28 :     # $fh = read_from_pipe_with_redirect( \@cmd_and_args, \%redirects )
29 :     #
30 :     # Redirects:
31 :     #
32 :     # stdin => $file # Process will read from $file
33 :     # stdout => $file # Process will write to $file
34 :     # stderr => $file # stderr will be sent to $file (e.g., '/dev/null')
35 :     #
36 :     # The file name may begin with '<' or '>', but these are not necessary.
37 :     # If the supplied name begins with '>>', output will be appended to the file.a
38 :     #
39 :     # Simpler versions without redirects:
40 :     #
41 :     # $string = run_gathering_output( $cmd, @args )
42 :     # @lines = run_gathering_output( $cmd, @args )
43 :     #
44 :     # Line-by-line read from command:
45 :     #
46 :     # while ( $line = run_line_by_line( $cmd, @args ) ) { ... }
47 :     #
48 :     # my $cmd_and_args = [ $cmd, @args ];
49 :     # while ( $line = run_line_by_line( $cmd_and_args ) ) { ... }
50 :     #
51 :     # Close the file handle before end of file:
52 :     #
53 :     # close_line_by_line( $cmd, @args )
54 :     # close_line_by_line( $cmd_and_args )
55 :     #
56 :     # Find out the file handle associated with the command and args:
57 :     #
58 :     # $fh = line_by_line_fh( $cmd, @args )
59 :     # $fh = line_by_line_fh( $cmd_and_args )
60 :     #
61 :     #-----------------------------------------------------------------------------
62 :     # Read the entire contents of a file or stream into a string. This command
63 :     # if similar to $string = join( '', <FH> ), but reads the input by blocks.
64 :     #
65 :     # $string = slurp_input( ) # \*STDIN
66 :     # $string = slurp_input( $filename )
67 :     # $string = slurp_input( \*FILEHANDLE )
68 :     #
69 :     #-----------------------------------------------------------------------------
70 :     # Locate commands in special bin directories. If not in a seed environment,
71 :     # it just returns the bare command:
72 :     #
73 :     # $command_possibly_with_path = executable_for( $command )
74 :     #
75 :     #-----------------------------------------------------------------------------
76 :     # Locate the directory for temporary files in a SEED-aware, but not SEED-
77 :     # dependent manner:
78 :     #
79 :     # $tmp = location_of_tmp( )
80 :     # $tmp = location_of_tmp( \%options )
81 :     #
82 :     # The function returns the first valid directory that is writable by the user
83 :     # in the sequence:
84 :     #
85 :     # $options->{ tmp }
86 :     # $FIG_Config::temp
87 :     # /tmp
88 :     # .
89 :     #
90 :     # Failure returns undef.
91 :     #
92 :     #-----------------------------------------------------------------------------
93 :     # Locate or create a temporary directory for files in a SEED-aware, but not
94 :     # SEED-dependent manner.
95 :     #
96 :     # $tmp_dir = temporary_directory( $name, \%options )
97 :     # ( $tmp_dir, $save_dir ) = temporary_directory( $name, \%options )
98 :     # $tmp_dir = temporary_directory( \%options )
99 :     # ( $tmp_dir, $save_dir ) = temporary_directory( \%options )
100 :     #
101 :     # If defined, $tmp_dir will be the path to a temporary directory.
102 :     # If true, $save_dir indicates that the directory already existed, and
103 :     # therefore should not be deleted as the completion of its temporary
104 :     # usage.
105 :     #
106 :     # If $name is supplied, the directory in "tmp" is to have this name. This
107 :     # is also available as an option.
108 :     #
109 :     # Failure returns undef.
110 :     #
111 :     # The placement of the directory is the value returned by location_of_tmp().
112 :     #
113 :     # Options:
114 :     #
115 :     # base => $base # Base string for name of this temporary directory,
116 :     # # to which a random string will be appended.
117 :     # name => $name # Name of this temporary directory (without path).
118 :     # save_dir => $bool # Set $save_dir output (don't delete when done)
119 :     # tmp => $tmp # Directory in which the directory is to be placed
120 :     # # (D = location_of_tmp( $options )).
121 :     # tmp_dir => $tmp_dir # Name of the directory including implicit or
122 :     # # explict path. This option overrides name.
123 :     #
124 :     # The options { tmp => 'my_home', name => 'my_name' }
125 :     # are equivalent to { tmp_dir => 'my_home/my_name' }
126 :     #
127 :     #-----------------------------------------------------------------------------
128 :     # Create a name for a new file or directory that will not clobber an existing
129 :     # one.
130 :     #
131 :     # $file_name = new_file_name( )
132 :     # $file_name = new_file_name( $base_name )
133 : golsen 1.2 # $file_name = new_file_name( $base_name, $extention )
134 :     # $file_name = new_file_name( $base_name, $extention, $in_directory )
135 : golsen 1.1 #
136 :     #===============================================================================
137 :     use strict;
138 : olson 1.3 use Carp;
139 : golsen 1.1 require Exporter;
140 :     our @ISA = qw(Exporter);
141 :     our @EXPORT = qw(
142 :     system_with_redirect
143 :     write_to_pipe_with_redirect
144 :     read_from_pipe_with_redirect
145 :    
146 :     run_gathering_output
147 :     run_line_by_line
148 :     slurp_input
149 :    
150 :     executable_for
151 :     location_of_tmp
152 :     temporary_directory
153 :     new_file_name
154 :     );
155 :     our @EXPORT_OK = qw(
156 :     close_line_by_line
157 :     line_by_line_fh
158 :     );
159 :    
160 :     #
161 : olson 1.4 # Bah. On Windows, redirecty stuff needs IPC::Run.
162 :     #
163 :    
164 :     our $have_ipc_run;
165 :     if ($^O =~ /win32/i)
166 :     {
167 :     eval {
168 :     require IPC::Run;
169 :     $have_ipc_run = 1;
170 :     };
171 :     }
172 :    
173 :    
174 :     #
175 : golsen 1.1 # In case we are running in a SEED, pull in the FIG_Config
176 :     #
177 :     our $in_SEED;
178 : olson 1.3
179 : golsen 1.1 BEGIN
180 :     {
181 :     $in_SEED = 0;
182 :     eval { require FIG_Config; $in_SEED = 1 };
183 :     }
184 :    
185 :    
186 : olson 1.3
187 : golsen 1.1 #===============================================================================
188 :     # Commands that run, read from, or write to a process, allowing control over
189 :     # the other input streams, as would normally be handled by a shell.
190 :     #
191 :     # $status = system_with_redirect( \%redirects, @cmd_and_args )
192 :     # $status = system_with_redirect( \%redirects, \@cmd_and_args )
193 :     # $fh = write_to_pipe_with_redirect( \%redirects, @cmd_and_args )
194 :     # $fh = write_to_pipe_with_redirect( \%redirects, \@cmd_and_args )
195 :     # $fh = read_from_pipe_with_redirect( \%redirects, @cmd_and_args )
196 :     # $fh = read_from_pipe_with_redirect( \%redirects, \@cmd_and_args )
197 :     #
198 :     # $status = system_with_redirect( @cmd_and_args, \%redirects )
199 :     # $status = system_with_redirect( \@cmd_and_args, \%redirects )
200 :     # $fh = write_to_pipe_with_redirect( @cmd_and_args, \%redirects )
201 :     # $fh = write_to_pipe_with_redirect( \@cmd_and_args, \%redirects )
202 :     # $fh = read_from_pipe_with_redirect( @cmd_and_args, \%redirects )
203 :     # $fh = read_from_pipe_with_redirect( \@cmd_and_args, \%redirects )
204 :     #
205 :     # Redirects:
206 :     #
207 :     # stdin => $file # Where process should read from
208 :     # stdout => $file # Where process should write to
209 :     # stderr => $file # Where stderr should be sent (/dev/null comes to mind)
210 :     #
211 :     # '>' and '<' are not necessary, but use '>>' for appending to output files.
212 :     #===============================================================================
213 :     sub system_with_redirect
214 :     {
215 :     @_ or return undef;
216 :     my $opts = ( $_[0] && ref $_[0] eq 'HASH' ) ? shift
217 :     : ( $_[-1] && ref $_[-1] eq 'HASH' ) ? pop
218 :     : {};
219 :     @_ && defined $_[0] or return undef;
220 :     my @cmd_and_args = ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_;
221 :    
222 :     if ( $opts->{stdin} ) { open IN0, "<&STDIN"; open STDIN, fixin($opts->{stdin}) }
223 :     if ( $opts->{stdout} ) { open OUT0, ">&STDOUT"; open STDOUT, fixout($opts->{stdout}) }
224 :     if ( $opts->{stderr} ) { open ERR0, ">&STDERR"; open STDERR, fixout($opts->{stderr}) }
225 :    
226 :     my $stat = system( @cmd_and_args );
227 :    
228 :     if ( $opts->{stdin} ) { open STDIN, "<&IN0"; close IN0 }
229 :     if ( $opts->{stdout} ) { open STDOUT, ">&OUT0"; close OUT0 }
230 :     if ( $opts->{stderr} ) { open STDERR, ">&ERR0"; close ERR0 }
231 :    
232 :     $stat;
233 :     }
234 :    
235 :    
236 :     sub write_to_pipe_with_redirect
237 :     {
238 :     @_ or return undef;
239 :     my $opts = ( $_[0] && ref $_[0] eq 'HASH' ) ? shift
240 :     : ( $_[-1] && ref $_[-1] eq 'HASH' ) ? pop
241 :     : {};
242 :     @_ && defined $_[0] or return undef;
243 :     my @cmd_and_args = ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_;
244 :    
245 :     if ( $opts->{stdout} ) { open OUT0, ">&STDOUT"; open STDOUT, fixout($opts->{stdout}) }
246 :     if ( $opts->{stderr} ) { open ERR0, ">&STDERR"; open STDERR, fixout($opts->{stderr}) }
247 :    
248 :     my $okay = open( FH, '|-', @cmd_and_args );
249 :    
250 :     if ( $opts->{stdout} ) { open STDOUT, ">&OUT0"; close OUT0 }
251 :     if ( $opts->{stderr} ) { open STDERR, ">&ERR0"; close ERR0 }
252 :    
253 :     $okay ? \*FH : undef;
254 :     }
255 :    
256 :    
257 :     sub read_from_pipe_with_redirect
258 :     {
259 :     @_ or return undef;
260 :     my $opts = ( $_[0] && ref $_[0] eq 'HASH' ) ? shift
261 :     : ( $_[-1] && ref $_[-1] eq 'HASH' ) ? pop
262 :     : {};
263 :     @_ && defined $_[0] or return undef;
264 :     my @cmd_and_args = ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_;
265 :    
266 :     if ( $opts->{stdin} ) { open IN0, "<&STDIN"; open STDIN, fixin($opts->{stdin}) }
267 :     if ( $opts->{stderr} ) { open ERR0, ">&STDERR"; open STDERR, fixout($opts->{stderr}) }
268 :    
269 :     my $okay = open( FH, '-|', @cmd_and_args );
270 :    
271 :     if ( $opts->{stdin} ) { open STDIN, "<&IN0"; close IN0 }
272 :     if ( $opts->{stderr} ) { open STDERR, ">&ERR0"; close ERR0 }
273 :    
274 :     $okay ? \*FH : undef;
275 :     }
276 :    
277 :     # Format an input file request:
278 :    
279 :     sub fixin { local $_ = shift; /^\+?</ ? $_ : "<$_" }
280 :    
281 :    
282 :     # Format an output file request:
283 :    
284 :     sub fixout { local $_ = shift; /^\+?>/ ? $_ : ">$_" }
285 :    
286 :    
287 :     #===============================================================================
288 :     # Fork a command and read its output without invoking a shell. This is
289 :     # safer than the perl pipe command, which runs the command in a shell.
290 :     # But note that these commands only work for simple commands, not complex
291 :     # pipes (though the user could make a command file that implements any pipe
292 :     # desired).
293 :     #
294 :     # $string = run_gathering_output( $cmd, @args )
295 :     # @lines = run_gathering_output( $cmd, @args )
296 :     #
297 :     # This command is meant of situations in which the expected volume of output
298 :     # will not stress the available memory. For larger volumes of output that
299 :     # can be processed a line at a time, there is the run_line_by_line() function.
300 :     #
301 :     # Note that it is faster to read the whole output to a string and then split
302 :     # it than it is to use the array form of the command. Also note that it
303 :     # is faster to use the output as the list of a foreach statement than to
304 :     # put it into an array. The line-by-line form is slowest, but, as noted
305 :     # above, will handle arbitrarily large outputs.
306 :     #
307 :     #-----------------------------------------------------------------------------
308 :     # Command Time (sec)
309 :     #-----------------------------------------------------------------------------
310 :     # my $data = run_gathering_output( 'cat', 'big_file' ); 0.3
311 :     # my @data = split /\n/, run_gathering_output( 'cat', 'big_file' ); 1.4
312 :     # my @data = run_gathering_output( 'cat', 'big_file' ); 1.9
313 :     #
314 :     # foreach ( split /\n/, run_gathering_output( 'cat', 'big_file' ) ) {}; 0.9
315 :     # foreach ( run_gathering_output( 'cat', 'big_file' ) ) {}; 1.5
316 :     # while ( $_ = run_line_by_line( 'cat', 'big_file' ) ) {}; 2.2
317 :     #-----------------------------------------------------------------------------
318 :     #
319 :     # run_line_by_line()
320 :     #
321 :     # while ( $line = SeedAware::run_line_by_line( $cmd, @args ) ) { ... }
322 :     #
323 :     # my $cmd_and_args = [ $cmd, @args ];
324 :     # while ( $line = SeedAware::run_line_by_line( $cmd_and_args ) ) { ... }
325 :     #
326 :     # Run a command, reading output line-by-line. This is similar to an input pipe,
327 :     # but it does not invoke the shell. Note that the argument list must be passed
328 :     # one command line argument per function argument. Subsequent calls with the
329 :     # same command and args return sequential lines. Multiple instances with
330 :     # different comands or args can be interlaced, with the command and args
331 :     # serving as a key to the stream to be read. Thus, the second form can be
332 :     # run in multiple instances by using different array references. For unclear
333 :     # reasons, this version is slower.
334 :     #
335 :     # Close the file handle before end of file:
336 :     #
337 :     # close_line_by_line( $cmd, @args )
338 :     # close_line_by_line( $cmd_and_args )
339 :     #
340 :     # Find out the file handle associated with the command and args:
341 :     #
342 :     # $fh = line_by_line_fh( $cmd, @args )
343 :     # $fh = line_by_line_fh( $cmd_and_args )
344 :     #
345 :     #===============================================================================
346 :    
347 :     sub run_gathering_output
348 :     {
349 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
350 :     return () if ! ( @_ && defined $_[0] );
351 :    
352 :     #
353 :     # Run the command in a safe fork-with-pipe/exec.
354 :     #
355 :     my @cmd_and_args = ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_;
356 :     my $name = join( ' ', @cmd_and_args );
357 : olson 1.4
358 :     if ($have_ipc_run)
359 :     {
360 :     my $out;
361 :     my $ok = IPC::Run::run(\@cmd_and_args, '>', \$out);
362 :     if (wantarray)
363 :     {
364 :     my @out;
365 :     open(my $fh, "<", \$out);
366 :     @out = <$fh>;
367 :     close($fh);
368 :     return @out;
369 :     }
370 :     else
371 :     {
372 :     return $out;
373 :     }
374 :     }
375 :    
376 : golsen 1.1 open( PROC_READ, '-|', @cmd_and_args ) || die "Could not execute '$name': $!\n";
377 :    
378 :     if ( wantarray )
379 :     {
380 :     my @out;
381 :     while( <PROC_READ> ) { push @out, $_ } # Faster than @out = <PROC_READ>
382 : olson 1.3 close( PROC_READ ) or confess "FAILED: '$name' with error return $?";
383 : golsen 1.1 return @out;
384 :     }
385 :     else
386 :     {
387 :     my $out = '';
388 :     my $inc = 1048576;
389 :     my $end = 0;
390 :     my $read;
391 :     while ( $read = read( PROC_READ, $out, $inc, $end ) ) { $end += $read }
392 :     close( PROC_READ ) or die "FAILED: '$name' with error return $?";
393 :     return $out;
394 :     }
395 :     }
396 :    
397 :    
398 :     # Deal with multiple streams
399 :     my %handles;
400 :    
401 :     sub run_line_by_line
402 :     {
403 :     shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
404 :     return () if ! ( @_ && defined $_[0] );
405 :    
406 :     my $key = join( ' ', @_ );
407 :    
408 :     my $fh;
409 :     if ( ! ( $fh = $handles{ $key } ) )
410 :     {
411 :     #
412 :     # Run the command in a safe fork-with-pipe/exec.
413 :     #
414 :     my @cmd_and_args = ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_;
415 :     my $name = join( ' ', @cmd_and_args );
416 :     open( $fh, '-|', @cmd_and_args ) || die "Could not exec '$name':\n$!\n";
417 :     $handles{ $key } = $fh;
418 :     }
419 :    
420 :     my $line = <$fh>;
421 :     if ( ! defined( $line ) )
422 :     {
423 :     delete( $handles{ $key } );
424 :     close( $fh );
425 :     }
426 :    
427 :     $line;
428 :     }
429 :    
430 :     #
431 :     # Provide a method to close the pipe early.
432 :     #
433 :     sub close_line_by_line
434 :     {
435 :     shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
436 :     return undef if ! ( @_ && defined $_[0] );
437 :    
438 :     my $name = join( ' ', @_ );
439 :     my $fh;
440 :     ( $fh = $handles{ $name } ) or return undef;
441 :     delete( $handles{ $name } );
442 :     close( $fh );
443 :     }
444 :    
445 :     #
446 :     # Provide a method to learn the file handle. This could create problems
447 :     # if the caller does something bad. One possible use is simply to see if
448 :     # the pipe exists.
449 :     #
450 :     sub line_by_line_fh
451 :     {
452 :     shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
453 :     return undef if ! ( @_ && defined $_[0] );
454 :     $handles{ join( ' ', @_ ) };
455 :     }
456 :    
457 :    
458 :     #-----------------------------------------------------------------------------
459 :     # Read the entire contents of a file or stream into a string. This command
460 :     # if similar to $string = join( '', <FH> ), but reads the input by blocks.
461 :     #
462 :     # $string = SeedAware::slurp_input( ) # \*STDIN
463 :     # $string = SeedAware::slurp_input( $filename )
464 :     # $string = SeedAware::slurp_input( \*FILEHANDLE )
465 :     #
466 :     #-----------------------------------------------------------------------------
467 :     sub slurp_input
468 :     {
469 :     my $file = shift;
470 :     my ( $fh, $close );
471 :     if ( ref $file eq 'GLOB' )
472 :     {
473 :     $fh = $file;
474 :     }
475 :     elsif ( $file )
476 :     {
477 :     if ( -f $file ) { $file = "<$file" }
478 :     elsif ( $_[0] =~ /^<(.*)$/ && -f $1 ) { } # Explicit read
479 :     else { return undef }
480 :     open $fh, $file or return undef;
481 :     $close = 1;
482 :     }
483 :     else
484 :     {
485 :     $fh = \*STDIN;
486 :     }
487 :    
488 :     my $out = '';
489 :     my $inc = 1048576;
490 :     my $end = 0;
491 :     my $read;
492 :     while ( $read = read( $fh, $out, $inc, $end ) ) { $end += $read }
493 :     close $fh if $close;
494 :    
495 :     $out;
496 :     }
497 :    
498 :    
499 :     #===============================================================================
500 :     # Locate commands in special bin directories
501 :     #
502 :     # $command = SeedAware::executable_for( $command )
503 :     #
504 :     #===============================================================================
505 :     sub executable_for
506 :     {
507 :     my $prog = shift;
508 :    
509 :     return $prog if ! defined($prog) || $prog =~ /\//; # undef, or includes path
510 :    
511 :     if ( $in_SEED )
512 :     {
513 :     foreach my $bin ( $FIG_Config::blastbin, $FIG_Config::ext_bin )
514 :     {
515 :     return "$bin/$prog" if defined $bin && -d $bin && -x "$bin/$prog";
516 :     }
517 :     }
518 :    
519 :     return $prog; # default to $PATH search
520 :     }
521 :    
522 :    
523 :     #===============================================================================
524 :     # Locate the directory for temporary files in a SEED-aware, but not SEED-
525 :     # dependent manner:
526 :     #
527 :     # $tmp = SeedAware::location_of_tmp( \%options )
528 :     #
529 :     #===============================================================================
530 :     sub location_of_tmp
531 :     {
532 :     my $options = ref( $_[0] ) eq 'HASH' ? shift : {};
533 :    
534 : olson 1.3 foreach my $tmp ( $options->{tmp}, $FIG_Config::temp, $ENV{TEMP}, $ENV{TMPDIR}, $ENV{TEMPDIR}, '/tmp', '.' )
535 : golsen 1.1 {
536 :     return $tmp if defined $tmp && -d $tmp && -w $tmp;
537 :     }
538 :    
539 :     return undef;
540 :     }
541 :    
542 :    
543 :     #===============================================================================
544 :     # Locate or create a temporary directory for files in a SEED-aware, but not
545 :     # SEED-dependent manner. The placement of the directory depends on the
546 :     # environment, or can be specified as an option.
547 :     #
548 :     # $tmp_dir = SeedAware::temporary_directory( $name, \%opts )
549 :     # ( $tmp_dir, $save_dir ) = SeedAware::temporary_directory( $name, \%opts )
550 :     # $tmp_dir = SeedAware::temporary_directory( \%opts )
551 :     # ( $tmp_dir, $save_dir ) = SeedAware::temporary_directory( \%opts )
552 :     #
553 :     # If $name is supplied, the directory in "tmp" is to have this name.
554 :     # $save_dir indicates that the directory already existed, and should not be
555 :     # deleted.
556 :     #
557 :     # Options:
558 :     #
559 :     # base => $base # Base string for name of directory
560 :     # name => $name # Name for directory in "tmp"
561 :     # save_dir => $bool # Set $save_dir output (don't delete when done)
562 :     # tmp => $tmp # Directory in which the directory is to be placed
563 :     # tmp_dir => $tmp_dir # Name of the directory including implicit or
564 :     # explict path. This option overrides name.
565 :     #
566 :     # The options { tmp => 'my_home', name => 'my_name' }
567 :     # are equivalent to { tmp_dir => 'my_home/my_name' }
568 :     #
569 :     #===============================================================================
570 :     sub temporary_directory
571 :     {
572 :     my $name = defined( $_[0] ) && ! ref( $_[0] ) ? shift : undef;
573 :     my $options = defined( $_[0] ) && ref( $_[0] ) eq 'HASH' ? shift : {};
574 :    
575 :     my $tmp_dir = $options->{ tmpdir } || $options->{ tmp_dir };
576 :     if ( ! defined $tmp_dir )
577 :     {
578 :     my $tmp = location_of_tmp( $options );
579 :     return ( wantarray ? () : undef ) if ! $tmp;
580 :    
581 :     if ( ! defined $name )
582 :     {
583 :     if ( defined $options->{ name } )
584 :     {
585 :     $name = $options->{ name };
586 :     }
587 :     else
588 :     {
589 :     my $base = $options->{ base } || 'tmp_dir';
590 : golsen 1.2 $name = new_file_name( $base, '', $tmp );
591 : golsen 1.1 }
592 :     }
593 :     $tmp_dir = "$tmp/$name";
594 :     }
595 :    
596 :     my $save_dir = $options->{ savedir } || $options->{ save_dir } || -d $tmp_dir;
597 :    
598 :     if ( ! -d $tmp_dir )
599 :     {
600 :     mkdir $tmp_dir;
601 :     return ( wantarray ? () : undef ) if ! -d $tmp_dir;
602 :     }
603 :    
604 :     # $options->{ tmp_dir } = $tmp_dir;
605 :     # $options->{ save_dir } = $save_dir;
606 :    
607 :     wantarray ? ( $tmp_dir, $save_dir ) : $tmp_dir;
608 :     }
609 :    
610 :    
611 :     #===============================================================================
612 :     # Create a name for a new file or directory that will not clobber an existing
613 :     # one.
614 :     #
615 :     # $file_name = new_file_name( )
616 :     # $file_name = new_file_name( $base_name )
617 :     # $file_name = new_file_name( $base_name, $extention )
618 :     # $file_name = new_file_name( $base_name, $extention, $in_directory )
619 :     #
620 :     # The name is derived by adding an underscore and 12 random digits to a
621 :     # base name (D = temp). The random digits are done in two parts because
622 :     # the coversion to a decimal integer dies when the number gets too big.
623 :     # The repeat period of rand() is >10^12 (on my Mac), so these are not
624 :     # empty digits.
625 :     #===============================================================================
626 :     sub new_file_name
627 :     {
628 :     my ( $base, $ext, $dir ) = @_;
629 :     $base = 'temp' if ! ( defined $base && length $base );
630 :     $ext = '' if ! defined $ext;
631 :     $ext =~ s/^([^.])/.$1/; # Start ext with .
632 : golsen 1.5 $dir = '' if ! defined $dir;
633 :     $dir .= '/' if $dir =~ m/[^\/]$/; # End dir with /
634 : golsen 1.1 while ( 1 )
635 :     {
636 :     my $r = rand( 1e6 );
637 :     my $ir = int( $r );
638 :     my $name = sprintf "%s_%06d%06d%s", $base, $ir, int(1e6*($r-$ir)), $ext;
639 :     return $name if ! -e ( length $dir ? "$dir$name" : $name );
640 :     }
641 :     }
642 :    
643 :    
644 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3