|
0
|
1 # $Id: IO.pm,v 1.37.2.3 2003/06/28 21:57:04 jason Exp $
|
|
|
2 #
|
|
|
3 # BioPerl module for Bio::Root::IO
|
|
|
4 #
|
|
|
5 # Cared for by Hilmar Lapp <hlapp@gmx.net>
|
|
|
6 #
|
|
|
7 # Copyright Hilmar Lapp
|
|
|
8 #
|
|
|
9 # You may distribute this module under the same terms as perl itself
|
|
|
10
|
|
|
11 # POD documentation - main docs before the code
|
|
|
12
|
|
|
13 =head1 NAME
|
|
|
14
|
|
|
15 Bio::Root::IO - module providing several methods often needed when dealing with file IO
|
|
|
16
|
|
|
17 =head1 SYNOPSIS
|
|
|
18
|
|
|
19 # utilize stream I/O in your module
|
|
|
20 $self->{'io'} = Bio::Root::IO->new(-file => "myfile");
|
|
|
21 $self->{'io'}->_print("some stuff");
|
|
|
22 $line = $self->{'io'}->_readline();
|
|
|
23 $self->{'io'}->_pushback($line);
|
|
|
24 $self->{'io'}->close();
|
|
|
25
|
|
|
26 # obtain platform-compatible filenames
|
|
|
27 $path = Bio::Root::IO->catfile($dir, $subdir, $filename);
|
|
|
28 # obtain a temporary file (created in $TEMPDIR)
|
|
|
29 ($handle) = $io->tempfile();
|
|
|
30
|
|
|
31 =head1 DESCRIPTION
|
|
|
32
|
|
|
33 This module provides methods that will usually be needed for any sort
|
|
|
34 of file- or stream-related input/output, e.g., keeping track of a file
|
|
|
35 handle, transient printing and reading from the file handle, a close
|
|
|
36 method, automatically closing the handle on garbage collection, etc.
|
|
|
37
|
|
|
38 To use this for your own code you will either want to inherit from
|
|
|
39 this module, or instantiate an object for every file or stream you are
|
|
|
40 dealing with. In the first case this module will most likely not be
|
|
|
41 the first class off which your class inherits; therefore you need to
|
|
|
42 call _initialize_io() with the named parameters in order to set file
|
|
|
43 handle, open file, etc automatically.
|
|
|
44
|
|
|
45 Most methods start with an underscore, indicating they are private. In
|
|
|
46 OO speak, they are not private but protected, that is, use them in
|
|
|
47 your module code, but a client code of your module will usually not
|
|
|
48 want to call them (except those not starting with an underscore).
|
|
|
49
|
|
|
50 In addition this module contains a couple of convenience methods for
|
|
|
51 cross-platform safe tempfile creation and similar tasks. There are
|
|
|
52 some CPAN modules related that may not be available on all
|
|
|
53 platforms. At present, File::Spec and File::Temp are attempted. This
|
|
|
54 module defines $PATHSEP, $TEMPDIR, and $ROOTDIR, which will always be set,
|
|
|
55 and $OPENFLAGS, which will be set if either of File::Spec or File::Temp fails.
|
|
|
56
|
|
|
57 The -noclose boolean (accessed via the noclose method) prevents a
|
|
|
58 filehandle from being closed when the IO object is cleaned up. This
|
|
|
59 is special behavior when a object like a parser might share a
|
|
|
60 filehandle with an object like an indexer where it is not proper to
|
|
|
61 close the filehandle as it will continue to be reused until the end of the
|
|
|
62 stream is reached. In general you won't want to play with this flag.
|
|
|
63
|
|
|
64 =head1 FEEDBACK
|
|
|
65
|
|
|
66 =head2 Mailing Lists
|
|
|
67
|
|
|
68 User feedback is an integral part of the evolution of this
|
|
|
69 and other Bioperl modules. Send your comments and suggestions preferably
|
|
|
70 to one of the Bioperl mailing lists.
|
|
|
71 Your participation is much appreciated.
|
|
|
72
|
|
|
73 bioperl-l@bioperl.org - General discussion
|
|
|
74 http://bio.perl.org/MailList.html - About the mailing lists
|
|
|
75
|
|
|
76 =head2 Reporting Bugs
|
|
|
77
|
|
|
78 Report bugs to the Bioperl bug tracking system to help us keep track
|
|
|
79 the bugs and their resolution.
|
|
|
80 Bug reports can be submitted via email or the web:
|
|
|
81
|
|
|
82 bioperl-bugs@bio.perl.org
|
|
|
83 http://bugzilla.bioperl.org/
|
|
|
84
|
|
|
85 =head1 AUTHOR - Hilmar Lapp
|
|
|
86
|
|
|
87 Email hlapp@gmx.net
|
|
|
88
|
|
|
89 Describe contact details here
|
|
|
90
|
|
|
91 =head1 APPENDIX
|
|
|
92
|
|
|
93 The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _
|
|
|
94
|
|
|
95 =cut
|
|
|
96
|
|
|
97
|
|
|
98 # Let the code begin...
|
|
|
99
|
|
|
100
|
|
|
101 package Bio::Root::IO;
|
|
|
102 use vars qw(@ISA $FILESPECLOADED $FILETEMPLOADED $FILEPATHLOADED
|
|
|
103 $TEMPDIR $PATHSEP $ROOTDIR $OPENFLAGS $VERBOSE);
|
|
|
104 use strict;
|
|
|
105
|
|
|
106 use Symbol;
|
|
|
107 use POSIX qw(dup);
|
|
|
108 use IO::Handle;
|
|
|
109 use Bio::Root::Root;
|
|
|
110
|
|
|
111 @ISA = qw(Bio::Root::Root);
|
|
|
112
|
|
|
113 my $TEMPCOUNTER;
|
|
|
114 my $HAS_WIN32 = 0;
|
|
|
115
|
|
|
116 BEGIN {
|
|
|
117 $TEMPCOUNTER = 0;
|
|
|
118 $FILESPECLOADED = 0;
|
|
|
119 $FILETEMPLOADED = 0;
|
|
|
120 $FILEPATHLOADED = 0;
|
|
|
121 $VERBOSE = 1;
|
|
|
122
|
|
|
123 # try to load those modules that may cause trouble on some systems
|
|
|
124 eval {
|
|
|
125 require File::Path;
|
|
|
126 $FILEPATHLOADED = 1;
|
|
|
127 };
|
|
|
128 if( $@ ) {
|
|
|
129 print STDERR "Cannot load File::Path: $@" if( $VERBOSE > 0 );
|
|
|
130 # do nothing
|
|
|
131 }
|
|
|
132
|
|
|
133
|
|
|
134 # If on Win32, attempt to find Win32 package
|
|
|
135
|
|
|
136 if($^O =~ /mswin/i) {
|
|
|
137 eval {
|
|
|
138 require Win32;
|
|
|
139 $HAS_WIN32 = 1;
|
|
|
140 };
|
|
|
141 }
|
|
|
142
|
|
|
143 # Try to provide a path separator. Why doesn't File::Spec export this,
|
|
|
144 # or did I miss it?
|
|
|
145 if($^O =~ /mswin/i) {
|
|
|
146 $PATHSEP = "\\";
|
|
|
147 } elsif($^O =~ /macos/i) {
|
|
|
148 $PATHSEP = ":";
|
|
|
149 } else { # unix
|
|
|
150 $PATHSEP = "/";
|
|
|
151 }
|
|
|
152 eval {
|
|
|
153 require File::Spec;
|
|
|
154 $FILESPECLOADED = 1;
|
|
|
155 $TEMPDIR = File::Spec->tmpdir();
|
|
|
156 $ROOTDIR = File::Spec->rootdir();
|
|
|
157 require File::Temp; # tempfile creation
|
|
|
158 $FILETEMPLOADED = 1;
|
|
|
159 };
|
|
|
160 if( $@ ) {
|
|
|
161 if(! defined($TEMPDIR)) { # File::Spec failed
|
|
|
162 # determine tempdir
|
|
|
163 if (defined $ENV{'TEMPDIR'} && -d $ENV{'TEMPDIR'} ) {
|
|
|
164 $TEMPDIR = $ENV{'TEMPDIR'};
|
|
|
165 } elsif( defined $ENV{'TMPDIR'} && -d $ENV{'TMPDIR'} ) {
|
|
|
166 $TEMPDIR = $ENV{'TMPDIR'};
|
|
|
167 }
|
|
|
168 if($^O =~ /mswin/i) {
|
|
|
169 $TEMPDIR = 'C:\TEMP' unless $TEMPDIR;
|
|
|
170 $ROOTDIR = 'C:';
|
|
|
171 } elsif($^O =~ /macos/i) {
|
|
|
172 $TEMPDIR = "" unless $TEMPDIR; # what is a reasonable default on Macs?
|
|
|
173 $ROOTDIR = ""; # what is reasonable??
|
|
|
174 } else { # unix
|
|
|
175 $TEMPDIR = "/tmp" unless $TEMPDIR;
|
|
|
176 $ROOTDIR = "/";
|
|
|
177 }
|
|
|
178 if (!( -d $TEMPDIR && -w $TEMPDIR )) {
|
|
|
179 $TEMPDIR = '.'; # last resort
|
|
|
180 }
|
|
|
181 }
|
|
|
182 # File::Temp failed (alone, or File::Spec already failed)
|
|
|
183 #
|
|
|
184 # determine open flags for tempfile creation -- we'll have to do this
|
|
|
185 # ourselves
|
|
|
186 use Fcntl;
|
|
|
187 use Symbol;
|
|
|
188 $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR;
|
|
|
189 for my $oflag (qw/FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT TEMPORARY/){
|
|
|
190 my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
|
|
|
191 no strict 'refs';
|
|
|
192 $OPENFLAGS |= $bit if eval { $bit = &$func(); 1 };
|
|
|
193 }
|
|
|
194 }
|
|
|
195 }
|
|
|
196
|
|
|
197 =head2 new
|
|
|
198
|
|
|
199 Title : new
|
|
|
200 Usage :
|
|
|
201 Function: Overridden here to automatically call _initialize_io().
|
|
|
202 Example :
|
|
|
203 Returns : new instance of this class
|
|
|
204 Args : named parameters
|
|
|
205
|
|
|
206
|
|
|
207 =cut
|
|
|
208
|
|
|
209 sub new {
|
|
|
210 my ($caller, @args) = @_;
|
|
|
211 my $self = $caller->SUPER::new(@args);
|
|
|
212
|
|
|
213 $self->_initialize_io(@args);
|
|
|
214 return $self;
|
|
|
215 }
|
|
|
216
|
|
|
217 =head2 _initialize_io
|
|
|
218
|
|
|
219 Title : initialize_io
|
|
|
220 Usage : $self->_initialize_io(@params);
|
|
|
221 Function: Initializes filehandle and other properties from the parameters.
|
|
|
222
|
|
|
223 Currently recognizes the following named parameters:
|
|
|
224 -file name of file to open
|
|
|
225 -input name of file, or GLOB, or IO::Handle object
|
|
|
226 -fh file handle (mutually exclusive with -file)
|
|
|
227 -flush boolean flag to autoflush after each write
|
|
|
228 -noclose boolean flag, when set to true will not close a
|
|
|
229 filehandle (must explictly call close($io->_fh)
|
|
|
230 Returns : TRUE
|
|
|
231 Args : named parameters
|
|
|
232
|
|
|
233
|
|
|
234 =cut
|
|
|
235
|
|
|
236 sub _initialize_io {
|
|
|
237 my($self, @args) = @_;
|
|
|
238
|
|
|
239 $self->_register_for_cleanup(\&_io_cleanup);
|
|
|
240
|
|
|
241 my ($input, $noclose, $file, $fh, $flush) = $self->_rearrange([qw(INPUT
|
|
|
242 NOCLOSE
|
|
|
243 FILE FH
|
|
|
244 FLUSH)], @args);
|
|
|
245
|
|
|
246 delete $self->{'_readbuffer'};
|
|
|
247 delete $self->{'_filehandle'};
|
|
|
248 $self->noclose( $noclose) if defined $noclose;
|
|
|
249 # determine whether the input is a file(name) or a stream
|
|
|
250 if($input) {
|
|
|
251 if(ref(\$input) eq "SCALAR") {
|
|
|
252 # we assume that a scalar is a filename
|
|
|
253 if($file && ($file ne $input)) {
|
|
|
254 $self->throw("input file given twice: $file and $input disagree");
|
|
|
255 }
|
|
|
256 $file = $input;
|
|
|
257 } elsif(ref($input) &&
|
|
|
258 ((ref($input) eq "GLOB") || $input->isa('IO::Handle'))) {
|
|
|
259 # input is a stream
|
|
|
260 $fh = $input;
|
|
|
261 } else {
|
|
|
262 # let's be strict for now
|
|
|
263 $self->throw("unable to determine type of input $input: ".
|
|
|
264 "not string and not GLOB");
|
|
|
265 }
|
|
|
266 }
|
|
|
267 if(defined($file) && defined($fh)) {
|
|
|
268 $self->throw("Providing both a file and a filehandle for reading - only one please!");
|
|
|
269 }
|
|
|
270
|
|
|
271 if(defined($file) && ($file ne '')) {
|
|
|
272 $fh = Symbol::gensym();
|
|
|
273 open ($fh,$file) ||
|
|
|
274 $self->throw("Could not open $file: $!");
|
|
|
275 $self->file($file);
|
|
|
276 }
|
|
|
277 $self->_fh($fh) if $fh; # if not provided, defaults to STDIN and STDOUT
|
|
|
278
|
|
|
279 $self->_flush_on_write(defined $flush ? $flush : 1);
|
|
|
280
|
|
|
281 return 1;
|
|
|
282 }
|
|
|
283
|
|
|
284 =head2 _fh
|
|
|
285
|
|
|
286 Title : _fh
|
|
|
287 Usage : $obj->_fh($newval)
|
|
|
288 Function: Get/set the file handle for the stream encapsulated.
|
|
|
289 Example :
|
|
|
290 Returns : value of _filehandle
|
|
|
291 Args : newvalue (optional)
|
|
|
292
|
|
|
293 =cut
|
|
|
294
|
|
|
295 sub _fh {
|
|
|
296 my ($obj, $value) = @_;
|
|
|
297 if ( defined $value) {
|
|
|
298 $obj->{'_filehandle'} = $value;
|
|
|
299 }
|
|
|
300 return $obj->{'_filehandle'};
|
|
|
301 }
|
|
|
302
|
|
|
303 =head2 mode
|
|
|
304
|
|
|
305 Title : mode
|
|
|
306 Usage : $obj->mode()
|
|
|
307 Function:
|
|
|
308 Example :
|
|
|
309 Returns : mode of filehandle:
|
|
|
310 'r' for readable
|
|
|
311 'w' for writeable
|
|
|
312 '?' if mode could not be determined
|
|
|
313 Args : -force (optional), see notes.
|
|
|
314 Notes : once mode() has been called, the filehandle's mode is cached
|
|
|
315 for further calls to mode(). to override this behavior so
|
|
|
316 that mode() re-checks the filehandle's mode, call with arg
|
|
|
317 -force
|
|
|
318
|
|
|
319 =cut
|
|
|
320
|
|
|
321 sub mode {
|
|
|
322 my ($obj, @arg) = @_;
|
|
|
323 my %param = @arg;
|
|
|
324 return $obj->{'_mode'} if defined $obj->{'_mode'} and !$param{-force};
|
|
|
325
|
|
|
326 print STDERR "testing mode... " if $obj->verbose;
|
|
|
327
|
|
|
328 # we need to dup() the original filehandle because
|
|
|
329 # doing fdopen() calls on an already open handle causes
|
|
|
330 # the handle to go stale. is this going to work for non-unix
|
|
|
331 # filehandles? -allen
|
|
|
332
|
|
|
333 my $fh = Symbol::gensym();
|
|
|
334
|
|
|
335 my $iotest = new IO::Handle;
|
|
|
336
|
|
|
337 #test for a readable filehandle;
|
|
|
338 $iotest->fdopen( dup(fileno($obj->_fh)) , 'r' );
|
|
|
339 if($iotest->error == 0){
|
|
|
340
|
|
|
341 # note the hack here, we actually have to try to read the line
|
|
|
342 # and if we get something, pushback() it into the readbuffer.
|
|
|
343 # this is because solaris and windows xp (others?) don't set
|
|
|
344 # IO::Handle::error. for non-linux the r/w testing is done
|
|
|
345 # inside this read-test, instead of the write test below. ugh.
|
|
|
346
|
|
|
347 if($^O eq 'linux'){
|
|
|
348 $obj->{'_mode'} = 'r';
|
|
|
349 my $line = $iotest->getline;
|
|
|
350 $obj->_pushback($line) if defined $line;
|
|
|
351 $obj->{'_mode'} = defined $line ? 'r' : 'w';
|
|
|
352 return $obj->{'_mode'};
|
|
|
353 } else {
|
|
|
354 my $line = $iotest->getline;
|
|
|
355 $obj->_pushback($line) if defined $line;
|
|
|
356 $obj->{'_mode'} = defined $line ? 'r' : 'w';
|
|
|
357 return $obj->{'_mode'};
|
|
|
358 }
|
|
|
359 }
|
|
|
360 $iotest->clearerr;
|
|
|
361
|
|
|
362 #test for a writeable filehandle;
|
|
|
363 $iotest->fdopen( dup(fileno($obj->_fh)) , 'w' );
|
|
|
364 if($iotest->error == 0){
|
|
|
365 $obj->{'_mode'} = 'w';
|
|
|
366 # return $obj->{'_mode'};
|
|
|
367 }
|
|
|
368
|
|
|
369 #wtf type of filehandle is this?
|
|
|
370 # $obj->{'_mode'} = '?';
|
|
|
371 return $obj->{'_mode'};
|
|
|
372 }
|
|
|
373
|
|
|
374 =head2 file
|
|
|
375
|
|
|
376 Title : file
|
|
|
377 Usage : $obj->file($newval)
|
|
|
378 Function: Get/set the filename, if one has been designated.
|
|
|
379 Example :
|
|
|
380 Returns : value of file
|
|
|
381 Args : newvalue (optional)
|
|
|
382
|
|
|
383
|
|
|
384 =cut
|
|
|
385
|
|
|
386 sub file {
|
|
|
387 my ($obj, $value) = @_;
|
|
|
388 if ( defined $value) {
|
|
|
389 $obj->{'_file'} = $value;
|
|
|
390 }
|
|
|
391 return $obj->{'_file'};
|
|
|
392 }
|
|
|
393
|
|
|
394 =head2 _print
|
|
|
395
|
|
|
396 Title : _print
|
|
|
397 Usage : $obj->_print(@lines)
|
|
|
398 Function:
|
|
|
399 Example :
|
|
|
400 Returns : writes output
|
|
|
401
|
|
|
402 =cut
|
|
|
403
|
|
|
404 sub _print {
|
|
|
405 my $self = shift;
|
|
|
406 my $fh = $self->_fh() || \*STDOUT;
|
|
|
407 print $fh @_;
|
|
|
408 }
|
|
|
409
|
|
|
410 =head2 _readline
|
|
|
411
|
|
|
412 Title : _readline
|
|
|
413 Usage : $obj->_readline(%args)
|
|
|
414 Function: Reads a line of input.
|
|
|
415
|
|
|
416 Note that this method implicitely uses the value of $/ that is
|
|
|
417 in effect when called.
|
|
|
418
|
|
|
419 Note also that the current implementation does not handle pushed
|
|
|
420 back input correctly unless the pushed back input ends with the
|
|
|
421 value of $/.
|
|
|
422
|
|
|
423 Example :
|
|
|
424 Args : Accepts a hash of arguments, currently only -raw is recognized
|
|
|
425 passing (-raw => 1) prevents \r\n sequences from being changed
|
|
|
426 to \n. The default value of -raw is undef, allowing \r\n to be
|
|
|
427 converted to \n.
|
|
|
428 Returns :
|
|
|
429
|
|
|
430 =cut
|
|
|
431
|
|
|
432 sub _readline {
|
|
|
433 my $self = shift;
|
|
|
434 my %param =@_;
|
|
|
435 my $fh = $self->_fh || \*ARGV;
|
|
|
436 my $line;
|
|
|
437
|
|
|
438 # if the buffer been filled by _pushback then return the buffer
|
|
|
439 # contents, rather than read from the filehandle
|
|
|
440 $line = shift @{$self->{'_readbuffer'}} || <$fh>;
|
|
|
441
|
|
|
442 #don't strip line endings if -raw is specified
|
|
|
443 $line =~ s/\r\n/\n/g if( (!$param{-raw}) && (defined $line) );
|
|
|
444
|
|
|
445 return $line;
|
|
|
446 }
|
|
|
447
|
|
|
448 =head2 _pushback
|
|
|
449
|
|
|
450 Title : _pushback
|
|
|
451 Usage : $obj->_pushback($newvalue)
|
|
|
452 Function: puts a line previously read with _readline back into a buffer.
|
|
|
453 buffer can hold as many lines as system memory permits.
|
|
|
454 Example :
|
|
|
455 Returns :
|
|
|
456 Args : newvalue
|
|
|
457
|
|
|
458 =cut
|
|
|
459
|
|
|
460 sub _pushback {
|
|
|
461 my ($obj, $value) = @_;
|
|
|
462
|
|
|
463 $obj->{'_readbuffer'} ||= [];
|
|
|
464 push @{$obj->{'_readbuffer'}}, $value;
|
|
|
465 }
|
|
|
466
|
|
|
467 =head2 close
|
|
|
468
|
|
|
469 Title : close
|
|
|
470 Usage : $io->close()
|
|
|
471 Function: Closes the file handle associated with this IO instance.
|
|
|
472 Will not close the FH if -noclose is specified
|
|
|
473 Returns : none
|
|
|
474 Args : none
|
|
|
475
|
|
|
476 =cut
|
|
|
477
|
|
|
478 sub close {
|
|
|
479 my ($self) = @_;
|
|
|
480 return if $self->noclose; # don't close if we explictly asked not to
|
|
|
481 if( defined $self->{'_filehandle'} ) {
|
|
|
482 $self->flush;
|
|
|
483 return if( \*STDOUT == $self->_fh ||
|
|
|
484 \*STDERR == $self->_fh ||
|
|
|
485 \*STDIN == $self->_fh
|
|
|
486 ); # don't close STDOUT fh
|
|
|
487 if( ! ref($self->{'_filehandle'}) ||
|
|
|
488 ! $self->{'_filehandle'}->isa('IO::String') ) {
|
|
|
489 close($self->{'_filehandle'});
|
|
|
490 }
|
|
|
491 }
|
|
|
492 $self->{'_filehandle'} = undef;
|
|
|
493 delete $self->{'_readbuffer'};
|
|
|
494 }
|
|
|
495
|
|
|
496
|
|
|
497 =head2 flush
|
|
|
498
|
|
|
499 Title : flush
|
|
|
500 Usage : $io->flush()
|
|
|
501 Function: Flushes the filehandle
|
|
|
502 Returns : none
|
|
|
503 Args : none
|
|
|
504
|
|
|
505 =cut
|
|
|
506
|
|
|
507 sub flush {
|
|
|
508 my ($self) = shift;
|
|
|
509
|
|
|
510 if( !defined $self->{'_filehandle'} ) {
|
|
|
511 $self->throw("Attempting to call flush but no filehandle active");
|
|
|
512 }
|
|
|
513
|
|
|
514 if( ref($self->{'_filehandle'}) =~ /GLOB/ ) {
|
|
|
515 my $oldh = select($self->{'_filehandle'});
|
|
|
516 $| = 1;
|
|
|
517 select($oldh);
|
|
|
518 } else {
|
|
|
519 $self->{'_filehandle'}->flush();
|
|
|
520 }
|
|
|
521 }
|
|
|
522
|
|
|
523 =head2 noclose
|
|
|
524
|
|
|
525 Title : noclose
|
|
|
526 Usage : $obj->noclose($newval)
|
|
|
527 Function: Get/Set the NOCLOSE flag - setting this to true will
|
|
|
528 prevent a filehandle from being closed
|
|
|
529 when an object is cleaned up or explicitly closed
|
|
|
530 This is a bit of hack
|
|
|
531 Returns : value of noclose (a scalar)
|
|
|
532 Args : on set, new value (a scalar or undef, optional)
|
|
|
533
|
|
|
534
|
|
|
535 =cut
|
|
|
536
|
|
|
537 sub noclose{
|
|
|
538 my $self = shift;
|
|
|
539
|
|
|
540 return $self->{'_noclose'} = shift if @_;
|
|
|
541 return $self->{'_noclose'};
|
|
|
542 }
|
|
|
543
|
|
|
544 sub _io_cleanup {
|
|
|
545 my ($self) = @_;
|
|
|
546
|
|
|
547 $self->close();
|
|
|
548 my $v = $self->verbose;
|
|
|
549
|
|
|
550 # we are planning to cleanup temp files no matter what
|
|
|
551 if( exists($self->{'_rootio_tempfiles'}) &&
|
|
|
552 ref($self->{'_rootio_tempfiles'}) =~ /array/i) {
|
|
|
553 if( $v > 0 ) {
|
|
|
554 print STDERR "going to remove files ",
|
|
|
555 join(",", @{$self->{'_rootio_tempfiles'}}), "\n";
|
|
|
556 }
|
|
|
557 unlink (@{$self->{'_rootio_tempfiles'}} );
|
|
|
558 }
|
|
|
559 # cleanup if we are not using File::Temp
|
|
|
560 if( $self->{'_cleanuptempdir'} &&
|
|
|
561 exists($self->{'_rootio_tempdirs'}) &&
|
|
|
562 ref($self->{'_rootio_tempdirs'}) =~ /array/i) {
|
|
|
563
|
|
|
564 if( $v > 0 ) {
|
|
|
565 print STDERR "going to remove dirs ",
|
|
|
566 join(",", @{$self->{'_rootio_tempdirs'}}), "\n";
|
|
|
567 }
|
|
|
568 $self->rmtree( $self->{'_rootio_tempdirs'});
|
|
|
569 }
|
|
|
570 }
|
|
|
571
|
|
|
572 =head2 exists_exe
|
|
|
573
|
|
|
574 Title : exists_exe
|
|
|
575 Usage : $exists = $obj->exists_exe('clustalw');
|
|
|
576 $exists = Bio::Root::IO->exists_exe('clustalw')
|
|
|
577 $exists = Bio::Root::IO::exists_exe('clustalw')
|
|
|
578 Function: Determines whether the given executable exists either as file
|
|
|
579 or within the path environment. The latter requires File::Spec
|
|
|
580 to be installed.
|
|
|
581 On Win32-based system, .exe is automatically appended to the program
|
|
|
582 name unless the program name already ends in .exe.
|
|
|
583 Example :
|
|
|
584 Returns : 1 if the given program is callable as an executable, and 0 otherwise
|
|
|
585 Args : the name of the executable
|
|
|
586
|
|
|
587 =cut
|
|
|
588
|
|
|
589 sub exists_exe {
|
|
|
590 my ($self, $exe) = @_;
|
|
|
591 $exe = $self if(!(ref($self) || $exe));
|
|
|
592 $exe .= '.exe' if(($^O =~ /mswin/i) && ($exe !~ /\.(exe|com|bat|cmd)$/i));
|
|
|
593 return $exe if(-e $exe); # full path and exists
|
|
|
594
|
|
|
595 # Ewan's comment. I don't think we need this. People should not be
|
|
|
596 # asking for a program with a pathseparator starting it
|
|
|
597
|
|
|
598 # $exe =~ s/^$PATHSEP//;
|
|
|
599
|
|
|
600 # Not a full path, or does not exist. Let's see whether it's in the path.
|
|
|
601 if($FILESPECLOADED) {
|
|
|
602 foreach my $dir (File::Spec->path()) {
|
|
|
603 my $f = Bio::Root::IO->catfile($dir, $exe);
|
|
|
604 return $f if(-e $f && -x $f );
|
|
|
605 }
|
|
|
606 }
|
|
|
607 return 0;
|
|
|
608 }
|
|
|
609
|
|
|
610 =head2 tempfile
|
|
|
611
|
|
|
612 Title : tempfile
|
|
|
613 Usage : my ($handle,$tempfile) = $io->tempfile();
|
|
|
614 Function: Returns a temporary filename and a handle opened for writing and
|
|
|
615 and reading.
|
|
|
616
|
|
|
617 Caveats : If you do not have File::Temp on your system you should avoid
|
|
|
618 specifying TEMPLATE and SUFFIX. (We don't want to recode
|
|
|
619 everything, okay?)
|
|
|
620 Returns : a 2-element array, consisting of temporary handle and temporary
|
|
|
621 file name
|
|
|
622 Args : named parameters compatible with File::Temp: DIR (defaults to
|
|
|
623 $Bio::Root::IO::TEMPDIR), TEMPLATE, SUFFIX.
|
|
|
624
|
|
|
625 =cut
|
|
|
626
|
|
|
627 #'
|
|
|
628 sub tempfile {
|
|
|
629 my ($self, @args) = @_;
|
|
|
630 my ($tfh, $file);
|
|
|
631 my %params = @args;
|
|
|
632
|
|
|
633 # map between naming with and without dash
|
|
|
634 foreach my $key (keys(%params)) {
|
|
|
635 if( $key =~ /^-/ ) {
|
|
|
636 my $v = $params{$key};
|
|
|
637 delete $params{$key};
|
|
|
638 $params{uc(substr($key,1))} = $v;
|
|
|
639 } else {
|
|
|
640 # this is to upper case
|
|
|
641 my $v = $params{$key};
|
|
|
642 delete $params{$key};
|
|
|
643 $params{uc($key)} = $v;
|
|
|
644 }
|
|
|
645 }
|
|
|
646 $params{'DIR'} = $TEMPDIR if(! exists($params{'DIR'}));
|
|
|
647 unless (exists $params{'UNLINK'} &&
|
|
|
648 defined $params{'UNLINK'} &&
|
|
|
649 ! $params{'UNLINK'} ) {
|
|
|
650 $params{'UNLINK'} = 1;
|
|
|
651 } else { $params{'UNLINK'} = 0 }
|
|
|
652
|
|
|
653 if($FILETEMPLOADED) {
|
|
|
654 if(exists($params{'TEMPLATE'})) {
|
|
|
655 my $template = $params{'TEMPLATE'};
|
|
|
656 delete $params{'TEMPLATE'};
|
|
|
657 ($tfh, $file) = File::Temp::tempfile($template, %params);
|
|
|
658 } else {
|
|
|
659 ($tfh, $file) = File::Temp::tempfile(%params);
|
|
|
660 }
|
|
|
661 } else {
|
|
|
662 my $dir = $params{'DIR'};
|
|
|
663 $file = $self->catfile($dir,
|
|
|
664 (exists($params{'TEMPLATE'}) ?
|
|
|
665 $params{'TEMPLATE'} :
|
|
|
666 sprintf( "%s.%s.%s",
|
|
|
667 $ENV{USER} || 'unknown', $$,
|
|
|
668 $TEMPCOUNTER++)));
|
|
|
669
|
|
|
670 # sneakiness for getting around long filenames on Win32?
|
|
|
671 if( $HAS_WIN32 ) {
|
|
|
672 $file = Win32::GetShortPathName($file);
|
|
|
673 }
|
|
|
674
|
|
|
675 # taken from File::Temp
|
|
|
676 if ($] < 5.006) {
|
|
|
677 $tfh = &Symbol::gensym;
|
|
|
678 }
|
|
|
679 # Try to make sure this will be marked close-on-exec
|
|
|
680 # XXX: Win32 doesn't respect this, nor the proper fcntl,
|
|
|
681 # but may have O_NOINHERIT. This may or may not be in Fcntl.
|
|
|
682 local $^F = 2;
|
|
|
683 # Store callers umask
|
|
|
684 my $umask = umask();
|
|
|
685 # Set a known umaskr
|
|
|
686 umask(066);
|
|
|
687 # Attempt to open the file
|
|
|
688 if ( sysopen($tfh, $file, $OPENFLAGS, 0600) ) {
|
|
|
689 # Reset umask
|
|
|
690 umask($umask);
|
|
|
691 } else {
|
|
|
692 $self->throw("Could not open tempfile $file: $!\n");
|
|
|
693 }
|
|
|
694 }
|
|
|
695
|
|
|
696 if( $params{'UNLINK'} ) {
|
|
|
697 push @{$self->{'_rootio_tempfiles'}}, $file;
|
|
|
698 }
|
|
|
699
|
|
|
700
|
|
|
701 return wantarray ? ($tfh,$file) : $tfh;
|
|
|
702 }
|
|
|
703
|
|
|
704 =head2 tempdir
|
|
|
705
|
|
|
706 Title : tempdir
|
|
|
707 Usage : my ($tempdir) = $io->tempdir(CLEANUP=>1);
|
|
|
708 Function: Creates and returns the name of a new temporary directory.
|
|
|
709
|
|
|
710 Note that you should not use this function for obtaining "the"
|
|
|
711 temp directory. Use $Bio::Root::IO::TEMPDIR for that. Calling this
|
|
|
712 method will in fact create a new directory.
|
|
|
713
|
|
|
714 Returns : The name of a new temporary directory.
|
|
|
715 Args : args - ( key CLEANUP ) indicates whether or not to cleanup
|
|
|
716 dir on object destruction, other keys as specified by File::Temp
|
|
|
717
|
|
|
718 =cut
|
|
|
719
|
|
|
720 sub tempdir {
|
|
|
721 my ( $self, @args ) = @_;
|
|
|
722 if($FILETEMPLOADED && File::Temp->can('tempdir') ) {
|
|
|
723 return File::Temp::tempdir(@args);
|
|
|
724 }
|
|
|
725
|
|
|
726 # we have to do this ourselves, not good
|
|
|
727 #
|
|
|
728 # we are planning to cleanup temp files no matter what
|
|
|
729 my %params = @args;
|
|
|
730 $self->{'_cleanuptempdir'} = ( defined $params{CLEANUP} &&
|
|
|
731 $params{CLEANUP} == 1);
|
|
|
732 my $tdir = $self->catfile($TEMPDIR,
|
|
|
733 sprintf("dir_%s-%s-%s",
|
|
|
734 $ENV{USER} || 'unknown', $$,
|
|
|
735 $TEMPCOUNTER++));
|
|
|
736 mkdir($tdir, 0755);
|
|
|
737 push @{$self->{'_rootio_tempdirs'}}, $tdir;
|
|
|
738 return $tdir;
|
|
|
739 }
|
|
|
740
|
|
|
741 =head2 catfile
|
|
|
742
|
|
|
743 Title : catfile
|
|
|
744 Usage : $path = Bio::Root::IO->catfile(@dirs,$filename);
|
|
|
745 Function: Constructs a full pathname in a cross-platform safe way.
|
|
|
746
|
|
|
747 If File::Spec exists on your system, this routine will merely
|
|
|
748 delegate to it. Otherwise it tries to make a good guess.
|
|
|
749
|
|
|
750 You should use this method whenever you construct a path name
|
|
|
751 from directory and filename. Otherwise you risk cross-platform
|
|
|
752 compatibility of your code.
|
|
|
753
|
|
|
754 You can call this method both as a class and an instance method.
|
|
|
755
|
|
|
756 Returns : a string
|
|
|
757 Args : components of the pathname (directories and filename, NOT an
|
|
|
758 extension)
|
|
|
759
|
|
|
760 =cut
|
|
|
761
|
|
|
762 sub catfile {
|
|
|
763 my ($self, @args) = @_;
|
|
|
764
|
|
|
765 return File::Spec->catfile(@args) if($FILESPECLOADED);
|
|
|
766 # this is clumsy and not very appealing, but how do we specify the
|
|
|
767 # root directory?
|
|
|
768 if($args[0] eq '/') {
|
|
|
769 $args[0] = $ROOTDIR;
|
|
|
770 }
|
|
|
771 return join($PATHSEP, @args);
|
|
|
772 }
|
|
|
773
|
|
|
774 =head2 rmtree
|
|
|
775
|
|
|
776 Title : rmtree
|
|
|
777 Usage : Bio::Root::IO->rmtree($dirname );
|
|
|
778 Function: Remove a full directory tree
|
|
|
779
|
|
|
780 If File::Path exists on your system, this routine will merely
|
|
|
781 delegate to it. Otherwise it runs a local version of that code.
|
|
|
782
|
|
|
783 You should use this method to remove directories which contain
|
|
|
784 files.
|
|
|
785
|
|
|
786 You can call this method both as a class and an instance method.
|
|
|
787
|
|
|
788 Returns : number of files successfully deleted
|
|
|
789 Args : roots - rootdir to delete or reference to list of dirs
|
|
|
790
|
|
|
791 verbose - a boolean value, which if TRUE will cause
|
|
|
792 C<rmtree> to print a message each time it
|
|
|
793 examines a file, giving the name of the file, and
|
|
|
794 indicating whether it's using C<rmdir> or
|
|
|
795 C<unlink> to remove it, or that it's skipping it.
|
|
|
796 (defaults to FALSE)
|
|
|
797
|
|
|
798 safe - a boolean value, which if TRUE will cause C<rmtree>
|
|
|
799 to skip any files to which you do not have delete
|
|
|
800 access (if running under VMS) or write access (if
|
|
|
801 running under another OS). This will change in the
|
|
|
802 future when a criterion for 'delete permission'
|
|
|
803 under OSs other than VMS is settled. (defaults to
|
|
|
804 FALSE)
|
|
|
805
|
|
|
806 =cut
|
|
|
807
|
|
|
808 # taken straight from File::Path VERSION = "1.0403"
|
|
|
809 sub rmtree {
|
|
|
810 my($self,$roots, $verbose, $safe) = @_;
|
|
|
811 if( $FILEPATHLOADED ) {
|
|
|
812 return File::Path::rmtree ($roots, $verbose, $safe);
|
|
|
813 }
|
|
|
814
|
|
|
815 my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32'
|
|
|
816 || $^O eq 'amigaos');
|
|
|
817 my $Is_VMS = $^O eq 'VMS';
|
|
|
818
|
|
|
819 my(@files);
|
|
|
820 my($count) = 0;
|
|
|
821 $verbose ||= 0;
|
|
|
822 $safe ||= 0;
|
|
|
823 if ( defined($roots) && length($roots) ) {
|
|
|
824 $roots = [$roots] unless ref $roots;
|
|
|
825 } else {
|
|
|
826 $self->warn("No root path(s) specified\n");
|
|
|
827 return 0;
|
|
|
828 }
|
|
|
829
|
|
|
830 my($root);
|
|
|
831 foreach $root (@{$roots}) {
|
|
|
832 $root =~ s#/\z##;
|
|
|
833 (undef, undef, my $rp) = lstat $root or next;
|
|
|
834 $rp &= 07777; # don't forget setuid, setgid, sticky bits
|
|
|
835 if ( -d _ ) {
|
|
|
836 # notabene: 0777 is for making readable in the first place,
|
|
|
837 # it's also intended to change it to writable in case we have
|
|
|
838 # to recurse in which case we are better than rm -rf for
|
|
|
839 # subtrees with strange permissions
|
|
|
840 chmod(0777, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
|
|
|
841 or $self->warn("Can't make directory $root read+writeable: $!")
|
|
|
842 unless $safe;
|
|
|
843 if (opendir(DIR, $root) ){
|
|
|
844 @files = readdir DIR;
|
|
|
845 closedir(DIR);
|
|
|
846 } else {
|
|
|
847 $self->warn( "Can't read $root: $!");
|
|
|
848 @files = ();
|
|
|
849 }
|
|
|
850
|
|
|
851 # Deleting large numbers of files from VMS Files-11 filesystems
|
|
|
852 # is faster if done in reverse ASCIIbetical order
|
|
|
853 @files = reverse @files if $Is_VMS;
|
|
|
854 ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS;
|
|
|
855 @files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files);
|
|
|
856 $count += $self->rmtree([@files],$verbose,$safe);
|
|
|
857 if ($safe &&
|
|
|
858 ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
|
|
|
859 print "skipped $root\n" if $verbose;
|
|
|
860 next;
|
|
|
861 }
|
|
|
862 chmod 0777, $root
|
|
|
863 or $self->warn( "Can't make directory $root writeable: $!")
|
|
|
864 if $force_writeable;
|
|
|
865 print "rmdir $root\n" if $verbose;
|
|
|
866 if (rmdir $root) {
|
|
|
867 ++$count;
|
|
|
868 }
|
|
|
869 else {
|
|
|
870 $self->warn( "Can't remove directory $root: $!");
|
|
|
871 chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
|
|
|
872 or $self->warn("and can't restore permissions to "
|
|
|
873 . sprintf("0%o",$rp) . "\n");
|
|
|
874 }
|
|
|
875 }
|
|
|
876 else {
|
|
|
877
|
|
|
878 if ($safe &&
|
|
|
879 ($Is_VMS ? !&VMS::Filespec::candelete($root)
|
|
|
880 : !(-l $root || -w $root)))
|
|
|
881 {
|
|
|
882 print "skipped $root\n" if $verbose;
|
|
|
883 next;
|
|
|
884 }
|
|
|
885 chmod 0666, $root
|
|
|
886 or $self->warn( "Can't make file $root writeable: $!")
|
|
|
887 if $force_writeable;
|
|
|
888 print "unlink $root\n" if $verbose;
|
|
|
889 # delete all versions under VMS
|
|
|
890 for (;;) {
|
|
|
891 unless (unlink $root) {
|
|
|
892 $self->warn( "Can't unlink file $root: $!");
|
|
|
893 if ($force_writeable) {
|
|
|
894 chmod $rp, $root
|
|
|
895 or $self->warn("and can't restore permissions to "
|
|
|
896 . sprintf("0%o",$rp) . "\n");
|
|
|
897 }
|
|
|
898 last;
|
|
|
899 }
|
|
|
900 ++$count;
|
|
|
901 last unless $Is_VMS && lstat $root;
|
|
|
902 }
|
|
|
903 }
|
|
|
904 }
|
|
|
905
|
|
|
906 $count;
|
|
|
907 }
|
|
|
908
|
|
|
909 =head2 _flush_on_write
|
|
|
910
|
|
|
911 Title : _flush_on_write
|
|
|
912 Usage : $obj->_flush_on_write($newval)
|
|
|
913 Function: Boolean flag to indicate whether to flush
|
|
|
914 the filehandle on writing when the end of
|
|
|
915 a component is finished (Sequences,Alignments,etc)
|
|
|
916 Returns : value of _flush_on_write
|
|
|
917 Args : newvalue (optional)
|
|
|
918
|
|
|
919
|
|
|
920 =cut
|
|
|
921
|
|
|
922 sub _flush_on_write {
|
|
|
923 my ($self,$value) = @_;
|
|
|
924 if( defined $value) {
|
|
|
925 $self->{'_flush_on_write'} = $value;
|
|
|
926 }
|
|
|
927 return $self->{'_flush_on_write'};
|
|
|
928 }
|
|
|
929
|
|
|
930 1;
|
