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

Annotation of /FigKernelPackages/SeedAware.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3