← Index
NYTProf Performance Profile   « block view • line view • sub view »
For bin/pan_genome_post_analysis
  Run on Fri Mar 27 11:43:32 2015
Reported on Fri Mar 27 11:46:07 2015

Filename/Users/ap13/perl5/lib/perl5/Bio/Root/IO.pm
StatementsExecuted 41 statements in 4.49ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1117.95ms16.2msBio::Root::IO::::BEGIN@75Bio::Root::IO::BEGIN@75
1112.40ms3.91msBio::Root::IO::::BEGIN@5Bio::Root::IO::BEGIN@5
111806µs906µsBio::Root::IO::::BEGIN@4Bio::Root::IO::BEGIN@4
111461µs1.10msBio::Root::IO::::BEGIN@7Bio::Root::IO::BEGIN@7
11117µs32µsBio::Root::IO::::BEGIN@3Bio::Root::IO::BEGIN@3
11112µs43µsBio::Root::IO::::BEGIN@6Bio::Root::IO::BEGIN@6
11111µs26µsBio::Root::IO::::BEGIN@359Bio::Root::IO::BEGIN@359
11110µs85µsBio::Root::IO::::BEGIN@8Bio::Root::IO::BEGIN@8
1118µs20µsBio::Root::IO::::BEGIN@144Bio::Root::IO::BEGIN@144
3217µs7µsBio::Root::IO::::CORE:matchBio::Root::IO::CORE:match (opcode)
0000s0sBio::Root::IO::::_fhBio::Root::IO::_fh
0000s0sBio::Root::IO::::_flush_on_writeBio::Root::IO::_flush_on_write
0000s0sBio::Root::IO::::_initialize_ioBio::Root::IO::_initialize_io
0000s0sBio::Root::IO::::_insertBio::Root::IO::_insert
0000s0sBio::Root::IO::::_io_cleanupBio::Root::IO::_io_cleanup
0000s0sBio::Root::IO::::_printBio::Root::IO::_print
0000s0sBio::Root::IO::::_pushbackBio::Root::IO::_pushback
0000s0sBio::Root::IO::::_readlineBio::Root::IO::_readline
0000s0sBio::Root::IO::::catfileBio::Root::IO::catfile
0000s0sBio::Root::IO::::cleanfileBio::Root::IO::cleanfile
0000s0sBio::Root::IO::::closeBio::Root::IO::close
0000s0sBio::Root::IO::::exists_exeBio::Root::IO::exists_exe
0000s0sBio::Root::IO::::fileBio::Root::IO::file
0000s0sBio::Root::IO::::flushBio::Root::IO::flush
0000s0sBio::Root::IO::::formatBio::Root::IO::format
0000s0sBio::Root::IO::::modeBio::Root::IO::mode
0000s0sBio::Root::IO::::newBio::Root::IO::new
0000s0sBio::Root::IO::::nocloseBio::Root::IO::noclose
0000s0sBio::Root::IO::::rmtreeBio::Root::IO::rmtree
0000s0sBio::Root::IO::::save_tempfilesBio::Root::IO::save_tempfiles
0000s0sBio::Root::IO::::tempdirBio::Root::IO::tempdir
0000s0sBio::Root::IO::::tempfileBio::Root::IO::tempfile
0000s0sBio::Root::IO::::variantBio::Root::IO::variant
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Bio::Root::IO;
2
3226µs246µs
# spent 32µs (17+14) within Bio::Root::IO::BEGIN@3 which was called: # once (17µs+14µs) by Bio::Root::Root::BEGIN@3 at line 3
use strict;
# spent 32µs making 1 call to Bio::Root::IO::BEGIN@3 # spent 14µs making 1 call to strict::import
42196µs2982µs
# spent 906µs (806+100) within Bio::Root::IO::BEGIN@4 which was called: # once (806µs+100µs) by Bio::Root::Root::BEGIN@3 at line 4
use Symbol;
# spent 906µs making 1 call to Bio::Root::IO::BEGIN@4 # spent 77µs making 1 call to Exporter::import
52294µs23.93ms
# spent 3.91ms (2.40+1.51) within Bio::Root::IO::BEGIN@5 which was called: # once (2.40ms+1.51ms) by Bio::Root::Root::BEGIN@3 at line 5
use IO::Handle;
# spent 3.91ms making 1 call to Bio::Root::IO::BEGIN@5 # spent 20µs making 1 call to Exporter::import
6227µs274µs
# spent 43µs (12+31) within Bio::Root::IO::BEGIN@6 which was called: # once (12µs+31µs) by Bio::Root::Root::BEGIN@3 at line 6
use File::Copy;
# spent 43µs making 1 call to Bio::Root::IO::BEGIN@6 # spent 31µs making 1 call to Exporter::import
72157µs21.35ms
# spent 1.10ms (461µs+636µs) within Bio::Root::IO::BEGIN@7 which was called: # once (461µs+636µs) by Bio::Root::Root::BEGIN@3 at line 7
use Fcntl;
# spent 1.10ms making 1 call to Bio::Root::IO::BEGIN@7 # spent 253µs making 1 call to Exporter::import
82414µs285µs
# spent 85µs (10+76) within Bio::Root::IO::BEGIN@8 which was called: # once (10µs+76µs) by Bio::Root::Root::BEGIN@3 at line 8
use base qw(Bio::Root::Root);
# spent 85µs making 1 call to Bio::Root::IO::BEGIN@8 # spent 76µs making 1 call to base::import, recursion: max depth 1, sum of overlapping time 76µs
9
10# ABSTRACT: module providing several methods often needed when dealing with file IO
11# AUTHOR: Hilmar Lapp <hlapp@gmx.net>
12# OWNER: Hilmar Lapp
13# LICENSE: Perl_5
14
15# CONTRIBUTOR: Mark A. Jensen <maj@fortinbras.us>
16
17=head1 SYNOPSIS
18
19 # Use stream I/O in your module
20 $self->{'io'} = Bio::Root::IO->new(-file => "myfile");
21 $self->{'io'}->_print("some stuff");
22 my $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
33This module provides methods that will usually be needed for any sort
34of file- or stream-related input/output, e.g., keeping track of a file
35handle, transient printing and reading from the file handle, a close
36method, automatically closing the handle on garbage collection, etc.
37
38To use this for your own code you will either want to inherit from
39this module, or instantiate an object for every file or stream you are
40dealing with. In the first case this module will most likely not be
41the first class off which your class inherits; therefore you need to
42call _initialize_io() with the named parameters in order to set file
43handle, open file, etc automatically.
44
45Most methods start with an underscore, indicating they are private. In
46OO speak, they are not private but protected, that is, use them in
47your module code, but a client code of your module will usually not
48want to call them (except those not starting with an underscore).
49
50In addition this module contains a couple of convenience methods for
51cross-platform safe tempfile creation and similar tasks. There are
52some CPAN modules related that may not be available on all
53platforms. At present, File::Spec and File::Temp are attempted. This
54module defines $PATHSEP, $TEMPDIR, and $ROOTDIR, which will always be set,
55and $OPENFLAGS, which will be set if either of File::Spec or File::Temp fails.
56
57The -noclose boolean (accessed via the noclose method) prevents a
58filehandle from being closed when the IO object is cleaned up. This
59is special behavior when a object like a parser might share a
60filehandle with an object like an indexer where it is not proper to
61close the filehandle as it will continue to be reused until the end of the
62stream is reached. In general you won't want to play with this flag.
63
64=cut
65
661300nsour ($FILESPECLOADED, $FILETEMPLOADED,
67 $FILEPATHLOADED, $TEMPDIR,
68 $PATHSEP, $ROOTDIR,
69 $OPENFLAGS, $VERBOSE,
70 $ONMAC, $HAS_EOL, );
71
721100nsmy $TEMPCOUNTER;
731300nsmy $HAS_WIN32 = 0;
74
75
# spent 16.2ms (7.95+8.27) within Bio::Root::IO::BEGIN@75 which was called: # once (7.95ms+8.27ms) by Bio::Root::Root::BEGIN@3 at line 149
BEGIN {
761300ns $TEMPCOUNTER = 0;
771100ns $FILESPECLOADED = 0;
781100ns $FILETEMPLOADED = 0;
7910s $FILEPATHLOADED = 0;
8010s $VERBOSE = 0;
81
82 # try to load those modules that may cause trouble on some systems
831100ns eval {
84182µs require File::Path;
851400ns $FILEPATHLOADED = 1;
86 };
871100ns if( $@ ) {
88 print STDERR "Cannot load File::Path: $@" if( $VERBOSE > 0 );
89 # do nothing
90 }
91
92 # If on Win32, attempt to find Win32 package
93112µs16µs if($^O =~ /mswin/i) {
# spent 6µs making 1 call to Bio::Root::IO::CORE:match
94 eval {
95 require Win32;
96 $HAS_WIN32 = 1;
97 };
98 }
99
100 # Try to provide a path separator. Why doesn't File::Spec export this,
101 # or did I miss it?
10215µs21µs if ($^O =~ /mswin/i) {
# spent 1µs making 2 calls to Bio::Root::IO::CORE:match, avg 550ns/call
103 $PATHSEP = "\\";
104 } elsif($^O =~ /macos/i) {
105 $PATHSEP = ":";
106 } else { # unix
1071800ns $PATHSEP = "/";
108 }
1091400ns eval {
1101300ns require File::Spec;
1111200ns $FILESPECLOADED = 1;
11217µs199µs $TEMPDIR = File::Spec->tmpdir();
# spent 99µs making 1 call to File::Spec::Unix::tmpdir
11314µs12µs $ROOTDIR = File::Spec->rootdir();
# spent 2µs making 1 call to File::Spec::Unix::rootdir
114196µs require File::Temp; # tempfile creation
1151700ns $FILETEMPLOADED = 1;
116 };
1171400ns if( $@ ) {
118 if(! defined($TEMPDIR)) { # File::Spec failed
119 # determine tempdir
120 if (defined $ENV{'TEMPDIR'} && -d $ENV{'TEMPDIR'} ) {
121 $TEMPDIR = $ENV{'TEMPDIR'};
122 } elsif( defined $ENV{'TMPDIR'} && -d $ENV{'TMPDIR'} ) {
123 $TEMPDIR = $ENV{'TMPDIR'};
124 }
125 if($^O =~ /mswin/i) {
126 $TEMPDIR = 'C:\TEMP' unless $TEMPDIR;
127 $ROOTDIR = 'C:';
128 } elsif($^O =~ /macos/i) {
129 $TEMPDIR = "" unless $TEMPDIR; # what is a reasonable default on Macs?
130 $ROOTDIR = ""; # what is reasonable??
131 } else { # unix
132 $TEMPDIR = "/tmp" unless $TEMPDIR;
133 $ROOTDIR = "/";
134 }
135 if (!( -d $TEMPDIR && -w $TEMPDIR )) {
136 $TEMPDIR = '.'; # last resort
137 }
138 }
139 # File::Temp failed (alone, or File::Spec already failed)
140 # determine open flags for tempfile creation using Fcntl
141 $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR;
142 for my $oflag (qw/FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT TEMPORARY/){
143 my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
144273µs232µs
# spent 20µs (8+12) within Bio::Root::IO::BEGIN@144 which was called: # once (8µs+12µs) by Bio::Root::Root::BEGIN@3 at line 144
no strict 'refs';
# spent 20µs making 1 call to Bio::Root::IO::BEGIN@144 # spent 12µs making 1 call to strict::unimport
145 $OPENFLAGS |= $bit if eval { $bit = &$func(); 1 };
146 }
147 }
14814µs $ONMAC = "\015" eq "\n";
1491660µs116.2ms}
# spent 16.2ms making 1 call to Bio::Root::IO::BEGIN@75
150
151
152=head2 new
153
154 Title : new
155 Usage : my $io = Bio::Root::IO->new( -file => 'data.txt' );
156 Function: Create new class instance. It automatically calls C<_initialize_io>.
157 Args : Same named parameters as C<_initialize_io>.
158 Returns : A Bio::Root::IO object
159
160=cut
161
162sub new {
163 my ($caller, @args) = @_;
164 my $self = $caller->SUPER::new(@args);
165 $self->_initialize_io(@args);
166 return $self;
167}
168
169
170=head2 _initialize_io
171
172 Title : _initialize_io
173 Usage : $io->_initialize_io(@params);
174 Function: Initializes filehandle and other properties from the parameters.
175 Args : The following named parameters are currently recognized:
176 -file name of file to read or write to
177 -fh file handle to read or write to (mutually exclusive
178 with -file and -string)
179 -input name of file, or filehandle (GLOB or IO::Handle object)
180 to read of write to
181 -string string to read from (will be converted to filehandle)
182 -url name of URL to open
183 -flush boolean flag to autoflush after each write
184 -noclose boolean flag, when set to true will not close a
185 filehandle (must explicitly call close($io->_fh)
186 -retries number of times to try a web fetch before failure
187 -ua_parms when using -url, hashref of key => value parameters
188 to pass to LWP::UserAgent->new(). A useful value might
189 be, for example, {timeout => 60 } (ua defaults to 180s)
190 Returns : True
191
192=cut
193
194sub _initialize_io {
195 my($self, @args) = @_;
196
197 $self->_register_for_cleanup(\&_io_cleanup);
198
199 my ($input, $noclose, $file, $fh, $string,
200 $flush, $url, $retries, $ua_parms) =
201 $self->_rearrange([qw(INPUT NOCLOSE FILE FH STRING FLUSH URL RETRIES UA_PARMS)],
202 @args);
203
204 my $mode;
205
206 if ($url) {
207 $retries ||= 5;
208
209 require LWP::UserAgent;
210 my $ua = LWP::UserAgent->new(%$ua_parms);
211 my $http_result;
212 my ($handle, $tempfile) = $self->tempfile();
213 CORE::close($handle);
214
215 for (my $try = 1 ; $try <= $retries ; $try++) {
216 $http_result = $ua->get($url, ':content_file' => $tempfile);
217 $self->warn("[$try/$retries] tried to fetch $url, but server ".
218 "threw ". $http_result->code . ". retrying...")
219 if !$http_result->is_success;
220 last if $http_result->is_success;
221 }
222 $self->throw("Failed to fetch $url, server threw ".$http_result->code)
223 if !$http_result->is_success;
224
225 $file = $tempfile;
226 $mode = '>';
227 }
228
229 delete $self->{'_readbuffer'};
230 delete $self->{'_filehandle'};
231 $self->noclose( $noclose) if defined $noclose;
232 # determine whether the input is a file(name) or a stream
233 if ($input) {
234 if (ref(\$input) eq 'SCALAR') {
235 # we assume that a scalar is a filename
236 if ($file && ($file ne $input)) {
237 $self->throw("Input file given twice: '$file' and '$input' disagree");
238 }
239 $file = $input;
240 } elsif (ref($input) &&
241 ((ref($input) eq 'GLOB') || $input->isa('IO::Handle'))) {
242 # input is a stream
243 $fh = $input;
244 } else {
245 # let's be strict for now
246 $self->throw("Unable to determine type of input $input: ".
247 "not string and not GLOB");
248 }
249 }
250
251 if (defined($file) && defined($fh)) {
252 $self->throw("Providing both a file and a filehandle for reading - ".
253 "only one please!");
254 }
255
256 if ($string) {
257 if (defined($file) || defined($fh)) {
258 $self->throw("File or filehandle provided with -string, ".
259 "please unset if you are using -string as a file");
260 }
261 open $fh, '<', \$string or $self->throw("Could not read string: $!");
262 }
263
264 if (defined($file) && ($file ne '')) {
265 $self->file($file);
266 ($mode, $file) = $self->cleanfile;
267 $mode ||= '<';
268 my $action = ($mode =~ m/>/) ? 'write' : 'read';
269 $fh = Symbol::gensym();
270 open $fh, $mode, $file or $self->throw("Could not $action file '$file': $!");
271 }
272
273 if (defined $fh) {
274 # check filehandle to ensure it's one of:
275 # a GLOB reference, as in: open(my $fh, "myfile");
276 # an IO::Handle or IO::String object
277 # the UNIVERSAL::can added to fix Bug2863
278 unless ( ( ref $fh and ( ref $fh eq 'GLOB' ) )
279 or ( ref $fh and ( UNIVERSAL::can( $fh, 'can' ) )
280 and ( $fh->isa('IO::Handle')
281 or $fh->isa('IO::String') ) )
282 ) {
283 $self->throw("Object $fh does not appear to be a file handle");
284 }
285 if ($HAS_EOL) {
286 binmode $fh, ':raw:eol(LF-Native)';
287 }
288 $self->_fh($fh); # if $fh not provided, defaults to STDIN and STDOUT
289 }
290
291 $self->_flush_on_write(defined $flush ? $flush : 1);
292
293 return 1;
294}
295
296
297=head2 _fh
298
299 Title : _fh
300 Usage : $io->_fh($newval);
301 Function: Get or set the file handle for the stream encapsulated.
302 Args : Optional filehandle to use
303 Returns : Filehandle for the stream
304
305=cut
306
307sub _fh {
308 my ($self, $value) = @_;
309 if ( defined $value) {
310 $self->{'_filehandle'} = $value;
311 }
312 return $self->{'_filehandle'};
313}
314
315
316=head2 mode
317
318 Title : mode
319 Usage : $io->mode();
320 $io->mode(-force => 1);
321 Function: Determine if the object was opened for reading or writing
322 Args : -force: Boolean. Once mode() has been called, the mode is cached for
323 further calls to mode(). Use this argument to override this
324 behavior and re-check the object's mode.
325 Returns : Mode of the object:
326 'r' for readable
327 'w' for writable
328 'rw' for readable and writable
329 '?' if mode could not be determined (e.g. for a -url)
330
331=cut
332
333sub mode {
334 my ($self, %arg) = @_;
335
336 # Method 1: IO::Handle::fdopen
337 # my $iotest = new IO::Handle;
338 # $iotest->fdopen( dup(fileno($fh)) , 'r' );
339 # if ($iotest->error == 0) { ... }
340 # It did not actually seem to work under any platform, since there would no
341 # error if the filehandle had been opened writable only. It could not be
342 # hacked around when dealing with unseekable (piped) filehandles.
343
344 # Method 2: readline, a.k.a. the <> operator
345 # no warnings "io";
346 # my $line = <$fh>;
347 # if (defined $line) {
348 # $self->{'_mode'} = 'r';
349 # ...
350 # It did not work well either because <> returns undef, i.e. querying the
351 # mode() after having read an entire file returned 'w'.
352
353 if ( $arg{-force} || not exists $self->{'_mode'} ) {
354 # Determine stream mode
355 my $mode;
356 my $fh = $self->_fh;
357 if (defined $fh) {
358 # Determine read/write status of filehandle
35922.42ms240µs
# spent 26µs (11+15) within Bio::Root::IO::BEGIN@359 which was called: # once (11µs+15µs) by Bio::Root::Root::BEGIN@3 at line 359
no warnings 'io';
# spent 26µs making 1 call to Bio::Root::IO::BEGIN@359 # spent 15µs making 1 call to warnings::unimport
360 if ( defined( read $fh, my $content, 0 ) ) {
361 # Successfully read 0 bytes
362 $mode = 'r'
363 }
364 if ( defined( syswrite $fh, '') ) {
365 # Successfully wrote 0 bytes
366 $mode ||= '';
367 $mode .= 'w';
368 }
369 } else {
370 # Stream does not have a filehandle... cannot determine mode
371 $mode = '?';
372 }
373 # Save mode for future use
374 $self->{'_mode'} = $mode;
375 }
376 return $self->{'_mode'};
377}
378
379
380=head2 file
381
382 Title : file
383 Usage : $io->file('>'.$file);
384 my $file = $io->file;
385 Function: Get or set the name of the file to read or write.
386 Args : Optional file name (including its mode, e.g. '<' for reading or '>'
387 for writing)
388 Returns : A string representing the filename and its mode.
389
390=cut
391
392sub file {
393 my ($self, $value) = @_;
394 if ( defined $value) {
395 $self->{'_file'} = $value;
396 }
397 return $self->{'_file'};
398}
399
400
401=head2 cleanfile
402
403 Title : cleanfile
404 Usage : my ($mode, $file) = $io->cleanfile;
405 Function: Get the name of the file to read or write, stripped of its mode
406 ('>', '<', '+>', '>>', etc).
407 Args : None
408 Returns : In array context, an array of the mode and the clean filename.
409
410=cut
411
412sub cleanfile {
413 my ($self) = @_;
414 return ($self->{'_file'} =~ m/^ (\+?[><]{1,2})?\s*(.*) $/x);
415}
416
417
418=head2 format
419
420 Title : format
421 Usage : $io->format($newval)
422 Function: Get the format of a Bio::Root::IO sequence file or filehandle. Every
423 object inheriting Bio::Root::IO is guaranteed to have a format.
424 Args : None
425 Returns : Format of the file or filehandle, e.g. fasta, fastq, genbank, embl.
426
427=cut
428
429sub format {
430 my ($self) = @_;
431 my $format = (split '::', ref($self))[-1];
432 return $format;
433}
434
435
436=head2 variant
437
438 Title : format
439 Usage : $io->format($newval)
440 Function: Get the variant of a Bio::Root::IO sequence file or filehandle.
441 The format variant depends on the specific format used. Note that
442 not all formats have variants. Also, the Bio::Root::IO-implementing
443 modules that require access to variants need to define a global hash
444 that has the allowed variants as its keys.
445 Args : None
446 Returns : Variant of the file or filehandle, e.g. sanger, solexa or illumina for
447 the fastq format, or undef for formats that do not have variants.
448
449=cut
450
451sub variant {
452 my ($self, $variant) = @_;
453 if (defined $variant) {
454 $variant = lc $variant;
455 my $var_name = '%'.ref($self).'::variant';
456 my %ok_variants = eval $var_name; # e.g. %Bio::Assembly::IO::ace::variant
457 if (scalar keys %ok_variants == 0) {
458 $self->throw("Could not validate variant because global variant ".
459 "$var_name was not set or was empty\n");
460 }
461 if (not exists $ok_variants{$variant}) {
462 $self->throw("$variant is not a valid variant of the " .
463 $self->format . ' format');
464 }
465 $self->{variant} = $variant;
466 }
467 return $self->{variant};
468}
469
470
471=head2 _print
472
473 Title : _print
474 Usage : $io->_print(@lines)
475 Function: Print lines of text to the IO stream object.
476 Args : List of strings to print
477 Returns : True on success, undef on failure
478
479=cut
480
481sub _print {
482 my $self = shift;
483 my $fh = $self->_fh() || \*STDOUT;
484 my $ret = print $fh @_;
485 return $ret;
486}
487
488
489=head2 _insert
490
491 Title : _insert
492 Usage : $io->_insert($string,1)
493 Function: Insert some text in a file at the given line number (1-based).
494 Args : * string to write in file
495 * line number to insert the string at
496 Returns : True
497
498=cut
499
500sub _insert {
501 my ($self, $string, $line_num) = @_;
502 # Line number check
503 if ($line_num < 1) {
504 $self->throw("Could not insert text at line $line_num: the minimum ".
505 "line number possible is 1.");
506 }
507 # File check
508 my ($mode, $file) = $self->cleanfile;
509 if (not defined $file) {
510 $self->throw('Could not insert a line: IO object was initialized with '.
511 'something else than a file.');
512 }
513 # Everything that needs to be written is written before we read it
514 $self->flush;
515
516 # Edit the file line by line (no slurping)
517 $self->close;
518 my $temp_file;
519 my $number = 0;
520 while (-e "$file.$number.temp") {
521 $number++;
522 }
523 $temp_file = "$file.$number.temp";
524 copy($file, $temp_file);
525 open my $fh1, '<', $temp_file or $self->throw("Could not read temporary file '$temp_file': $!");
526 open my $fh2, '>', $file or $self->throw("Could not write file '$file': $!");
527 while (my $line = <$fh1>) {
528 if ($. == $line_num) { # right line for new data
529 print $fh2 $string . $line;
530 }
531 else {
532 print $fh2 $line;
533 }
534 }
535 CORE::close $fh1;
536 CORE::close $fh2;
537 unlink $temp_file or $self->throw("Could not delete temporary file '$temp_file': $!");
538
539 # Line number check (again)
540 if ( $. > 0 && $line_num > $. ) {
541 $self->throw("Could not insert text at line $line_num: there are only ".
542 "$. lines in file '$file'");
543 }
544 # Re-open the file in append mode to be ready to add text at the end of it
545 # when the next _print() statement comes
546 open my $new_fh, '>>', $file or $self->throw("Could not append to file '$file': $!");
547 $self->_fh($new_fh);
548 # If file is empty and we're inserting at line 1, simply append text to file
549 if ( $. == 0 && $line_num == 1 ) {
550 $self->_print($string);
551 }
552 return 1;
553}
554
555
556=head2 _readline
557
558 Title : _readline
559 Usage : local $Bio::Root::IO::HAS_EOL = 1;
560 my $io = Bio::Root::IO->new(-file => 'data.txt');
561 my $line = $io->_readline();
562 $io->close;
563 Function: Read a line of input and normalize all end of line characters.
564
565 End of line characters are typically "\n" on Linux platforms, "\r\n"
566 on Windows and "\r" on older Mac OS. By default, the _readline()
567 method uses the value of $/, Perl's input record separator, to
568 detect the end of each line. This means that you will not get the
569 expected lines if your input has Mac-formatted end of line characters.
570 Also, note that the current implementation does not handle pushed
571 back input correctly unless the pushed back input ends with the
572 value of $/. For each line parsed, its line ending, e.g. "\r\n" is
573 converted to "\n", unless you provide the -raw argument.
574
575 Altogether it is easier to let the PerlIO::eol module automatically
576 detect the proper end of line character and normalize it to "\n". Do
577 so by setting $Bio::Root::IO::HAS_EOL to 1.
578
579 Args : -raw : Avoid converting end of line characters to "\n" This option
580 has no effect when using $Bio::Root::IO::HAS_EOL = 1.
581 Returns : Line of input, or undef when there is nothing to read anymore
582
583=cut
584
585sub _readline {
586 my ($self, %param) = @_;
587 my $fh = $self->_fh or return;
588 my $line;
589
590 # if the buffer been filled by _pushback then return the buffer
591 # contents, rather than read from the filehandle
592 if( @{$self->{'_readbuffer'} || [] } ) {
593 $line = shift @{$self->{'_readbuffer'}};
594 } else {
595 $line = <$fh>;
596 }
597
598 # Note: In Windows the "-raw" parameter has no effect, because Perl already discards
599 # the '\r' from the line when reading in text mode from the filehandle
600 # ($line = <$fh>), and put it back automatically when printing
601 if( !$HAS_EOL && !$param{-raw} && (defined $line) ) {
602 # don't strip line endings if -raw or $HAS_EOL is specified
603 $line =~ s/\015\012/\012/g; # Change all CR/LF pairs to LF
604 $line =~ tr/\015/\n/ unless $ONMAC; # Change all single CRs to NEWLINE
605 }
606 return $line;
607}
608
609
610=head2 _pushback
611
612 Title : _pushback
613 Usage : $io->_pushback($newvalue)
614 Function: Puts a line previously read with _readline back into a buffer.
615 buffer can hold as many lines as system memory permits.
616
617 Note that this is only supported for pushing back data ending with
618 the current, localized value of $/. Using this method to push
619 modified data back onto the buffer stack is not supported; see bug
620 843.
621
622 Args : newvalue
623 Returns : True
624
625=cut
626
627# fix for bug 843, this reveals some unsupported behavior
628
629#sub _pushback {
630# my ($self, $value) = @_;
631# if (index($value, $/) >= 0) {
632# push @{$self->{'_readbuffer'}}, $value;
633# } else {
634# $self->throw("Pushing modifed data back not supported: $value");
635# }
636#}
637
638sub _pushback {
639 my ($self, $value) = @_;
640 return unless $value;
641 unshift @{$self->{'_readbuffer'}}, $value;
642 return 1;
643}
644
645
646=head2 close
647
648 Title : close
649 Usage : $io->close()
650 Function: Closes the file handle associated with this IO instance,
651 excepted if -noclose was specified.
652 Args : None
653 Returns : True
654
655=cut
656
657sub close {
658 my ($self) = @_;
659
660 # do not close if we explicitly asked not to
661 return if $self->noclose;
662
663 if( defined( my $fh = $self->{'_filehandle'} )) {
664 $self->flush;
665 return if ref $fh eq 'GLOB' && (
666 \*STDOUT == $fh || \*STDERR == $fh || \*STDIN == $fh
667 );
668
669 # don't close IO::Strings
670 CORE::close $fh unless ref $fh && $fh->isa('IO::String');
671 }
672 $self->{'_filehandle'} = undef;
673 delete $self->{'_readbuffer'};
674 return 1;
675}
676
677
678=head2 flush
679
680 Title : flush
681 Usage : $io->flush()
682 Function: Flushes the filehandle
683 Args : None
684 Returns : True
685
686=cut
687
688sub flush {
689 my ($self) = shift;
690
691 if( !defined $self->{'_filehandle'} ) {
692 $self->throw("Flush failed: no filehandle was active");
693 }
694
695 if( ref($self->{'_filehandle'}) =~ /GLOB/ ) {
696 my $oldh = select($self->{'_filehandle'});
697 $| = 1;
698 select($oldh);
699 } else {
700 $self->{'_filehandle'}->flush();
701 }
702 return 1;
703}
704
705
706=head2 noclose
707
708 Title : noclose
709 Usage : $io->noclose($newval)
710 Function: Get or set the NOCLOSE flag - setting this to true will prevent a
711 filehandle from being closed when an object is cleaned up or
712 explicitly closed.
713 Args : Optional new value (a scalar or undef)
714 Returns : Value of noclose (a scalar)
715
716=cut
717
718sub noclose {
719 my $self = shift;
720 return $self->{'_noclose'} = shift if @_;
721 return $self->{'_noclose'};
722}
723
724
725=head2 _io_cleanup
726
727=cut
728
729sub _io_cleanup {
730 my ($self) = @_;
731 $self->close();
732 my $v = $self->verbose;
733
734 # we are planning to cleanup temp files no matter what
735 if ( exists($self->{'_rootio_tempfiles'})
736 and ref($self->{'_rootio_tempfiles'}) =~ /array/i
737 and not $self->save_tempfiles
738 ) {
739 if( $v > 0 ) {
740 warn( "going to remove files ",
741 join(",", @{$self->{'_rootio_tempfiles'}}),
742 "\n");
743 }
744 unlink (@{$self->{'_rootio_tempfiles'}} );
745 }
746 # cleanup if we are not using File::Temp
747 if ( $self->{'_cleanuptempdir'}
748 and exists($self->{'_rootio_tempdirs'})
749 and ref($self->{'_rootio_tempdirs'}) =~ /array/i
750 and not $self->save_tempfiles
751 ) {
752 if( $v > 0 ) {
753 warn( "going to remove dirs ",
754 join(",", @{$self->{'_rootio_tempdirs'}}),
755 "\n");
756 }
757 $self->rmtree( $self->{'_rootio_tempdirs'});
758 }
759}
760
761
762=head2 exists_exe
763
764 Title : exists_exe
765 Usage : $exists = $io->exists_exe('clustalw');
766 $exists = Bio::Root::IO->exists_exe('clustalw')
767 $exists = Bio::Root::IO::exists_exe('clustalw')
768 Function: Determines whether the given executable exists either as file
769 or within the path environment. The latter requires File::Spec
770 to be installed.
771 On Win32-based system, .exe is automatically appended to the program
772 name unless the program name already ends in .exe.
773 Args : Name of the executable
774 Returns : 1 if the given program is callable as an executable, and 0 otherwise
775
776=cut
777
778sub exists_exe {
779 my ($self, $exe) = @_;
780 $self->throw("Must pass a defined value to exists_exe") unless defined $exe;
781 $exe = $self if (!(ref($self) || $exe));
782 $exe .= '.exe' if(($^O =~ /mswin/i) && ($exe !~ /\.(exe|com|bat|cmd)$/i));
783 return $exe if ( -f $exe && -x $exe ); # full path and exists
784
785 # Ewan's comment. I don't think we need this. People should not be
786 # asking for a program with a pathseparator starting it
787 # $exe =~ s/^$PATHSEP//;
788
789 # Not a full path, or does not exist. Let's see whether it's in the path.
790 if($FILESPECLOADED) {
791 for my $dir (File::Spec->path()) {
792 my $f = Bio::Root::IO->catfile($dir, $exe);
793 return $f if( -f $f && -x $f );
794 }
795 }
796 return 0;
797}
798
799
800=head2 tempfile
801
802 Title : tempfile
803 Usage : my ($handle,$tempfile) = $io->tempfile();
804 Function: Create a temporary filename and a handle opened for reading and
805 writing.
806 Caveats: If you do not have File::Temp on your system you should
807 avoid specifying TEMPLATE and SUFFIX.
808 Args : Named parameters compatible with File::Temp: DIR (defaults to
809 $Bio::Root::IO::TEMPDIR), TEMPLATE, SUFFIX.
810 Returns : A 2-element array, consisting of temporary handle and temporary
811 file name.
812
813=cut
814
815sub tempfile {
816 my ($self, @args) = @_;
817 my ($tfh, $file);
818 my %params = @args;
819
820 # map between naming with and without dash
821 for my $key (keys(%params)) {
822 if( $key =~ /^-/ ) {
823 my $v = $params{$key};
824 delete $params{$key};
825 $params{uc(substr($key,1))} = $v;
826 } else {
827 # this is to upper case
828 my $v = $params{$key};
829 delete $params{$key};
830 $params{uc($key)} = $v;
831 }
832 }
833 $params{'DIR'} = $TEMPDIR if(! exists($params{'DIR'}));
834 unless (exists $params{'UNLINK'} &&
835 defined $params{'UNLINK'} &&
836 ! $params{'UNLINK'} ) {
837 $params{'UNLINK'} = 1;
838 } else {
839 $params{'UNLINK'} = 0;
840 }
841
842 if($FILETEMPLOADED) {
843 if(exists($params{'TEMPLATE'})) {
844 my $template = $params{'TEMPLATE'};
845 delete $params{'TEMPLATE'};
846 ($tfh, $file) = File::Temp::tempfile($template, %params);
847 } else {
848 ($tfh, $file) = File::Temp::tempfile(%params);
849 }
850 } else {
851 my $dir = $params{'DIR'};
852 $file = $self->catfile(
853 $dir,
854 (exists($params{'TEMPLATE'}) ?
855 $params{'TEMPLATE'} :
856 sprintf( "%s.%s.%s", $ENV{USER} || 'unknown', $$, $TEMPCOUNTER++))
857 );
858
859 # sneakiness for getting around long filenames on Win32?
860 if( $HAS_WIN32 ) {
861 $file = Win32::GetShortPathName($file);
862 }
863
864 # Try to make sure this will be marked close-on-exec
865 # XXX: Win32 doesn't respect this, nor the proper fcntl,
866 # but may have O_NOINHERIT. This may or may not be in Fcntl.
867 local $^F = 2;
868 # Store callers umask
869 my $umask = umask();
870 # Set a known umaskr
871 umask(066);
872 # Attempt to open the file
873 if ( sysopen($tfh, $file, $OPENFLAGS, 0600) ) {
874 # Reset umask
875 umask($umask);
876 } else {
877 $self->throw("Could not write temporary file '$file': $!");
878 }
879 }
880
881 if( $params{'UNLINK'} ) {
882 push @{$self->{'_rootio_tempfiles'}}, $file;
883 }
884
885 return wantarray ? ($tfh,$file) : $tfh;
886}
887
888
889=head2 tempdir
890
891 Title : tempdir
892 Usage : my ($tempdir) = $io->tempdir(CLEANUP=>1);
893 Function: Creates and returns the name of a new temporary directory.
894
895 Note that you should not use this function for obtaining "the"
896 temp directory. Use $Bio::Root::IO::TEMPDIR for that. Calling this
897 method will in fact create a new directory.
898
899 Args : args - ( key CLEANUP ) indicates whether or not to cleanup
900 dir on object destruction, other keys as specified by File::Temp
901 Returns : The name of a new temporary directory.
902
903=cut
904
905sub tempdir {
906 my ($self, @args) = @_;
907 if ($FILETEMPLOADED && File::Temp->can('tempdir')) {
908 return File::Temp::tempdir(@args);
909 }
910
911 # we have to do this ourselves, not good
912 # we are planning to cleanup temp files no matter what
913 my %params = @args;
914 print "cleanup is " . $params{CLEANUP} . "\n";
915 $self->{'_cleanuptempdir'} = ( defined $params{CLEANUP} &&
916 $params{CLEANUP} == 1);
917 my $tdir = $self->catfile( $TEMPDIR,
918 sprintf("dir_%s-%s-%s",
919 $ENV{USER} || 'unknown',
920 $$,
921 $TEMPCOUNTER++));
922 mkdir($tdir, 0755);
923 push @{$self->{'_rootio_tempdirs'}}, $tdir;
924 return $tdir;
925}
926
927
928=head2 catfile
929
930 Title : catfile
931 Usage : $path = Bio::Root::IO->catfile(@dirs, $filename);
932 Function: Constructs a full pathname in a cross-platform safe way.
933
934 If File::Spec exists on your system, this routine will merely
935 delegate to it. Otherwise it tries to make a good guess.
936
937 You should use this method whenever you construct a path name
938 from directory and filename. Otherwise you risk cross-platform
939 compatibility of your code.
940
941 You can call this method both as a class and an instance method.
942
943 Args : components of the pathname (directories and filename, NOT an
944 extension)
945 Returns : a string
946
947=cut
948
949sub catfile {
950 my ($self, @args) = @_;
951
952 return File::Spec->catfile(@args) if $FILESPECLOADED;
953 # this is clumsy and not very appealing, but how do we specify the
954 # root directory?
955 if($args[0] eq '/') {
956 $args[0] = $ROOTDIR;
957 }
958 return join($PATHSEP, @args);
959}
960
961
962=head2 rmtree
963
964 Title : rmtree
965 Usage : Bio::Root::IO->rmtree($dirname );
966 Function: Remove a full directory tree
967
968 If File::Path exists on your system, this routine will merely
969 delegate to it. Otherwise it runs a local version of that code.
970
971 You should use this method to remove directories which contain
972 files.
973
974 You can call this method both as a class and an instance method.
975
976 Args : roots - rootdir to delete or reference to list of dirs
977
978 verbose - a boolean value, which if TRUE will cause
979 C<rmtree> to print a message each time it
980 examines a file, giving the name of the file, and
981 indicating whether it's using C<rmdir> or
982 C<unlink> to remove it, or that it's skipping it.
983 (defaults to FALSE)
984
985 safe - a boolean value, which if TRUE will cause C<rmtree>
986 to skip any files to which you do not have delete
987 access (if running under VMS) or write access (if
988 running under another OS). This will change in the
989 future when a criterion for 'delete permission'
990 under OSs other than VMS is settled. (defaults to
991 FALSE)
992 Returns : number of files successfully deleted
993
994=cut
995
996# taken straight from File::Path VERSION = "1.0403"
997sub rmtree {
998 my ($self, $roots, $verbose, $safe) = @_;
999 if ( $FILEPATHLOADED ) {
1000 return File::Path::rmtree ($roots, $verbose, $safe);
1001 }
1002
1003 my $force_writable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' ||
1004 $^O eq 'amigaos' || $^O eq 'cygwin');
1005 my $Is_VMS = $^O eq 'VMS';
1006
1007 my @files;
1008 my $count = 0;
1009 $verbose ||= 0;
1010 $safe ||= 0;
1011 if ( defined($roots) && length($roots) ) {
1012 $roots = [$roots] unless ref $roots;
1013 } else {
1014 $self->warn("No root path(s) specified\n");
1015 return 0;
1016 }
1017
1018 my $root;
1019 for $root (@{$roots}) {
1020 $root =~ s#/\z##;
1021 (undef, undef, my $rp) = lstat $root or next;
1022 $rp &= 07777; # don't forget setuid, setgid, sticky bits
1023 if ( -d _ ) {
1024 # notabene: 0777 is for making readable in the first place,
1025 # it's also intended to change it to writable in case we have
1026 # to recurse in which case we are better than rm -rf for
1027 # subtrees with strange permissions
1028 chmod(0777, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
1029 or $self->warn("Could not make directory '$root' read+writable: $!")
1030 unless $safe;
1031 if (opendir DIR, $root){
1032 @files = readdir DIR;
1033 closedir DIR;
1034 } else {
1035 $self->warn("Could not read directory '$root': $!");
1036 @files = ();
1037 }
1038
1039 # Deleting large numbers of files from VMS Files-11 filesystems
1040 # is faster if done in reverse ASCIIbetical order
1041 @files = reverse @files if $Is_VMS;
1042 ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS;
1043 @files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files);
1044 $count += $self->rmtree([@files],$verbose,$safe);
1045 if ($safe &&
1046 ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
1047 print "skipped '$root'\n" if $verbose;
1048 next;
1049 }
1050 chmod 0777, $root
1051 or $self->warn("Could not make directory '$root' writable: $!")
1052 if $force_writable;
1053 print "rmdir '$root'\n" if $verbose;
1054 if (rmdir $root) {
1055 ++$count;
1056 }
1057 else {
1058 $self->warn("Could not remove directory '$root': $!");
1059 chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
1060 or $self->warn("and can't restore permissions to "
1061 . sprintf("0%o",$rp) . "\n");
1062 }
1063 }
1064 else {
1065 if ( $safe
1066 and ($Is_VMS ? !&VMS::Filespec::candelete($root)
1067 : !(-l $root || -w $root))
1068 ) {
1069 print "skipped '$root'\n" if $verbose;
1070 next;
1071 }
1072 chmod 0666, $root
1073 or $self->warn( "Could not make file '$root' writable: $!")
1074 if $force_writable;
1075 warn "unlink '$root'\n" if $verbose;
1076 # delete all versions under VMS
1077 for (;;) {
1078 unless (unlink $root) {
1079 $self->warn("Could not unlink file '$root': $!");
1080 if ($force_writable) {
1081 chmod $rp, $root
1082 or $self->warn("and can't restore permissions to "
1083 . sprintf("0%o",$rp) . "\n");
1084 }
1085 last;
1086 }
1087 ++$count;
1088 last unless $Is_VMS && lstat $root;
1089 }
1090 }
1091 }
1092
1093 return $count;
1094}
1095
1096
1097=head2 _flush_on_write
1098
1099 Title : _flush_on_write
1100 Usage : $io->_flush_on_write($newval)
1101 Function: Boolean flag to indicate whether to flush
1102 the filehandle on writing when the end of
1103 a component is finished (Sequences, Alignments, etc)
1104 Args : Optional new value
1105 Returns : Value of _flush_on_write
1106
1107=cut
1108
1109sub _flush_on_write {
1110 my ($self, $value) = @_;
1111 if (defined $value) {
1112 $self->{'_flush_on_write'} = $value;
1113 }
1114 return $self->{'_flush_on_write'};
1115}
1116
1117
1118=head2 save_tempfiles
1119
1120 Title : save_tempfiles
1121 Usage : $io->save_tempfiles(1)
1122 Function: Boolean flag to indicate whether to retain tempfiles/tempdir
1123 Args : Value evaluating to TRUE or FALSE
1124 Returns : Boolean value : 1 = save tempfiles/tempdirs, 0 = remove (default)
1125
1126=cut
1127
1128sub save_tempfiles {
1129 my $self = shift;
1130 if (@_) {
1131 my $value = shift;
1132 $self->{save_tempfiles} = $value ? 1 : 0;
1133 }
1134 return $self->{save_tempfiles} || 0;
1135}
1136
1137
113816µs1;
 
# spent 7µs within Bio::Root::IO::CORE:match which was called 3 times, avg 2µs/call: # 2 times (1µs+0s) by Bio::Root::IO::BEGIN@75 at line 102, avg 550ns/call # once (6µs+0s) by Bio::Root::IO::BEGIN@75 at line 93
sub Bio::Root::IO::CORE:match; # opcode