← Back to branch summary

~ubuntu-branches/ubuntu/raring/bioperl/raring

« back to all changes in this revision

Viewing changes to Bio/Root/IO.pm

  • Committer: Bazaar Package Importer
  • Author(s): Charles Plessy
  • Date: 2008-03-18 14:44:57 UTC
  • mfrom: (4 hardy)
  • mto: This revision was merged to the branch mainline in revision 6.
  • Revision ID: james.westby@ubuntu.com-20080318144457-1jjoztrvqwf0gruk
http://bugs.debian.org/448890
* debian/control:
  - Removed MIA Matt Hope (dopey) from the Uploaders field.
    Thank you for your work, Matt. I hope you are doing well.
  - Downgraded some recommended package to the 'Suggests' priority,
    according to the following discussion on Upstream's mail list.
    http://bioperl.org/pipermail/bioperl-l/2008-March/027379.html
    (Closes: #448890)
* debian/copyright converted to machine-readable format.

Show diffs side-by-side

added added

removed removed

Lines of Context:
Bio/Root/IO.pm
1
 
# $Id: IO.pm,v 1.50 2003/11/21 03:03:38 lstein Exp $
 
1
# $Id: IO.pm,v 1.61.4.1 2006/10/02 23:10:23 sendu Exp $
2
2
#
3
3
# BioPerl module for Bio::Root::IO
4
4
#
70
70
 to one of the Bioperl mailing lists.
71
71
Your participation is much appreciated.
72
72
 
73
 
  bioperl-l@bioperl.org                 - General discussion
74
 
  http://bio.perl.org/MailList.html             - About the mailing lists
 
73
  bioperl-l@bioperl.org                  - General discussion
 
74
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
75
75
 
76
76
=head2 Reporting Bugs
77
77
 
78
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:
 
79
the bugs and their resolution.  Bug reports can be submitted via the
 
80
web:
81
81
 
82
 
  bioperl-bugs@bio.perl.org
83
 
  http://bugzilla.bioperl.org/
 
82
  http://bugzilla.open-bio.org/
84
83
 
85
84
=head1 AUTHOR - Hilmar Lapp
86
85
 
87
86
Email hlapp@gmx.net
88
87
 
89
 
Describe contact details here
90
 
 
91
88
=head1 APPENDIX
92
89
 
93
90
The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _
99
96
 
100
97
 
101
98
package Bio::Root::IO;
102
 
use vars qw(@ISA $FILESPECLOADED $FILETEMPLOADED $FILEPATHLOADED
103
 
            $TEMPDIR $PATHSEP $ROOTDIR $OPENFLAGS $VERBOSE);
 
99
use vars qw($FILESPECLOADED $FILETEMPLOADED $FILEPATHLOADED
 
100
            $TEMPDIR $PATHSEP $ROOTDIR $OPENFLAGS $VERBOSE $ONMAC
 
101
            $HAS_LWP
 
102
           );
104
103
use strict;
105
104
 
106
105
use Symbol;
107
106
use POSIX qw(dup);
108
107
use IO::Handle;
109
 
use Bio::Root::Root;
 
108
use Bio::Root::HTTPget;
110
109
 
111
 
@ISA = qw(Bio::Root::Root);
 
110
use base qw(Bio::Root::Root);
112
111
 
113
112
my $TEMPCOUNTER;
114
113
my $HAS_WIN32 = 0;
 
114
#my $HAS_LWP = 1;
115
115
 
116
116
BEGIN {
117
117
    $TEMPCOUNTER = 0;
118
118
    $FILESPECLOADED = 0;
119
119
    $FILETEMPLOADED = 0;
120
120
    $FILEPATHLOADED = 0;
121
 
    $VERBOSE = 1;
 
121
    $VERBOSE = 0;
122
122
 
123
123
    # try to load those modules that may cause trouble on some systems
124
124
    eval { 
130
130
        # do nothing
131
131
    }
132
132
 
 
133
    eval {
 
134
        require LWP::Simple;
 
135
    };
 
136
    if( $@ ) {
 
137
        print STDERR "Cannot load LWP::Simple: $@" if( $VERBOSE > 0 );
 
138
        $HAS_LWP = 0;
 
139
    } else {
 
140
        $HAS_LWP = 1;
 
141
    }
133
142
 
134
143
    # If on Win32, attempt to find Win32 package
135
144
 
192
201
            $OPENFLAGS |= $bit if eval { $bit = &$func(); 1 };
193
202
        }
194
203
    }
 
204
    $ONMAC = "\015" eq "\n";
195
205
}
196
206
 
197
207
=head2 new
222
232
 
223
233
           Currently recognizes the following named parameters:
224
234
              -file     name of file to open
 
235
              -url      name of URL to open
225
236
              -input    name of file, or GLOB, or IO::Handle object
226
237
              -fh       file handle (mutually exclusive with -file)
227
238
              -flush    boolean flag to autoflush after each write
238
249
 
239
250
    $self->_register_for_cleanup(\&_io_cleanup);
240
251
 
241
 
    my ($input, $noclose, $file, $fh, $flush) = $self->_rearrange([qw(INPUT 
 
252
    my ($input, $noclose, $file, $fh, $flush, $url) = $self->_rearrange([qw(INPUT 
242
253
                                                            NOCLOSE
243
254
                                                            FILE FH 
244
 
                                                            FLUSH)], @args);
245
 
    
 
255
                                                            FLUSH URL)], @args);
 
256
 
 
257
    if($url){
 
258
      my $trymax = 5;
 
259
 
 
260
      if($HAS_LWP){ #use LWP::Simple::getstore()
 
261
        require LWP::Simple;
 
262
        #$self->warn("has lwp");
 
263
        my $http_result;
 
264
        my($handle,$tempfile) = $self->tempfile();
 
265
        close($handle);
 
266
 
 
267
        for(my $try = 1 ; $try <= $trymax ; $try++){
 
268
          $http_result = LWP::Simple::getstore($url, $tempfile);
 
269
          $self->warn("[$try/$trymax] tried to fetch $url, but server threw $http_result.  retrying...") if $http_result != 200;
 
270
          last if $http_result == 200;
 
271
        }
 
272
        $self->throw("failed to fetch $url, server threw $http_result") if $http_result != 200;
 
273
 
 
274
        $input = $tempfile;
 
275
        $file  = $tempfile;
 
276
      } else { #use Bio::Root::HTTPget
 
277
        #$self->warn("no lwp");
 
278
 
 
279
        $fh = Bio::Root::HTTPget->getFH($url);
 
280
      }
 
281
    }
 
282
 
246
283
    delete $self->{'_readbuffer'};
247
284
    delete $self->{'_filehandle'};
248
285
    $self->noclose( $noclose) if defined $noclose;
322
359
    my ($obj, @arg) = @_;
323
360
        my %param = @arg;
324
361
    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'){
 
362
    
 
363
    # Previous system of:
 
364
    #  my $iotest = new IO::Handle;
 
365
    #  $iotest->fdopen( dup(fileno($fh)) , 'r' );
 
366
    #  if ($iotest->error == 0) { ... }
 
367
    # didn't actually seem to work under any platform, since there would no
 
368
    # no error if the filehandle had been opened writable only. Couldn't be
 
369
    # hacked around when dealing with unseekable (piped) filehandles.
 
370
    #
 
371
    # Just try and do a simple readline, turning io warnings off, instead:
 
372
    
 
373
    my $fh = $obj->_fh || return '?';
 
374
    
 
375
    no warnings "io"; # we expect a warning if this is writable only
 
376
    my $line = <$fh>;
 
377
    if (defined $line) {
 
378
        $obj->_pushback($line);
348
379
        $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'} = '?';
 
380
    }
 
381
    else {
 
382
        $obj->{'_mode'} = 'w';
 
383
    }
 
384
    
371
385
    return $obj->{'_mode'};
372
386
}
373
387
 
397
411
 Usage   : $obj->_print(@lines)
398
412
 Function:
399
413
 Example :
400
 
 Returns : writes output
 
414
 Returns : 1 on success, undef on failure
401
415
 
402
416
=cut
403
417
 
404
418
sub _print {
405
419
    my $self = shift;
406
420
    my $fh = $self->_fh() || \*STDOUT;
407
 
    print $fh @_;
 
421
    my $ret = print $fh @_;
 
422
    return $ret;
408
423
}
409
424
 
410
425
=head2 _readline
437
452
 
438
453
    # if the buffer been filled by _pushback then return the buffer
439
454
    # contents, rather than read from the filehandle
440
 
    $line = shift @{$self->{'_readbuffer'}} || <$fh>;
 
455
    if( @{$self->{'_readbuffer'} || [] } ) {
 
456
        $line = shift @{$self->{'_readbuffer'}};
 
457
    } else {
 
458
        $line = <$fh>;
 
459
    }
441
460
 
442
461
    #don't strip line endings if -raw is specified
443
 
    $line =~ s/\r\n/\n/g if( (!$param{-raw}) && (defined $line) );
444
 
 
 
462
    # $line =~ s/\r\n/\n/g if( (!$param{-raw}) && (defined $line) );
 
463
    # Dave Howorth's fix
 
464
    if( (!$param{-raw}) && (defined $line) ) {
 
465
        $line =~ s/\015\012/\012/g; # Change all CR/LF pairs to LF
 
466
        $line =~ tr/\015/\n/ unless $ONMAC; # Change all single CRs to NEWLINE
 
467
    }
445
468
    return $line;
446
469
}
447
470
 
459
482
 
460
483
sub _pushback {
461
484
    my ($obj, $value) = @_;
462
 
 
463
 
        $obj->{'_readbuffer'} ||= [];
464
 
        push @{$obj->{'_readbuffer'}}, $value;
 
485
    return unless $value;
 
486
    push @{$obj->{'_readbuffer'}}, $value;
465
487
}
466
488
 
467
489
=head2 close