Filename | /Users/ap13/perl5/lib/perl5/Bio/Root/IO.pm |
Statements | Executed 41 statements in 4.49ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 7.95ms | 16.2ms | BEGIN@75 | Bio::Root::IO::
1 | 1 | 1 | 2.40ms | 3.91ms | BEGIN@5 | Bio::Root::IO::
1 | 1 | 1 | 806µs | 906µs | BEGIN@4 | Bio::Root::IO::
1 | 1 | 1 | 461µs | 1.10ms | BEGIN@7 | Bio::Root::IO::
1 | 1 | 1 | 17µs | 32µs | BEGIN@3 | Bio::Root::IO::
1 | 1 | 1 | 12µs | 43µs | BEGIN@6 | Bio::Root::IO::
1 | 1 | 1 | 11µs | 26µs | BEGIN@359 | Bio::Root::IO::
1 | 1 | 1 | 10µs | 85µs | BEGIN@8 | Bio::Root::IO::
1 | 1 | 1 | 8µs | 20µs | BEGIN@144 | Bio::Root::IO::
3 | 2 | 1 | 7µs | 7µs | CORE:match (opcode) | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | _fh | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | _flush_on_write | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | _initialize_io | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | _insert | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | _io_cleanup | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | _print | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | _pushback | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | _readline | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | catfile | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | cleanfile | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | close | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | exists_exe | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | file | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | flush | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | format | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | mode | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | new | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | noclose | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | rmtree | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | save_tempfiles | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | tempdir | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | tempfile | Bio::Root::IO::
0 | 0 | 0 | 0s | 0s | variant | Bio::Root::IO::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Bio::Root::IO; | ||||
2 | |||||
3 | 2 | 26µs | 2 | 46µ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 # spent 32µs making 1 call to Bio::Root::IO::BEGIN@3
# spent 14µs making 1 call to strict::import |
4 | 2 | 196µs | 2 | 982µ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 # spent 906µs making 1 call to Bio::Root::IO::BEGIN@4
# spent 77µs making 1 call to Exporter::import |
5 | 2 | 294µs | 2 | 3.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 # spent 3.91ms making 1 call to Bio::Root::IO::BEGIN@5
# spent 20µs making 1 call to Exporter::import |
6 | 2 | 27µs | 2 | 74µ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 # spent 43µs making 1 call to Bio::Root::IO::BEGIN@6
# spent 31µs making 1 call to Exporter::import |
7 | 2 | 157µs | 2 | 1.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 # spent 1.10ms making 1 call to Bio::Root::IO::BEGIN@7
# spent 253µs making 1 call to Exporter::import |
8 | 2 | 414µs | 2 | 85µ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 # 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 | |||||
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 | =cut | ||||
65 | |||||
66 | 1 | 300ns | our ($FILESPECLOADED, $FILETEMPLOADED, | ||
67 | $FILEPATHLOADED, $TEMPDIR, | ||||
68 | $PATHSEP, $ROOTDIR, | ||||
69 | $OPENFLAGS, $VERBOSE, | ||||
70 | $ONMAC, $HAS_EOL, ); | ||||
71 | |||||
72 | 1 | 100ns | my $TEMPCOUNTER; | ||
73 | 1 | 300ns | my $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 | ||||
76 | 12 | 23µs | $TEMPCOUNTER = 0; | ||
77 | $FILESPECLOADED = 0; | ||||
78 | $FILETEMPLOADED = 0; | ||||
79 | $FILEPATHLOADED = 0; | ||||
80 | $VERBOSE = 0; | ||||
81 | |||||
82 | # try to load those modules that may cause trouble on some systems | ||||
83 | 2 | 83µs | eval { | ||
84 | require File::Path; | ||||
85 | $FILEPATHLOADED = 1; | ||||
86 | }; | ||||
87 | 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 | ||||
93 | 1 | 6µ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? | ||||
102 | 1 | 800ns | 2 | 1µ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 | ||||
107 | $PATHSEP = "/"; | ||||
108 | } | ||||
109 | 6 | 109µs | eval { | ||
110 | require File::Spec; | ||||
111 | $FILESPECLOADED = 1; | ||||
112 | 1 | 99µs | $TEMPDIR = File::Spec->tmpdir(); # spent 99µs making 1 call to File::Spec::Unix::tmpdir | ||
113 | 1 | 2µs | $ROOTDIR = File::Spec->rootdir(); # spent 2µs making 1 call to File::Spec::Unix::rootdir | ||
114 | require File::Temp; # tempfile creation | ||||
115 | $FILETEMPLOADED = 1; | ||||
116 | }; | ||||
117 | 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); | ||||
144 | 2 | 73µs | 2 | 32µ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 # 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 | } | ||||
148 | $ONMAC = "\015" eq "\n"; | ||||
149 | 1 | 660µs | 1 | 16.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 | |||||
162 | sub 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 | |||||
194 | sub _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 | |||||
307 | sub _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 | |||||
333 | sub 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 | ||||
359 | 2 | 2.42ms | 2 | 40µ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 # 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 | |||||
392 | sub 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 | |||||
412 | sub 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 | |||||
429 | sub 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 | |||||
451 | sub 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 | |||||
481 | sub _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 | |||||
500 | sub _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 | |||||
585 | sub _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 | |||||
638 | sub _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 | |||||
657 | sub 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 | |||||
688 | sub 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 | |||||
718 | sub 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 | |||||
729 | sub _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 | |||||
778 | sub 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 | |||||
815 | sub 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 | |||||
905 | sub 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 | |||||
949 | sub 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" | ||||
997 | sub 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 | |||||
1109 | sub _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 | |||||
1128 | sub 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 | |||||
1138 | 1 | 6µs | 1; | ||
sub Bio::Root::IO::CORE:match; # opcode |