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

Annotation of /FigKernelPackages/SeedAware.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (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 :     # In case we are running in a SEED, pull in the FIG_Config
162 :     #
163 :     our $in_SEED;
164 : olson 1.3
165 : golsen 1.1 BEGIN
166 :     {
167 :     $in_SEED = 0;
168 :     eval { require FIG_Config; $in_SEED = 1 };
169 :     }
170 :    
171 :    
172 : olson 1.3
173 : golsen 1.1 #===============================================================================
174 :     # Commands that run, read from, or write to a process, allowing control over
175 :     # the other input streams, as would normally be handled by a shell.
176 :     #
177 :     # $status = system_with_redirect( \%redirects, @cmd_and_args )
178 :     # $status = system_with_redirect( \%redirects, \@cmd_and_args )
179 :     # $fh = write_to_pipe_with_redirect( \%redirects, @cmd_and_args )
180 :     # $fh = write_to_pipe_with_redirect( \%redirects, \@cmd_and_args )
181 :     # $fh = read_from_pipe_with_redirect( \%redirects, @cmd_and_args )
182 :     # $fh = read_from_pipe_with_redirect( \%redirects, \@cmd_and_args )
183 :     #
184 :     # $status = system_with_redirect( @cmd_and_args, \%redirects )
185 :     # $status = system_with_redirect( \@cmd_and_args, \%redirects )
186 :     # $fh = write_to_pipe_with_redirect( @cmd_and_args, \%redirects )
187 :     # $fh = write_to_pipe_with_redirect( \@cmd_and_args, \%redirects )
188 :     # $fh = read_from_pipe_with_redirect( @cmd_and_args, \%redirects )
189 :     # $fh = read_from_pipe_with_redirect( \@cmd_and_args, \%redirects )
190 :     #
191 :     # Redirects:
192 :     #
193 :     # stdin => $file # Where process should read from
194 :     # stdout => $file # Where process should write to
195 :     # stderr => $file # Where stderr should be sent (/dev/null comes to mind)
196 :     #
197 :     # '>' and '<' are not necessary, but use '>>' for appending to output files.
198 :     #===============================================================================
199 :     sub system_with_redirect
200 :     {
201 :     @_ or return undef;
202 :     my $opts = ( $_[0] && ref $_[0] eq 'HASH' ) ? shift
203 :     : ( $_[-1] && ref $_[-1] eq 'HASH' ) ? pop
204 :     : {};
205 :     @_ && defined $_[0] or return undef;
206 :     my @cmd_and_args = ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_;
207 :    
208 :     if ( $opts->{stdin} ) { open IN0, "<&STDIN"; open STDIN, fixin($opts->{stdin}) }
209 :     if ( $opts->{stdout} ) { open OUT0, ">&STDOUT"; open STDOUT, fixout($opts->{stdout}) }
210 :     if ( $opts->{stderr} ) { open ERR0, ">&STDERR"; open STDERR, fixout($opts->{stderr}) }
211 :    
212 :     my $stat = system( @cmd_and_args );
213 :    
214 :     if ( $opts->{stdin} ) { open STDIN, "<&IN0"; close IN0 }
215 :     if ( $opts->{stdout} ) { open STDOUT, ">&OUT0"; close OUT0 }
216 :     if ( $opts->{stderr} ) { open STDERR, ">&ERR0"; close ERR0 }
217 :    
218 :     $stat;
219 :     }
220 :    
221 :    
222 :     sub write_to_pipe_with_redirect
223 :     {
224 :     @_ or return undef;
225 :     my $opts = ( $_[0] && ref $_[0] eq 'HASH' ) ? shift
226 :     : ( $_[-1] && ref $_[-1] eq 'HASH' ) ? pop
227 :     : {};
228 :     @_ && defined $_[0] or return undef;
229 :     my @cmd_and_args = ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_;
230 :    
231 :     if ( $opts->{stdout} ) { open OUT0, ">&STDOUT"; open STDOUT, fixout($opts->{stdout}) }
232 :     if ( $opts->{stderr} ) { open ERR0, ">&STDERR"; open STDERR, fixout($opts->{stderr}) }
233 :    
234 :     my $okay = open( FH, '|-', @cmd_and_args );
235 :    
236 :     if ( $opts->{stdout} ) { open STDOUT, ">&OUT0"; close OUT0 }
237 :     if ( $opts->{stderr} ) { open STDERR, ">&ERR0"; close ERR0 }
238 :    
239 :     $okay ? \*FH : undef;
240 :     }
241 :    
242 :    
243 :     sub read_from_pipe_with_redirect
244 :     {
245 :     @_ or return undef;
246 :     my $opts = ( $_[0] && ref $_[0] eq 'HASH' ) ? shift
247 :     : ( $_[-1] && ref $_[-1] eq 'HASH' ) ? pop
248 :     : {};
249 :     @_ && defined $_[0] or return undef;
250 :     my @cmd_and_args = ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_;
251 :    
252 :     if ( $opts->{stdin} ) { open IN0, "<&STDIN"; open STDIN, fixin($opts->{stdin}) }
253 :     if ( $opts->{stderr} ) { open ERR0, ">&STDERR"; open STDERR, fixout($opts->{stderr}) }
254 :    
255 :     my $okay = open( FH, '-|', @cmd_and_args );
256 :    
257 :     if ( $opts->{stdin} ) { open STDIN, "<&IN0"; close IN0 }
258 :     if ( $opts->{stderr} ) { open STDERR, ">&ERR0"; close ERR0 }
259 :    
260 :     $okay ? \*FH : undef;
261 :     }
262 :    
263 :     # Format an input file request:
264 :    
265 :     sub fixin { local $_ = shift; /^\+?</ ? $_ : "<$_" }
266 :    
267 :    
268 :     # Format an output file request:
269 :    
270 :     sub fixout { local $_ = shift; /^\+?>/ ? $_ : ">$_" }
271 :    
272 :    
273 :     #===============================================================================
274 :     # Fork a command and read its output without invoking a shell. This is
275 :     # safer than the perl pipe command, which runs the command in a shell.
276 :     # But note that these commands only work for simple commands, not complex
277 :     # pipes (though the user could make a command file that implements any pipe
278 :     # desired).
279 :     #
280 :     # $string = run_gathering_output( $cmd, @args )
281 :     # @lines = run_gathering_output( $cmd, @args )
282 :     #
283 :     # This command is meant of situations in which the expected volume of output
284 :     # will not stress the available memory. For larger volumes of output that
285 :     # can be processed a line at a time, there is the run_line_by_line() function.
286 :     #
287 :     # Note that it is faster to read the whole output to a string and then split
288 :     # it than it is to use the array form of the command. Also note that it
289 :     # is faster to use the output as the list of a foreach statement than to
290 :     # put it into an array. The line-by-line form is slowest, but, as noted
291 :     # above, will handle arbitrarily large outputs.
292 :     #
293 :     #-----------------------------------------------------------------------------
294 :     # Command Time (sec)
295 :     #-----------------------------------------------------------------------------
296 :     # my $data = run_gathering_output( 'cat', 'big_file' ); 0.3
297 :     # my @data = split /\n/, run_gathering_output( 'cat', 'big_file' ); 1.4
298 :     # my @data = run_gathering_output( 'cat', 'big_file' ); 1.9
299 :     #
300 :     # foreach ( split /\n/, run_gathering_output( 'cat', 'big_file' ) ) {}; 0.9
301 :     # foreach ( run_gathering_output( 'cat', 'big_file' ) ) {}; 1.5
302 :     # while ( $_ = run_line_by_line( 'cat', 'big_file' ) ) {}; 2.2
303 :     #-----------------------------------------------------------------------------
304 :     #
305 :     # run_line_by_line()
306 :     #
307 :     # while ( $line = SeedAware::run_line_by_line( $cmd, @args ) ) { ... }
308 :     #
309 :     # my $cmd_and_args = [ $cmd, @args ];
310 :     # while ( $line = SeedAware::run_line_by_line( $cmd_and_args ) ) { ... }
311 :     #
312 :     # Run a command, reading output line-by-line. This is similar to an input pipe,
313 :     # but it does not invoke the shell. Note that the argument list must be passed
314 :     # one command line argument per function argument. Subsequent calls with the
315 :     # same command and args return sequential lines. Multiple instances with
316 :     # different comands or args can be interlaced, with the command and args
317 :     # serving as a key to the stream to be read. Thus, the second form can be
318 :     # run in multiple instances by using different array references. For unclear
319 :     # reasons, this version is slower.
320 :     #
321 :     # Close the file handle before end of file:
322 :     #
323 :     # close_line_by_line( $cmd, @args )
324 :     # close_line_by_line( $cmd_and_args )
325 :     #
326 :     # Find out the file handle associated with the command and args:
327 :     #
328 :     # $fh = line_by_line_fh( $cmd, @args )
329 :     # $fh = line_by_line_fh( $cmd_and_args )
330 :     #
331 :     #===============================================================================
332 :    
333 :     sub run_gathering_output
334 :     {
335 :     shift if UNIVERSAL::isa($_[0],__PACKAGE__);
336 :     return () if ! ( @_ && defined $_[0] );
337 :    
338 :     #
339 :     # Run the command in a safe fork-with-pipe/exec.
340 :     #
341 :     my @cmd_and_args = ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_;
342 :     my $name = join( ' ', @cmd_and_args );
343 :     open( PROC_READ, '-|', @cmd_and_args ) || die "Could not execute '$name': $!\n";
344 :    
345 :     if ( wantarray )
346 :     {
347 :     my @out;
348 :     while( <PROC_READ> ) { push @out, $_ } # Faster than @out = <PROC_READ>
349 : olson 1.3 close( PROC_READ ) or confess "FAILED: '$name' with error return $?";
350 : golsen 1.1 return @out;
351 :     }
352 :     else
353 :     {
354 :     my $out = '';
355 :     my $inc = 1048576;
356 :     my $end = 0;
357 :     my $read;
358 :     while ( $read = read( PROC_READ, $out, $inc, $end ) ) { $end += $read }
359 :     close( PROC_READ ) or die "FAILED: '$name' with error return $?";
360 :     return $out;
361 :     }
362 :     }
363 :    
364 :    
365 :     # Deal with multiple streams
366 :     my %handles;
367 :    
368 :     sub run_line_by_line
369 :     {
370 :     shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
371 :     return () if ! ( @_ && defined $_[0] );
372 :    
373 :     my $key = join( ' ', @_ );
374 :    
375 :     my $fh;
376 :     if ( ! ( $fh = $handles{ $key } ) )
377 :     {
378 :     #
379 :     # Run the command in a safe fork-with-pipe/exec.
380 :     #
381 :     my @cmd_and_args = ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_;
382 :     my $name = join( ' ', @cmd_and_args );
383 :     open( $fh, '-|', @cmd_and_args ) || die "Could not exec '$name':\n$!\n";
384 :     $handles{ $key } = $fh;
385 :     }
386 :    
387 :     my $line = <$fh>;
388 :     if ( ! defined( $line ) )
389 :     {
390 :     delete( $handles{ $key } );
391 :     close( $fh );
392 :     }
393 :    
394 :     $line;
395 :     }
396 :    
397 :     #
398 :     # Provide a method to close the pipe early.
399 :     #
400 :     sub close_line_by_line
401 :     {
402 :     shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
403 :     return undef if ! ( @_ && defined $_[0] );
404 :    
405 :     my $name = join( ' ', @_ );
406 :     my $fh;
407 :     ( $fh = $handles{ $name } ) or return undef;
408 :     delete( $handles{ $name } );
409 :     close( $fh );
410 :     }
411 :    
412 :     #
413 :     # Provide a method to learn the file handle. This could create problems
414 :     # if the caller does something bad. One possible use is simply to see if
415 :     # the pipe exists.
416 :     #
417 :     sub line_by_line_fh
418 :     {
419 :     shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
420 :     return undef if ! ( @_ && defined $_[0] );
421 :     $handles{ join( ' ', @_ ) };
422 :     }
423 :    
424 :    
425 :     #-----------------------------------------------------------------------------
426 :     # Read the entire contents of a file or stream into a string. This command
427 :     # if similar to $string = join( '', <FH> ), but reads the input by blocks.
428 :     #
429 :     # $string = SeedAware::slurp_input( ) # \*STDIN
430 :     # $string = SeedAware::slurp_input( $filename )
431 :     # $string = SeedAware::slurp_input( \*FILEHANDLE )
432 :     #
433 :     #-----------------------------------------------------------------------------
434 :     sub slurp_input
435 :     {
436 :     my $file = shift;
437 :     my ( $fh, $close );
438 :     if ( ref $file eq 'GLOB' )
439 :     {
440 :     $fh = $file;
441 :     }
442 :     elsif ( $file )
443 :     {
444 :     if ( -f $file ) { $file = "<$file" }
445 :     elsif ( $_[0] =~ /^<(.*)$/ && -f $1 ) { } # Explicit read
446 :     else { return undef }
447 :     open $fh, $file or return undef;
448 :     $close = 1;
449 :     }
450 :     else
451 :     {
452 :     $fh = \*STDIN;
453 :     }
454 :    
455 :     my $out = '';
456 :     my $inc = 1048576;
457 :     my $end = 0;
458 :     my $read;
459 :     while ( $read = read( $fh, $out, $inc, $end ) ) { $end += $read }
460 :     close $fh if $close;
461 :    
462 :     $out;
463 :     }
464 :    
465 :    
466 :     #===============================================================================
467 :     # Locate commands in special bin directories
468 :     #
469 :     # $command = SeedAware::executable_for( $command )
470 :     #
471 :     #===============================================================================
472 :     sub executable_for
473 :     {
474 :     my $prog = shift;
475 :    
476 :     return $prog if ! defined($prog) || $prog =~ /\//; # undef, or includes path
477 :    
478 :     if ( $in_SEED )
479 :     {
480 :     foreach my $bin ( $FIG_Config::blastbin, $FIG_Config::ext_bin )
481 :     {
482 :     return "$bin/$prog" if defined $bin && -d $bin && -x "$bin/$prog";
483 :     }
484 :     }
485 :    
486 :     return $prog; # default to $PATH search
487 :     }
488 :    
489 :    
490 :     #===============================================================================
491 :     # Locate the directory for temporary files in a SEED-aware, but not SEED-
492 :     # dependent manner:
493 :     #
494 :     # $tmp = SeedAware::location_of_tmp( \%options )
495 :     #
496 :     #===============================================================================
497 :     sub location_of_tmp
498 :     {
499 :     my $options = ref( $_[0] ) eq 'HASH' ? shift : {};
500 :    
501 : olson 1.3 foreach my $tmp ( $options->{tmp}, $FIG_Config::temp, $ENV{TEMP}, $ENV{TMPDIR}, $ENV{TEMPDIR}, '/tmp', '.' )
502 : golsen 1.1 {
503 :     return $tmp if defined $tmp && -d $tmp && -w $tmp;
504 :     }
505 :    
506 :     return undef;
507 :     }
508 :    
509 :    
510 :     #===============================================================================
511 :     # Locate or create a temporary directory for files in a SEED-aware, but not
512 :     # SEED-dependent manner. The placement of the directory depends on the
513 :     # environment, or can be specified as an option.
514 :     #
515 :     # $tmp_dir = SeedAware::temporary_directory( $name, \%opts )
516 :     # ( $tmp_dir, $save_dir ) = SeedAware::temporary_directory( $name, \%opts )
517 :     # $tmp_dir = SeedAware::temporary_directory( \%opts )
518 :     # ( $tmp_dir, $save_dir ) = SeedAware::temporary_directory( \%opts )
519 :     #
520 :     # If $name is supplied, the directory in "tmp" is to have this name.
521 :     # $save_dir indicates that the directory already existed, and should not be
522 :     # deleted.
523 :     #
524 :     # Options:
525 :     #
526 :     # base => $base # Base string for name of directory
527 :     # name => $name # Name for directory in "tmp"
528 :     # save_dir => $bool # Set $save_dir output (don't delete when done)
529 :     # tmp => $tmp # Directory in which the directory is to be placed
530 :     # tmp_dir => $tmp_dir # Name of the directory including implicit or
531 :     # explict path. This option overrides name.
532 :     #
533 :     # The options { tmp => 'my_home', name => 'my_name' }
534 :     # are equivalent to { tmp_dir => 'my_home/my_name' }
535 :     #
536 :     #===============================================================================
537 :     sub temporary_directory
538 :     {
539 :     my $name = defined( $_[0] ) && ! ref( $_[0] ) ? shift : undef;
540 :     my $options = defined( $_[0] ) && ref( $_[0] ) eq 'HASH' ? shift : {};
541 :    
542 :     my $tmp_dir = $options->{ tmpdir } || $options->{ tmp_dir };
543 :     if ( ! defined $tmp_dir )
544 :     {
545 :     my $tmp = location_of_tmp( $options );
546 :     return ( wantarray ? () : undef ) if ! $tmp;
547 :    
548 :     if ( ! defined $name )
549 :     {
550 :     if ( defined $options->{ name } )
551 :     {
552 :     $name = $options->{ name };
553 :     }
554 :     else
555 :     {
556 :     my $base = $options->{ base } || 'tmp_dir';
557 : golsen 1.2 $name = new_file_name( $base, '', $tmp );
558 : golsen 1.1 }
559 :     }
560 :     $tmp_dir = "$tmp/$name";
561 :     }
562 :    
563 :     my $save_dir = $options->{ savedir } || $options->{ save_dir } || -d $tmp_dir;
564 :    
565 :     if ( ! -d $tmp_dir )
566 :     {
567 :     mkdir $tmp_dir;
568 :     return ( wantarray ? () : undef ) if ! -d $tmp_dir;
569 :     }
570 :    
571 :     # $options->{ tmp_dir } = $tmp_dir;
572 :     # $options->{ save_dir } = $save_dir;
573 :    
574 :     wantarray ? ( $tmp_dir, $save_dir ) : $tmp_dir;
575 :     }
576 :    
577 :    
578 :     #===============================================================================
579 :     # Create a name for a new file or directory that will not clobber an existing
580 :     # one.
581 :     #
582 :     # $file_name = new_file_name( )
583 :     # $file_name = new_file_name( $base_name )
584 :     # $file_name = new_file_name( $base_name, $extention )
585 :     # $file_name = new_file_name( $base_name, $extention, $in_directory )
586 :     #
587 :     # The name is derived by adding an underscore and 12 random digits to a
588 :     # base name (D = temp). The random digits are done in two parts because
589 :     # the coversion to a decimal integer dies when the number gets too big.
590 :     # The repeat period of rand() is >10^12 (on my Mac), so these are not
591 :     # empty digits.
592 :     #===============================================================================
593 :     sub new_file_name
594 :     {
595 :     my ( $base, $ext, $dir ) = @_;
596 :     $base = 'temp' if ! ( defined $base && length $base );
597 :     $ext = '' if ! defined $ext;
598 :     $ext =~ s/^([^.])/.$1/; # Start ext with .
599 :     $dir = '' if ! defined $dir;
600 :     $dir =~ s.([/])$.$1/.; # End dir with /
601 :     while ( 1 )
602 :     {
603 :     my $r = rand( 1e6 );
604 :     my $ir = int( $r );
605 :     my $name = sprintf "%s_%06d%06d%s", $base, $ir, int(1e6*($r-$ir)), $ext;
606 :     return $name if ! -e ( length $dir ? "$dir$name" : $name );
607 :     }
608 :     }
609 :    
610 :    
611 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3