160
162
# If on Win32, attempt to find Win32 package
162
164
if($^O =~ /mswin/i) {
169
171
# Try to provide a path separator. Why doesn't File::Spec export this,
170
172
# or did I miss it?
171
173
if($^O =~ /mswin/i) {
173
175
} elsif($^O =~ /macos/i) {
181
$TEMPDIR = File::Spec->tmpdir();
182
$ROOTDIR = File::Spec->rootdir();
183
require File::Temp; # tempfile creation
183
$TEMPDIR = File::Spec->tmpdir();
184
$ROOTDIR = File::Spec->rootdir();
185
require File::Temp; # tempfile creation
187
if(! defined($TEMPDIR)) { # File::Spec failed
189
if (defined $ENV{'TEMPDIR'} && -d $ENV{'TEMPDIR'} ) {
190
$TEMPDIR = $ENV{'TEMPDIR'};
191
} elsif( defined $ENV{'TMPDIR'} && -d $ENV{'TMPDIR'} ) {
192
$TEMPDIR = $ENV{'TMPDIR'};
194
if($^O =~ /mswin/i) {
195
$TEMPDIR = 'C:\TEMP' unless $TEMPDIR;
197
} elsif($^O =~ /macos/i) {
198
$TEMPDIR = "" unless $TEMPDIR; # what is a reasonable default on Macs?
199
$ROOTDIR = ""; # what is reasonable??
201
$TEMPDIR = "/tmp" unless $TEMPDIR;
204
if (!( -d $TEMPDIR && -w $TEMPDIR )) {
205
$TEMPDIR = '.'; # last resort
208
# File::Temp failed (alone, or File::Spec already failed)
210
# determine open flags for tempfile creation -- we'll have to do this
214
$OPENFLAGS = O_CREAT | O_EXCL | O_RDWR;
215
for my $oflag (qw/FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT TEMPORARY/){
216
my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
218
$OPENFLAGS |= $bit if eval { $bit = &$func(); 1 };
189
if(! defined($TEMPDIR)) { # File::Spec failed
191
if (defined $ENV{'TEMPDIR'} && -d $ENV{'TEMPDIR'} ) {
192
$TEMPDIR = $ENV{'TEMPDIR'};
193
} elsif( defined $ENV{'TMPDIR'} && -d $ENV{'TMPDIR'} ) {
194
$TEMPDIR = $ENV{'TMPDIR'};
196
if($^O =~ /mswin/i) {
197
$TEMPDIR = 'C:\TEMP' unless $TEMPDIR;
199
} elsif($^O =~ /macos/i) {
200
$TEMPDIR = "" unless $TEMPDIR; # what is a reasonable default on Macs?
201
$ROOTDIR = ""; # what is reasonable??
203
$TEMPDIR = "/tmp" unless $TEMPDIR;
206
if (!( -d $TEMPDIR && -w $TEMPDIR )) {
207
$TEMPDIR = '.'; # last resort
210
# File::Temp failed (alone, or File::Spec already failed)
212
# determine open flags for tempfile creation -- we'll have to do this
216
$OPENFLAGS = O_CREAT | O_EXCL | O_RDWR;
217
for my $oflag (qw/FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT TEMPORARY/){
218
my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
220
$OPENFLAGS |= $bit if eval { $bit = &$func(); 1 };
221
223
$ONMAC = "\015" eq "\n";
274
277
$self->_register_for_cleanup(\&_io_cleanup);
276
my ($input, $noclose, $file, $fh, $flush, $url,
277
$retries, $ua_parms) =
278
$self->_rearrange([qw(INPUT
279
my ($input, $noclose, $file, $fh, $string, $flush, $url,
280
$retries, $ua_parms) =
281
$self->_rearrange([qw(INPUT NOCLOSE FILE FH STRING FLUSH URL RETRIES UA_PARMS)],
290
if($HAS_LWP){ #use LWP::UserAgent
291
require LWP::UserAgent;
292
my $ua = LWP::UserAgent->new(%$ua_parms);
294
my($handle,$tempfile) = $self->tempfile();
295
CORE::close($handle);
298
for(my $try = 1 ; $try <= $retries ; $try++){
299
$http_result = $ua->get($url, ':content_file' => $tempfile);
300
$self->warn("[$try/$retries] tried to fetch $url, but server threw " . $http_result->code . ". retrying...") if !$http_result->is_success;
301
last if $http_result->is_success;
303
$self->throw("failed to fetch $url, server threw " . $http_result->code) if !$http_result->is_success;
307
} else { #use Bio::Root::HTTPget
308
#$self->warn("no lwp");
310
$fh = Bio::Root::HTTPget->getFH($url);
287
if($HAS_LWP) { #use LWP::UserAgent
288
require LWP::UserAgent;
289
my $ua = LWP::UserAgent->new(%$ua_parms);
291
my($handle,$tempfile) = $self->tempfile();
292
CORE::close($handle);
295
for(my $try = 1 ; $try <= $retries ; $try++){
296
$http_result = $ua->get($url, ':content_file' => $tempfile);
297
$self->warn("[$try/$retries] tried to fetch $url, but server ".
298
"threw ". $http_result->code . ". retrying...")
299
if !$http_result->is_success;
300
last if $http_result->is_success;
302
$self->throw("failed to fetch $url, server threw ".
303
$http_result->code) if !$http_result->is_success;
307
} else { #use Bio::Root::HTTPget
308
#$self->warn("no lwp");
310
$fh = Bio::Root::HTTPget::getFH($url);
314
314
delete $self->{'_readbuffer'};
315
315
delete $self->{'_filehandle'};
316
316
$self->noclose( $noclose) if defined $noclose;
317
317
# determine whether the input is a file(name) or a stream
319
if(ref(\$input) eq "SCALAR") {
320
# we assume that a scalar is a filename
321
if($file && ($file ne $input)) {
322
$self->throw("input file given twice: $file and $input disagree");
325
} elsif(ref($input) &&
326
((ref($input) eq "GLOB") || $input->isa('IO::Handle'))) {
330
# let's be strict for now
331
$self->throw("unable to determine type of input $input: ".
332
"not string and not GLOB");
319
if(ref(\$input) eq "SCALAR") {
320
# we assume that a scalar is a filename
321
if($file && ($file ne $input)) {
322
$self->throw("input file given twice: $file and $input disagree");
325
} elsif(ref($input) &&
326
((ref($input) eq "GLOB") || $input->isa('IO::Handle'))) {
330
# let's be strict for now
331
$self->throw("unable to determine type of input $input: ".
332
"not string and not GLOB");
335
336
if(defined($file) && defined($fh)) {
336
$self->throw("Providing both a file and a filehandle for reading - only one please!");
337
$self->throw("Providing both a file and a filehandle for reading - ".
342
if(defined($file) || defined($fh)) {
343
$self->throw("File or filehandle provided with -string,".
344
" please unset if you are using -string as a file");
346
open($fh, "<", \$string)
339
349
if(defined($file) && ($file ne '')) {
340
$fh = Symbol::gensym();
342
$self->throw("Could not open $file: $!");
345
if ( defined($fh) && !(ref($fh) && ((ref($fh) eq "GLOB") || $fh->isa('IO::Handle') || $fh->isa('IO::String'))) ) {
346
$self->throw("file handle $fh doesn't appear to be a handle");
350
$fh = Symbol::gensym();
351
open ($fh,$file) || $self->throw("Could not open $file: $!");
356
# check filehandle to ensure it's one of:
357
# a GLOB reference, as in: open(my $fh, "myfile");
358
# an IO::Handle or IO::String object
359
# the UNIVERSAL::can added to fix Bug2863
360
unless ( ( ref $fh && ( ref $fh eq 'GLOB' ) )
361
|| ( ref $fh && ( UNIVERSAL::can( $fh, 'can' )
362
&& ( $fh->isa('IO::Handle') || $fh->isa('IO::String') ) ) )
364
$self->throw("file handle $fh doesn't appear to be a handle");
368
binmode $fh, ':raw:eol(LF-Native)';
348
370
$self->_fh($fh) if $fh; # if not provided, defaults to STDIN and STDOUT
484
Usage : $obj->_insert($string,1)
485
Function: Insert some text in a file at the given line number (1-based).
486
Returns : 1 on success
487
Args : string to write in file
488
line number to insert the string at
493
my ($self, $string, $line_num) = @_;
496
$self->throw("Cannot insert text at line $line_num because the minimum".
497
" line number possible is 1");
500
my $file = $self->file;
501
if (not defined $file) {
502
$self->throw('Cannot insert a line in a IO object initialized with ".
503
"anything else than a file.');
505
$file =~ s/^\+?[><]?//; # transform '+>output.ace' into 'output.ace'
506
# Everything that needs to be written is written before we read it
508
# Edit the file in place, line by line (no slurping)
510
local @ARGV = ($file); # input file
511
#local $^I = '~'; # backup file extension, e.g. ~, .bak, .ori
512
local $^I = ''; # no backup file
514
if ($. == $line_num) { # right line for new data
521
# Line number check (again)
522
if ( $. > 0 && $line_num > $. ) {
523
$self->throw("Cannot insert text at line $line_num because there are ".
524
"only $. lines in file $file");
526
# Re-open the file in append mode to be ready to add text at the end of it
527
# when the next _print() statement comes
528
open my $new_fh, ">>$file" or $self->throw("Cannot append to file $file: $!");
530
# If file is empty and we're inserting at line 1, simply append text to file
531
if ( $. == 0 && $line_num == 1 ) {
532
$self->_print($string);
461
540
Title : _readline
539
return if $self->noclose; # don't close if we explictly asked not to
540
if( defined $self->{'_filehandle'} ) {
630
# don't close if we explicitly asked not to
631
return if $self->noclose;
633
if( defined( my $fh = $self->{'_filehandle'} )) {
542
return if( \*STDOUT == $self->_fh ||
543
\*STDERR == $self->_fh ||
544
\*STDIN == $self->_fh
545
); # don't close STDOUT fh
546
if( ! ref($self->{'_filehandle'}) ||
547
! $self->{'_filehandle'}->isa('IO::String') ) {
548
close($self->{'_filehandle'});
635
return if ref $fh eq 'GLOB'
641
# don't close IO::Strings
642
close $fh unless ref $fh && $fh->isa('IO::String');
551
644
$self->{'_filehandle'} = undef;
552
645
delete $self->{'_readbuffer'};
608
701
# we are planning to cleanup temp files no matter what
609
702
if( exists($self->{'_rootio_tempfiles'}) &&
610
ref($self->{'_rootio_tempfiles'}) =~ /array/i &&
703
ref($self->{'_rootio_tempfiles'}) =~ /array/i &&
611
704
!$self->save_tempfiles) {
613
warn( "going to remove files ",
614
join(",", @{$self->{'_rootio_tempfiles'}}), "\n");
616
unlink (@{$self->{'_rootio_tempfiles'}} );
706
warn( "going to remove files ",
707
join(",", @{$self->{'_rootio_tempfiles'}}), "\n");
709
unlink (@{$self->{'_rootio_tempfiles'}} );
618
711
# cleanup if we are not using File::Temp
619
712
if( $self->{'_cleanuptempdir'} &&
620
exists($self->{'_rootio_tempdirs'}) &&
621
ref($self->{'_rootio_tempdirs'}) =~ /array/i &&
622
!$self->save_tempfiles) {
624
warn( "going to remove dirs ",
625
join(",", @{$self->{'_rootio_tempdirs'}}), "\n");
627
$self->rmtree( $self->{'_rootio_tempdirs'});
713
exists($self->{'_rootio_tempdirs'}) &&
714
ref($self->{'_rootio_tempdirs'}) =~ /array/i &&
715
!$self->save_tempfiles) {
717
warn( "going to remove dirs ",
718
join(",", @{$self->{'_rootio_tempdirs'}}), "\n");
720
$self->rmtree( $self->{'_rootio_tempdirs'});
649
742
my ($self, $exe) = @_;
650
$self->throw("Must pass a defined value to exists_exe") unless defined $exe;
743
$self->throw("Must pass a defined value to exists_exe") unless defined $exe;
651
744
$exe = $self if (!(ref($self) || $exe));
652
745
$exe .= '.exe' if(($^O =~ /mswin/i) && ($exe !~ /\.(exe|com|bat|cmd)$/i));
653
return $exe if (-e $exe); # full path and exists
746
return $exe if ( -f $exe && -x $exe ); # full path and exists
655
748
# Ewan's comment. I don't think we need this. People should not be
656
749
# asking for a program with a pathseparator starting it
658
750
# $exe =~ s/^$PATHSEP//;
660
752
# Not a full path, or does not exist. Let's see whether it's in the path.
661
753
if($FILESPECLOADED) {
662
foreach my $dir (File::Spec->path()) {
663
my $f = Bio::Root::IO->catfile($dir, $exe);
664
return $f if(-e $f && -x $f );
754
foreach my $dir (File::Spec->path()) {
755
my $f = Bio::Root::IO->catfile($dir, $exe);
756
return $f if( -f $f && -x $f );
693
785
# map between naming with and without dash
694
786
foreach my $key (keys(%params)) {
696
my $v = $params{$key};
697
delete $params{$key};
698
$params{uc(substr($key,1))} = $v;
700
# this is to upper case
701
my $v = $params{$key};
702
delete $params{$key};
703
$params{uc($key)} = $v;
788
my $v = $params{$key};
789
delete $params{$key};
790
$params{uc(substr($key,1))} = $v;
792
# this is to upper case
793
my $v = $params{$key};
794
delete $params{$key};
795
$params{uc($key)} = $v;
706
798
$params{'DIR'} = $TEMPDIR if(! exists($params{'DIR'}));
707
799
unless (exists $params{'UNLINK'} &&
708
defined $params{'UNLINK'} &&
709
! $params{'UNLINK'} ) {
710
$params{'UNLINK'} = 1;
800
defined $params{'UNLINK'} &&
801
! $params{'UNLINK'} ) {
802
$params{'UNLINK'} = 1;
711
803
} else { $params{'UNLINK'} = 0 }
713
805
if($FILETEMPLOADED) {
714
if(exists($params{'TEMPLATE'})) {
715
my $template = $params{'TEMPLATE'};
716
delete $params{'TEMPLATE'};
717
($tfh, $file) = File::Temp::tempfile($template, %params);
719
($tfh, $file) = File::Temp::tempfile(%params);
722
my $dir = $params{'DIR'};
723
$file = $self->catfile($dir,
724
(exists($params{'TEMPLATE'}) ?
725
$params{'TEMPLATE'} :
727
$ENV{USER} || 'unknown', $$,
730
# sneakiness for getting around long filenames on Win32?
732
$file = Win32::GetShortPathName($file);
735
# Try to make sure this will be marked close-on-exec
736
# XXX: Win32 doesn't respect this, nor the proper fcntl,
737
# but may have O_NOINHERIT. This may or may not be in Fcntl.
739
# Store callers umask
743
# Attempt to open the file
744
if ( sysopen($tfh, $file, $OPENFLAGS, 0600) ) {
748
$self->throw("Could not open tempfile $file: $!\n");
806
if(exists($params{'TEMPLATE'})) {
807
my $template = $params{'TEMPLATE'};
808
delete $params{'TEMPLATE'};
809
($tfh, $file) = File::Temp::tempfile($template, %params);
811
($tfh, $file) = File::Temp::tempfile(%params);
814
my $dir = $params{'DIR'};
815
$file = $self->catfile($dir,
816
(exists($params{'TEMPLATE'}) ?
817
$params{'TEMPLATE'} :
819
$ENV{USER} || 'unknown', $$,
822
# sneakiness for getting around long filenames on Win32?
824
$file = Win32::GetShortPathName($file);
827
# Try to make sure this will be marked close-on-exec
828
# XXX: Win32 doesn't respect this, nor the proper fcntl,
829
# but may have O_NOINHERIT. This may or may not be in Fcntl.
831
# Store callers umask
835
# Attempt to open the file
836
if ( sysopen($tfh, $file, $OPENFLAGS, 0600) ) {
840
$self->throw("Could not open tempfile $file: $!\n");
752
844
if( $params{'UNLINK'} ) {
753
push @{$self->{'_rootio_tempfiles'}}, $file;
845
push @{$self->{'_rootio_tempfiles'}}, $file;
879
971
if ( defined($roots) && length($roots) ) {
880
$roots = [$roots] unless ref $roots;
972
$roots = [$roots] unless ref $roots;
882
$self->warn("No root path(s) specified\n");
974
$self->warn("No root path(s) specified\n");
887
979
foreach $root (@{$roots}) {
889
(undef, undef, my $rp) = lstat $root or next;
890
$rp &= 07777; # don't forget setuid, setgid, sticky bits
892
# notabene: 0777 is for making readable in the first place,
893
# it's also intended to change it to writable in case we have
894
# to recurse in which case we are better than rm -rf for
895
# subtrees with strange permissions
896
chmod(0777, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
897
or $self->warn("Can't make directory $root read+writeable: $!")
899
if (opendir(DIR, $root) ){
900
@files = readdir DIR;
903
$self->warn( "Can't read $root: $!");
907
# Deleting large numbers of files from VMS Files-11 filesystems
908
# is faster if done in reverse ASCIIbetical order
909
@files = reverse @files if $Is_VMS;
910
($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS;
911
@files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files);
912
$count += $self->rmtree([@files],$verbose,$safe);
914
($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
915
print "skipped $root\n" if $verbose;
919
or $self->warn( "Can't make directory $root writeable: $!")
921
print "rmdir $root\n" if $verbose;
926
$self->warn( "Can't remove directory $root: $!");
927
chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
928
or $self->warn("and can't restore permissions to "
929
. sprintf("0%o",$rp) . "\n");
935
($Is_VMS ? !&VMS::Filespec::candelete($root)
936
: !(-l $root || -w $root)))
938
print "skipped $root\n" if $verbose;
942
or $self->warn( "Can't make file $root writeable: $!")
944
warn "unlink $root\n" if $verbose;
945
# delete all versions under VMS
947
unless (unlink $root) {
948
$self->warn( "Can't unlink file $root: $!");
949
if ($force_writeable) {
951
or $self->warn("and can't restore permissions to "
952
. sprintf("0%o",$rp) . "\n");
957
last unless $Is_VMS && lstat $root;
981
(undef, undef, my $rp) = lstat $root or next;
982
$rp &= 07777; # don't forget setuid, setgid, sticky bits
984
# notabene: 0777 is for making readable in the first place,
985
# it's also intended to change it to writable in case we have
986
# to recurse in which case we are better than rm -rf for
987
# subtrees with strange permissions
988
chmod(0777, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
989
or $self->warn("Can't make directory $root read+writable: $!")
991
if (opendir(DIR, $root) ){
992
@files = readdir DIR;
995
$self->warn( "Can't read $root: $!");
999
# Deleting large numbers of files from VMS Files-11 filesystems
1000
# is faster if done in reverse ASCIIbetical order
1001
@files = reverse @files if $Is_VMS;
1002
($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS;
1003
@files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files);
1004
$count += $self->rmtree([@files],$verbose,$safe);
1006
($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
1007
print "skipped $root\n" if $verbose;
1011
or $self->warn( "Can't make directory $root writable: $!")
1013
print "rmdir $root\n" if $verbose;
1018
$self->warn( "Can't remove directory $root: $!");
1019
chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
1020
or $self->warn("and can't restore permissions to "
1021
. sprintf("0%o",$rp) . "\n");
1027
($Is_VMS ? !&VMS::Filespec::candelete($root)
1028
: !(-l $root || -w $root)))
1030
print "skipped $root\n" if $verbose;
1034
or $self->warn( "Can't make file $root writable: $!")
1036
warn "unlink $root\n" if $verbose;
1037
# delete all versions under VMS
1039
unless (unlink $root) {
1040
$self->warn( "Can't unlink file $root: $!");
1041
if ($force_writable) {
1043
or $self->warn("and can't restore permissions to "
1044
. sprintf("0%o",$rp) . "\n");
1049
last unless $Is_VMS && lstat $root;
added
removed
Bio/Root/IO.pm
