Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

I christen thee "bioperl-dev". Bless her and all who sail in her.

svn path=/bioperl-dev/trunk/; revision=15616
  • Loading branch information...
commit 67ab47d28c44e179c6be6a3c5320ab73a5822456 0 parents
maj authored
Showing with 18,383 additions and 0 deletions.
  1. +7 −0 AUTHORS
  2. +1,205 −0 Bio/Root/Build.pm
  3. +471 −0 Bio/Root/Exception.pm
  4. +392 −0 Bio/Root/HTTPget.pm
  5. +983 −0 Bio/Root/IO.pm
  6. +451 −0 Bio/Root/Root.pm
  7. +762 −0 Bio/Root/RootI.pm
  8. +624 −0 Bio/Root/Storable.pm
  9. +519 −0 Bio/Root/Test.pm
  10. +141 −0 Bio/Root/Test/Warn.pm
  11. +1,351 −0 Bio/Root/Utilities.pm
  12. +119 −0 Bio/Root/Version.pm
  13. +81 −0 Build.PL
  14. +30 −0 Changes
  15. +49 −0 INSTALL
  16. +1 −0  INSTALL.SKIP
  17. +812 −0 LICENSE
  18. +39 −0 README
  19. +551 −0 t/lib/Array/Compare.pm
  20. +741 −0 t/lib/Error.pm
  21. +246 −0 t/lib/Sub/Uplevel.pm
  22. +1,749 −0 t/lib/Test/Builder.pm
  23. +182 −0 t/lib/Test/Builder/Module.pm
  24. +639 −0 t/lib/Test/Builder/Tester.pm
  25. +50 −0 t/lib/Test/Builder/Tester/Color.pm
  26. +433 −0 t/lib/Test/Exception.pm
  27. +1,169 −0 t/lib/Test/Harness.pm
  28. +64 −0 t/lib/Test/Harness/Assert.pm
  29. +70 −0 t/lib/Test/Harness/Iterator.pm
  30. +143 −0 t/lib/Test/Harness/Point.pm
  31. +171 −0 t/lib/Test/Harness/Results.pm
  32. +647 −0 t/lib/Test/Harness/Straps.pm
  33. +492 −0 t/lib/Test/Harness/TAP.pod
  34. +133 −0 t/lib/Test/Harness/Util.pm
  35. +1,547 −0 t/lib/Test/More.pm
  36. +229 −0 t/lib/Test/Simple.pm
  37. +603 −0 t/lib/Test/Tutorial.pod
  38. +487 −0 t/lib/Test/Warn.pm
7 AUTHORS
@@ -0,0 +1,7 @@
+=head1 CONTRIBUTORS TO BIOPERL-DEV
+
+=over
+
+=item * Mark A. Jensen <maj at fortinbras.us>
+
+=back
1,205 Bio/Root/Build.pm
@@ -0,0 +1,1205 @@
+#!/usr/bin/perl -w
+
+# $Id: Build.pm 15549 2009-02-21 00:48:48Z maj $
+#
+# BioPerl module for Bio::Root::Build
+#
+# Please direct questions and support issues to <bioperl-l@bioperl.org>
+#
+# Cared for by Sendu Bala <bix@sendu.me.uk>
+#
+# Copyright Sendu Bala
+#
+# You may distribute this module under the same terms as perl itself
+
+# POD documentation - main docs before the code
+
+=head1 NAME
+
+Bio::Root::Build - A common Module::Build subclass base for BioPerl distributions
+
+=head1 SYNOPSIS
+
+ ...TO BE ADDED
+
+=head1 DESCRIPTION
+
+This is a subclass of Module::Build so we can override certain methods and do
+fancy stuff
+
+It was first written against Module::Build::Base v0.2805. Many of the methods
+here are copy/pasted from there in their entirety just to change one or two
+minor things, since for the most part Module::Build::Base code is hard to
+cleanly override.
+
+=head1 FEEDBACK
+
+=head2 Mailing Lists
+
+User feedback is an integral part of the evolution of this and other
+Bioperl modules. Send your comments and suggestions preferably to
+the Bioperl mailing list. Your participation is much appreciated.
+
+ bioperl-l@bioperl.org - General discussion
+ http://bioperl.org/wiki/Mailing_lists - About the mailing lists
+
+=head2 Support
+
+Please direct usage questions or support issues to the mailing list:
+
+L<bioperl-l@bioperl.org>
+
+rather than to the module maintainer directly. Many experienced and
+reponsive experts will be able look at the problem and quickly
+address it. Please include a thorough description of the problem
+with code and data examples if at all possible.
+
+=head2 Reporting Bugs
+
+Report bugs to the Bioperl bug tracking system to help us keep track
+of the bugs and their resolution. Bug reports can be submitted via
+the web:
+
+ http://bugzilla.open-bio.org/
+
+=head1 AUTHOR - Sendu Bala
+
+Email bix@sendu.me.uk
+
+=head1 APPENDIX
+
+The rest of the documentation details each of the object methods.
+Internal methods are usually preceded with a _
+
+=cut
+
+package Bio::Root::Build;
+
+BEGIN {
+ # we really need Module::Build to be installed
+ unless (eval "use Module::Build 0.2805; 1") {
+ print "This package requires Module::Build v0.2805 or greater to install itself.\n";
+
+ require ExtUtils::MakeMaker;
+ my $yn = ExtUtils::MakeMaker::prompt(' Install Module::Build now from CPAN?', 'y');
+
+ unless ($yn =~ /^y/i) {
+ die " *** Cannot install without Module::Build. Exiting ...\n";
+ }
+
+ require Cwd;
+ require File::Spec;
+ require File::Copy;
+ require CPAN;
+
+ # Save this because CPAN will chdir all over the place.
+ my $cwd = Cwd::cwd();
+
+ my $build_pl = File::Spec->catfile($cwd, "Build.PL");
+
+ File::Copy::move($build_pl, $build_pl."hidden"); # avoid bizarre bug with Module::Build tests using the wrong Build.PL if it happens to be in PERL5LIB
+ CPAN::Shell->install('Module::Build');
+ File::Copy::move($build_pl."hidden", $build_pl);
+ CPAN::Shell->expand("Module", "Module::Build")->uptodate or die "Couldn't install Module::Build, giving up.\n";
+
+ chdir $cwd or die "Cannot chdir() back to $cwd: $!\n\n***\nInstallation will probably work fine if you now quit CPAN and try again.\n***\n\n";
+ }
+
+ eval "use base Module::Build; 1" or die $@;
+
+ # ensure we'll be able to reload this module later by adding its path to inc
+ use Cwd;
+ use lib Cwd::cwd();
+}
+
+use strict;
+use warnings;
+
+our $VERSION = '1.006900'; # pre-1.7
+our @extra_types = qw(options excludes_os feature_requires test); # test must always be last in the list!
+our $checking_types = "requires|conflicts|".join("|", @extra_types);
+
+
+# our modules are in Bio, not lib
+sub find_pm_files {
+ my $self = shift;
+ foreach my $pm (@{$self->rscan_dir('Bio', qr/\.pm$/)}) {
+ $self->{properties}{pm_files}->{$pm} = File::Spec->catfile('lib', $pm);
+ }
+
+ $self->_find_file_by_type('pm', 'lib');
+}
+
+# ask what scripts to install (this method is unique to bioperl)
+sub choose_scripts {
+ my $self = shift;
+ my $accept = shift;
+
+ # we can offer interactive installation by groups only if we have subdirs
+ # in scripts and no .PLS files there
+ opendir(my $scripts_dir, 'scripts') or die "Can't open directory 'scripts': $!\n";
+ my $int_ok = 0;
+ my @group_dirs;
+ while (my $thing = readdir($scripts_dir)) {
+ next if $thing =~ /^\./;
+ next if $thing eq 'CVS';
+ if ($thing =~ /PLS$|pl$/) {
+ $int_ok = 0;
+ last;
+ }
+ $thing = File::Spec->catfile('scripts', $thing);
+ if (-d $thing) {
+ $int_ok = 1;
+ push(@group_dirs, $thing);
+ }
+ }
+ closedir($scripts_dir);
+ my $question = $int_ok ? "Install [a]ll BioPerl scripts, [n]one, or choose groups [i]nteractively?" : "Install [a]ll BioPerl scripts or [n]one?";
+
+ my $prompt = $accept ? 'a' : $self->prompt($question, 'a');
+
+ if ($prompt =~ /^[aA]/) {
+ $self->log_info(" - will install all scripts\n");
+ $self->notes(chosen_scripts => 'all');
+ }
+ elsif ($prompt =~ /^[iI]/) {
+ $self->log_info(" - will install interactively:\n");
+
+ my @chosen_scripts;
+ foreach my $group_dir (@group_dirs) {
+ my $group = File::Basename::basename($group_dir);
+ print " * group '$group' has:\n";
+
+ my @script_files = @{$self->rscan_dir($group_dir, qr/\.PLS$|\.pl$/)};
+ foreach my $script_file (@script_files) {
+ my $script = File::Basename::basename($script_file);
+ print " $script\n";
+ }
+
+ my $result = $self->prompt(" Install scripts for group '$group'? [y]es [n]o [q]uit", 'n');
+ die if $result =~ /^[qQ]/;
+ if ($result =~ /^[yY]/) {
+ $self->log_info(" + will install group '$group'\n");
+ push(@chosen_scripts, @script_files);
+ }
+ else {
+ $self->log_info(" - will not install group '$group'\n");
+ }
+ }
+
+ my $chosen_scripts = @chosen_scripts ? join("|", @chosen_scripts) : 'none';
+
+ $self->notes(chosen_scripts => $chosen_scripts);
+ }
+ else {
+ $self->log_info(" - won't install any scripts\n");
+ $self->notes(chosen_scripts => 'none');
+ }
+
+ print "\n";
+}
+
+# our version of script_files doesn't take args but just installs those scripts
+# requested by the user after choose_scripts() is called. If it wasn't called,
+# installs all scripts in scripts directory
+sub script_files {
+ my $self = shift;
+
+ unless (-d 'scripts') {
+ return {};
+ }
+
+ my $chosen_scripts = $self->notes('chosen_scripts');
+ if ($chosen_scripts) {
+ return if $chosen_scripts eq 'none';
+ return { map {$_, 1} split(/\|/, $chosen_scripts) } unless $chosen_scripts eq 'all';
+ }
+
+ return $_ = { map {$_,1} @{$self->rscan_dir('scripts', qr/\.PLS$|\.pl$/)} };
+}
+
+# process scripts normally, except that we change name from *.PLS to bp_*.pl
+sub process_script_files {
+ my $self = shift;
+ my $files = $self->find_script_files;
+ return unless keys %$files;
+
+ my $script_dir = File::Spec->catdir($self->blib, 'script');
+ File::Path::mkpath( $script_dir );
+
+ foreach my $file (keys %$files) {
+ my $result = $self->copy_if_modified($file, $script_dir, 'flatten') or next;
+ $self->fix_shebang_line($result) unless $self->os_type eq 'VMS';
+ $self->make_executable($result);
+
+ my $final = File::Basename::basename($result);
+ $final =~ s/\.PLS$/\.pl/; # change from .PLS to .pl
+ $final =~ s/^/bp_/ unless $final =~ /^bp/; # add the "bp" prefix
+ $final = File::Spec->catfile($script_dir, $final);
+ $self->log_info("$result -> $final\n");
+ File::Copy::move($result, $final) or die "Can't rename '$result' to '$final': $!";
+ }
+}
+
+# extended to handle extra checking types
+sub features {
+ my $self = shift;
+ my $ph = $self->{phash};
+
+ if (@_) {
+ my $key = shift;
+ if ($ph->{features}->exists($key)) {
+ return $ph->{features}->access($key, @_);
+ }
+
+ if (my $info = $ph->{auto_features}->access($key)) {
+ my $failures = $self->prereq_failures($info);
+ my $disabled = grep( /^(?:\w+_)?(?:$checking_types)$/, keys %$failures ) ? 1 : 0;
+ return !$disabled;
+ }
+
+ return $ph->{features}->access($key, @_);
+ }
+
+ # No args - get the auto_features & overlay the regular features
+ my %features;
+ my %auto_features = $ph->{auto_features}->access();
+ while (my ($name, $info) = each %auto_features) {
+ my $failures = $self->prereq_failures($info);
+ my $disabled = grep( /^(?:\w+_)?(?:$checking_types)$/, keys %$failures ) ? 1 : 0;
+ $features{$name} = $disabled ? 0 : 1;
+ }
+ %features = (%features, $ph->{features}->access());
+
+ return wantarray ? %features : \%features;
+}
+*feature = \&features;
+
+# overridden to fix a stupid bug in Module::Build and extended to handle extra
+# checking types
+sub check_autofeatures {
+ my ($self) = @_;
+ my $features = $self->auto_features;
+
+ return unless %$features;
+
+ $self->log_info("Checking features:\n");
+
+ my $max_name_len = 0; # this wasn't set to 0 in Module::Build, causing warning in next line
+ $max_name_len = ( length($_) > $max_name_len ) ? length($_) : $max_name_len for keys %$features;
+
+ while (my ($name, $info) = each %$features) {
+ $self->log_info(" $name" . '.' x ($max_name_len - length($name) + 4));
+ if ($name eq 'PL_files') {
+ print "got $name => $info\n";
+ print "info has:\n";
+ while (my ($key, $val) = each %$info) {
+ print " $key => $val\n";
+ }
+ }
+
+ if ( my $failures = $self->prereq_failures($info) ) {
+ my $disabled = grep( /^(?:\w+_)?(?:$checking_types)$/, keys %$failures ) ? 1 : 0;
+ $self->log_info( $disabled ? "disabled\n" : "enabled\n" );
+
+ my $log_text;
+ while (my ($type, $prereqs) = each %$failures) {
+ while (my ($module, $status) = each %$prereqs) {
+ my $required = ($type =~ /^(?:\w+_)?(?:requires|conflicts)$/) ? 1 : 0;
+ my $prefix = ($required) ? '-' : '*';
+ $log_text .= " $prefix $status->{message}\n";
+ }
+ }
+ $self->log_warn($log_text) if $log_text && ! $self->quiet;
+ }
+ else {
+ $self->log_info("enabled\n");
+ }
+ }
+
+ $self->log_info("\n");
+}
+
+# overriden just to hide pointless ugly warnings
+sub check_installed_status {
+ my $self = shift;
+ open (my $olderr, ">&", \*STDERR);
+ open(STDERR, "/dev/null");
+ my $return = $self->SUPER::check_installed_status(@_);
+ open(STDERR, ">&", $olderr);
+ return $return;
+}
+
+# extend to handle option checking (which takes an array ref) and code test
+# checking (which takes a code ref and must return a message only on failure)
+# and excludes_os (which takes an array ref of regexps).
+# also handles more informative output of recommends section
+sub prereq_failures {
+ my ($self, $info) = @_;
+
+ my @types = (@{ $self->prereq_action_types }, @extra_types);
+ $info ||= {map {$_, $self->$_()} @types};
+
+ my $out = {};
+ foreach my $type (@types) {
+ my $prereqs = $info->{$type} || next;
+
+ my $status = {};
+ if ($type eq 'test') {
+ unless (keys %$out) {
+ if (ref($prereqs) eq 'CODE') {
+ $status->{message} = &{$prereqs};
+
+ # drop the code-ref to avoid Module::Build trying to store
+ # it with Data::Dumper, generating warnings. (And also, may
+ # be expensive to run the sub multiple times.)
+ $info->{$type} = $status->{message};
+ }
+ else {
+ $status->{message} = $prereqs;
+ }
+ $out->{$type}{'test'} = $status if $status->{message};
+ }
+ }
+ elsif ($type eq 'options') {
+ my @not_ok;
+ foreach my $wanted_option (@{$prereqs}) {
+ unless ($self->args($wanted_option)) {
+ push(@not_ok, $wanted_option);
+ }
+ }
+
+ if (@not_ok > 0) {
+ $status->{message} = "Command line option(s) '@not_ok' not supplied";
+ $out->{$type}{'options'} = $status;
+ }
+ }
+ elsif ($type eq 'excludes_os') {
+ foreach my $os (@{$prereqs}) {
+ if ($^O =~ /$os/i) {
+ $status->{message} = "This feature isn't supported under your OS ($os)";
+ $out->{$type}{'excludes_os'} = $status;
+ last;
+ }
+ }
+ }
+ else {
+ while ( my ($modname, $spec) = each %$prereqs ) {
+ $status = $self->check_installed_status($modname, $spec);
+
+ if ($type =~ /^(?:\w+_)?conflicts$/) {
+ next if !$status->{ok};
+ $status->{conflicts} = delete $status->{need};
+ $status->{message} = "$modname ($status->{have}) conflicts with this distribution";
+ }
+ elsif ($type =~ /^(?:\w+_)?recommends$/) {
+ next if $status->{ok};
+
+ my ($preferred_version, $why, $by_what) = split("/", $spec);
+ $by_what = join(", ", split(",", $by_what));
+ $by_what =~ s/, (\S+)$/ and $1/;
+
+ $status->{message} = (!ref($status->{have}) && $status->{have} eq '<none>'
+ ? "Optional prerequisite $modname is not installed"
+ : "$modname ($status->{have}) is installed, but we prefer to have $preferred_version");
+
+ $status->{message} .= "\n (wanted for $why, used by $by_what)";
+
+ if ($by_what =~ /\[circular dependency!\]/) {
+ $preferred_version = -1;
+ }
+
+ my $installed = $self->install_optional($modname, $preferred_version, $status->{message});
+ next if $installed eq 'ok';
+ $status->{message} = $installed unless $installed eq 'skip';
+ }
+ elsif ($type =~ /^feature_requires/) {
+ next if $status->{ok};
+
+ # if there is a test code-ref, drop it to avoid
+ # Module::Build trying to store it with Data::Dumper,
+ # generating warnings.
+ delete $info->{test};
+ }
+ else {
+ next if $status->{ok};
+
+ my $installed = $self->install_required($modname, $spec, $status->{message});
+ next if $installed eq 'ok';
+ $status->{message} = $installed;
+ }
+
+ $out->{$type}{$modname} = $status;
+ }
+ }
+ }
+
+ return keys %{$out} ? $out : return;
+}
+
+# install an external module using CPAN prior to testing and installation
+# should only be called by install_required or install_optional
+sub install_prereq {
+ my ($self, $desired, $version) = @_;
+
+ if ($self->under_cpan) {
+ # Just add to the required hash, which CPAN >= 1.81 will check prior
+ # to install
+ $self->{properties}{requires}->{$desired} = $version;
+ $self->log_info(" I'll get CPAN to prepend the installation of this\n");
+ return 'ok';
+ }
+ else {
+ # Here we use CPAN to actually install the desired module, the benefit
+ # being we continue even if installation fails, and that this works
+ # even when not using CPAN to install.
+ require Cwd;
+ require CPAN;
+
+ # Save this because CPAN will chdir all over the place.
+ my $cwd = Cwd::cwd();
+
+ CPAN::Shell->install($desired);
+ my $msg;
+ my $expanded = CPAN::Shell->expand("Module", $desired);
+ if ($expanded && $expanded->uptodate) {
+ $self->log_info("\n\n*** (back in BioPerl Build.PL) ***\n * You chose to install $desired and it installed fine\n");
+ $msg = 'ok';
+ }
+ else {
+ $self->log_info("\n\n*** (back in BioPerl Build.PL) ***\n");
+ $msg = "You chose to install $desired but it failed to install";
+ }
+
+ chdir $cwd or die "Cannot chdir() back to $cwd: $!";
+ return $msg;
+ }
+}
+
+# install required modules listed in 'requires' or 'build_requires' arg to
+# new that weren't already installed. Should only be called by prereq_failures
+sub install_required {
+ my ($self, $desired, $version, $msg) = @_;
+
+ $self->log_info(" - ERROR: $msg\n");
+
+ return $self->install_prereq($desired, $version);
+}
+
+# install optional modules listed in 'recommends' arg to new that weren't
+# already installed. Should only be called by prereq_failures
+sub install_optional {
+ my ($self, $desired, $version, $msg) = @_;
+
+ unless (defined $self->{ask_optional}) {
+ $self->{ask_optional} = $self->args->{accept}
+ ? 'n' : $self->prompt("Install [a]ll optional external modules, [n]one, or choose [i]nteractively?", 'n');
+ }
+ return 'skip' if $self->{ask_optional} =~ /^n/i;
+
+ my $install;
+ if ($self->{ask_optional} =~ /^a/i) {
+ $self->log_info(" * $msg\n");
+ $install = 1;
+ }
+ else {
+ $install = $self->y_n(" * $msg\n Do you want to install it? y/n", 'n');
+ }
+
+ my $orig_version = $version;
+ $version = 0 if $version == -1;
+ if ($install && ! ($self->{ask_optional} =~ /^a/i && $orig_version == -1)) {
+ return $self->install_prereq($desired, $version);
+ }
+ else {
+ my $circular = ($self->{ask_optional} =~ /^a/i && $orig_version == -1) ? " - this is a circular dependency so doesn't get installed when installing 'all' modules. If you really want it, choose modules interactively." : '';
+ $self->log_info(" * You chose not to install $desired$circular\n");
+ return 'ok';
+ }
+}
+
+# there's no official way to discover if being run by CPAN, we take an approach
+# similar to that of Module::AutoInstall
+sub under_cpan {
+ my $self = shift;
+
+ unless (defined $self->{under_cpan}) {
+ ## modified from Module::AutoInstall
+
+ # load cpan config
+ require CPAN;
+ if ($CPAN::HandleConfig::VERSION) {
+ # Newer versions of CPAN have a HandleConfig module
+ CPAN::HandleConfig->load;
+ }
+ else {
+ # Older versions had the load method in Config directly
+ CPAN::Config->load;
+ }
+
+ # Find the CPAN lock-file
+ my $lock = File::Spec->catfile($CPAN::Config->{cpan_home}, '.lock');
+ if (-f $lock) {
+ # Module::AutoInstall now goes on to open the lock file and compare
+ # its pid to ours, but we're not in a situation where we expect
+ # the pids to match, so we take the windows approach for all OSes:
+ # find out if we're in cpan_home
+ my $cwd = File::Spec->canonpath(Cwd::cwd());
+ my $cpan = File::Spec->canonpath($CPAN::Config->{cpan_home});
+
+ $self->{under_cpan} = index($cwd, $cpan) > -1;
+ }
+
+ if ($self->{under_cpan}) {
+ $self->log_info("(I think I'm being run by CPAN, so will rely on CPAN to handle prerequisite installation)\n");
+ }
+ else {
+ $self->log_info("(I think you ran Build.PL directly, so will use CPAN to install prerequisites on demand)\n");
+ $self->{under_cpan} = 0;
+ }
+ }
+
+ return $self->{under_cpan};
+}
+
+# overridden simply to not print the default answer if chosen by hitting return
+sub prompt {
+ my $self = shift;
+ my $mess = shift or die "prompt() called without a prompt message";
+
+ my $def;
+ if ( $self->_is_unattended && !@_ ) {
+ die <<EOF;
+ERROR: This build seems to be unattended, but there is no default value
+for this question. Aborting.
+EOF
+ }
+ $def = shift if @_;
+ ($def, my $dispdef) = defined $def ? ($def, "[$def] ") : ('', ' ');
+
+ local $|=1;
+ print "$mess $dispdef";
+
+ my $ans = $self->_readline();
+
+ if ( !defined($ans) # Ctrl-D or unattended
+ or !length($ans) ) { # User hit return
+ #print "$def\n"; didn't like this!
+ $ans = $def;
+ }
+
+ return $ans;
+}
+
+# like the Module::Build version, except that we always get version from
+# dist_version
+sub find_dist_packages {
+ my $self = shift;
+
+ # Only packages in .pm files are candidates for inclusion here.
+ # Only include things in the MANIFEST, not things in developer's
+ # private stock.
+
+ my $manifest = $self->_read_manifest('MANIFEST') or die "Can't find dist packages without a MANIFEST file - run 'manifest' action first";
+
+ # Localize
+ my %dist_files = map { $self->localize_file_path($_) => $_ } keys %$manifest;
+
+ my @pm_files = grep {exists $dist_files{$_}} keys %{ $self->find_pm_files };
+
+ my $actual_version = $self->dist_version;
+
+ # First, we enumerate all packages & versions,
+ # seperating into primary & alternative candidates
+ my( %prime, %alt );
+ foreach my $file (@pm_files) {
+ next if $dist_files{$file} =~ m{^t/}; # Skip things in t/
+
+ my @path = split( /\//, $dist_files{$file} );
+ (my $prime_package = join( '::', @path[1..$#path] )) =~ s/\.pm$//;
+
+ my $pm_info = Module::Build::ModuleInfo->new_from_file( $file );
+
+ foreach my $package ( $pm_info->packages_inside ) {
+ next if $package eq 'main'; # main can appear numerous times, ignore
+ next if grep /^_/, split( /::/, $package ); # private package, ignore
+
+ my $version = $pm_info->version( $package );
+ if ($version && $version != $actual_version) {
+ $self->log_warn("Package $package had version $version!\n");
+ }
+ $version = $actual_version;
+
+ if ( $package eq $prime_package ) {
+ if ( exists( $prime{$package} ) ) {
+ # M::B::ModuleInfo will handle this conflict
+ die "Unexpected conflict in '$package'; multiple versions found.\n";
+ }
+ else {
+ $prime{$package}{file} = $dist_files{$file};
+ $prime{$package}{version} = $version if defined( $version );
+ }
+ }
+ else {
+ push( @{$alt{$package}}, { file => $dist_files{$file}, version => $version } );
+ }
+ }
+ }
+
+ # Then we iterate over all the packages found above, identifying conflicts
+ # and selecting the "best" candidate for recording the file & version
+ # for each package.
+ foreach my $package ( keys( %alt ) ) {
+ my $result = $self->_resolve_module_versions( $alt{$package} );
+
+ if ( exists( $prime{$package} ) ) { # primary package selected
+ if ( $result->{err} ) {
+ # Use the selected primary package, but there are conflicting
+ # errors amoung multiple alternative packages that need to be
+ # reported
+ $self->log_warn("Found conflicting versions for package '$package'\n" .
+ " $prime{$package}{file} ($prime{$package}{version})\n" . $result->{err});
+ }
+ elsif ( defined( $result->{version} ) ) {
+ # There is a primary package selected, and exactly one
+ # alternative package
+
+ if ( exists( $prime{$package}{version} ) && defined( $prime{$package}{version} ) ) {
+ # Unless the version of the primary package agrees with the
+ # version of the alternative package, report a conflict
+ if ( $self->compare_versions( $prime{$package}{version}, '!=', $result->{version} ) ) {
+ $self->log_warn("Found conflicting versions for package '$package'\n" .
+ " $prime{$package}{file} ($prime{$package}{version})\n" .
+ " $result->{file} ($result->{version})\n");
+ }
+ }
+ else {
+ # The prime package selected has no version so, we choose to
+ # use any alternative package that does have a version
+ $prime{$package}{file} = $result->{file};
+ $prime{$package}{version} = $result->{version};
+ }
+ }
+ else {
+ # no alt package found with a version, but we have a prime
+ # package so we use it whether it has a version or not
+ }
+ }
+ else { # No primary package was selected, use the best alternative
+ if ( $result->{err} ) {
+ $self->log_warn("Found conflicting versions for package '$package'\n" . $result->{err});
+ }
+
+ # Despite possible conflicting versions, we choose to record
+ # something rather than nothing
+ $prime{$package}{file} = $result->{file};
+ $prime{$package}{version} = $result->{version} if defined( $result->{version} );
+ }
+ }
+
+ # Stringify versions
+ for (grep exists $_->{version}, values %prime) {
+ $_->{version} = $_->{version}->stringify if ref($_->{version});
+ }
+
+ return \%prime;
+}
+
+# our recommends syntax contains extra info that needs to be ignored at this
+# stage
+sub _parse_conditions {
+ my ($self, $spec) = @_;
+
+ ($spec) = split("/", $spec);
+
+ if ($spec =~ /^\s*([\w.]+)\s*$/) { # A plain number, maybe with dots, letters, and underscores
+ return (">= $spec");
+ }
+ else {
+ return split /\s*,\s*/, $spec;
+ }
+}
+
+# when generating META.yml, we output optional_features syntax (instead of
+# recommends syntax). Note that as of CPAN v1.8802 nothing useful is done
+# with this information, which is why we implement our own request to install
+# the optional modules in install_optional()
+sub prepare_metadata {
+ my ($self, $node, $keys) = @_;
+ my $p = $self->{properties};
+
+ # A little helper sub
+ my $add_node = sub {
+ my ($name, $val) = @_;
+ $node->{$name} = $val;
+ push @$keys, $name if $keys;
+ };
+
+ foreach (qw(dist_name dist_version dist_author dist_abstract license)) {
+ (my $name = $_) =~ s/^dist_//;
+ $add_node->($name, $self->$_());
+ die "ERROR: Missing required field '$_' for META.yml\n" unless defined($node->{$name}) && length($node->{$name});
+ }
+ $node->{version} = '' . $node->{version}; # Stringify version objects
+
+ if (defined( $self->license ) && defined( my $url = $self->valid_licenses->{ $self->license } )) {
+ $node->{resources}{license} = $url;
+ }
+
+ foreach ( @{$self->prereq_action_types} ) {
+ if (exists $p->{$_} and keys %{ $p->{$_} }) {
+ if ($_ eq 'recommends') {
+ my $hash;
+ while (my ($req, $val) = each %{ $p->{$_} }) {
+ my ($ver, $why, $used_by) = split("/", $val);
+ my $info = {};
+ $info->{description} = $why;
+ $info->{requires} = { $req => $ver };
+ $hash->{$used_by} = $info;
+ }
+ $add_node->('optional_features', $hash);
+ }
+ else {
+ $add_node->($_, $p->{$_});
+ }
+ }
+ }
+
+ if (exists $p->{dynamic_config}) {
+ $add_node->('dynamic_config', $p->{dynamic_config});
+ }
+ my $pkgs = eval { $self->find_dist_packages };
+ if ($@) {
+ $self->log_warn("$@\nWARNING: Possible missing or corrupt 'MANIFEST' file.\n" . "Nothing to enter for 'provides' field in META.yml\n");
+ }
+ else {
+ $node->{provides} = $pkgs if %$pkgs;
+ };
+
+ if (exists $p->{no_index}) {
+ $add_node->('no_index', $p->{no_index});
+ }
+
+ $add_node->('generated_by', "Module::Build version $Module::Build::VERSION");
+
+ $add_node->('meta-spec',
+ {version => '1.2',
+ url => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
+ });
+
+ while (my($k, $v) = each %{$self->meta_add}) {
+ $add_node->($k, $v);
+ }
+
+ while (my($k, $v) = each %{$self->meta_merge}) {
+ $self->_hash_merge($node, $k, $v);
+ }
+
+ return $node;
+}
+
+# let us store extra things persistently in _build
+sub _construct {
+ my $self = shift;
+
+ # calling SUPER::_construct will dump some of the input to this sub out
+ # with Data::Dumper, which will complain about code refs. So we replace
+ # any code refs with dummies first, then put them back afterwards
+ my %in_hash = @_;
+ my $auto_features = $in_hash{auto_features} if defined $in_hash{auto_features};
+ my %code_refs;
+ if ($auto_features) {
+ while (my ($key, $hash) = each %{$auto_features}) {
+ while (my ($sub_key, $val) = each %{$hash}) {
+ if (ref($val) && ref($val) eq 'CODE') {
+ $hash->{$sub_key} = 'CODE_ref';
+ $code_refs{$key}->{$sub_key} = $val;
+ }
+ }
+ }
+ }
+
+ $self = $self->SUPER::_construct(@_);
+
+ my ($p, $ph) = ($self->{properties}, $self->{phash});
+
+ if (keys %code_refs) {
+ while (my ($key, $hash) = each %{$auto_features}) {
+ if (defined $code_refs{$key}) {
+ while (my ($sub_key, $code_ref) = each %{$code_refs{$key}}) {
+ $hash->{$sub_key} = $code_ref;
+ }
+ $ph->{auto_features}->{$key} = $hash;
+ }
+ }
+ }
+
+ foreach (qw(manifest_skip post_install_scripts)) {
+ my $file = File::Spec->catfile($self->config_dir, $_);
+ $ph->{$_} = Module::Build::Notes->new(file => $file);
+ $ph->{$_}->restore if -e $file;
+ }
+
+ return $self;
+}
+sub write_config {
+ my $self = shift;
+ $self->SUPER::write_config;
+
+ # write extra things
+ $self->{phash}{$_}->write() foreach qw(manifest_skip post_install_scripts);
+
+ # be even more certain we can reload ourselves during a resume by copying
+ # ourselves to _build\lib
+ # this is only possible for the core distribution where we are actually
+ # present in the distribution
+ my $self_filename = File::Spec->catfile('Bio', 'Root', 'Build.pm');
+ -e $self_filename || return;
+
+ my $filename = File::Spec->catfile($self->{properties}{config_dir}, 'lib', 'Bio', 'Root', 'Build.pm');
+ my $filedir = File::Basename::dirname($filename);
+
+ File::Path::mkpath($filedir);
+ warn "Can't create directory $filedir: $!" unless -d $filedir;
+
+ File::Copy::copy($self_filename, $filename);
+ warn "Unable to copy 'Bio/Root/Build.pm' to '$filename'\n" unless -e $filename;
+}
+
+# add a file to the default MANIFEST.SKIP
+sub add_to_manifest_skip {
+ my $self = shift;
+ my %files = map {$self->localize_file_path($_), 1} @_;
+ $self->{phash}{manifest_skip}->write(\%files);
+}
+
+# we always generate a new MANIFEST and MANIFEST.SKIP here, instead of allowing
+# existing files to remain
+sub ACTION_manifest {
+ my ($self) = @_;
+
+ my $maniskip = 'MANIFEST.SKIP';
+ if ( -e 'MANIFEST' || -e $maniskip ) {
+ $self->log_warn("MANIFEST files already exist, will overwrite them\n");
+ unlink('MANIFEST');
+ unlink($maniskip);
+ }
+ $self->_write_default_maniskip($maniskip);
+
+ require ExtUtils::Manifest; # ExtUtils::Manifest is not warnings clean.
+ local ($^W, $ExtUtils::Manifest::Quiet) = (0,1);
+ ExtUtils::Manifest::mkmanifest();
+}
+
+# extended to add extra things to the default MANIFEST.SKIP
+sub _write_default_maniskip {
+ my $self = shift;
+ $self->SUPER::_write_default_maniskip;
+
+ my @extra = keys %{$self->{phash}{manifest_skip}->read};
+ if (@extra) {
+ open(my $fh, '>>', 'MANIFEST.SKIP') or die "Could not open MANIFEST.SKIP file\n";
+ print $fh "\n# Avoid additional run-time generated things\n";
+ foreach my $line (@extra) {
+ print $fh $line, "\n";
+ }
+ close($fh);
+ }
+}
+
+# extended to run scripts post-installation
+sub ACTION_install {
+ my ($self) = @_;
+ require ExtUtils::Install;
+ $self->depends_on('build');
+ ExtUtils::Install::install($self->install_map, !$self->quiet, 0, $self->{args}{uninst}||0);
+ $self->run_post_install_scripts;
+}
+sub add_post_install_script {
+ my $self = shift;
+ my %files = map {$self->localize_file_path($_), 1} @_;
+ $self->{phash}{post_install_scripts}->write(\%files);
+}
+sub run_post_install_scripts {
+ my $self = shift;
+ my @scripts = keys %{$self->{phash}{post_install_scripts}->read};
+ foreach my $script (@scripts) {
+ $self->run_perl_script($script);
+ }
+}
+
+# for use with auto_features, which should require LWP::UserAgent as one of
+# its reqs
+sub test_internet {
+ eval {require LWP::UserAgent;};
+ if ($@) {
+ # ideally this won't happen because auto_feature already specified
+ # LWP::UserAgent, so this sub wouldn't get called if LWP not installed
+ return "LWP::UserAgent not installed";
+ }
+ my $ua = LWP::UserAgent->new;
+ $ua->timeout(10);
+ $ua->env_proxy;
+ my $response = $ua->get('http://search.cpan.org/');
+ unless ($response->is_success) {
+ return "Could not connect to the internet (http://search.cpan.org/)";
+ }
+ return;
+}
+
+# nice directory names for dist-related actions
+sub dist_dir {
+ my ($self) = @_;
+ my $version = $self->dist_version;
+ if ($version =~ /^\d\.\d{6}\d$/) {
+ # 1.x.x.100 returned as 1.x.x.1
+ $version .= '00';
+ }
+ $version =~ s/00(\d)/$1./g;
+ $version =~ s/\.$//;
+
+ if (my ($minor, $rev) = $version =~ /^\d\.(\d)\.\d\.(\d+)$/) {
+ my $dev = ! ($minor % 2 == 0);
+ if ($rev == 100) {
+ my $replace = $dev ? "_$rev" : '';
+ $version =~ s/\.\d+$/$replace/;
+ }
+ elsif ($rev < 100) {
+ $rev = sprintf("%03d", $rev);
+ $version =~ s/\.\d+$/_$rev-RC/;
+ }
+ else {
+ $rev -= 100 unless $dev;
+ my $replace = $dev ? "_$rev" : ".$rev";
+ $version =~ s/\.\d+$/$replace/;
+ }
+ }
+
+ return "$self->{properties}{dist_name}-$version";
+}
+sub ppm_name {
+ my $self = shift;
+ return $self->dist_dir.'-ppm';
+}
+
+# generate complete ppd4 version file
+sub ACTION_ppd {
+ my $self = shift;
+
+ my $file = $self->make_ppd(%{$self->{args}});
+ $self->add_to_cleanup($file);
+ $self->add_to_manifest_skip($file);
+}
+
+# add pod2htm temp files to MANIFEST.SKIP, generated during ppmdist most likely
+sub htmlify_pods {
+ my $self = shift;
+ $self->SUPER::htmlify_pods(@_);
+ $self->add_to_manifest_skip('pod2htm*');
+}
+
+# don't copy across man3 docs since they're of little use under Windows and
+# have bad filenames
+sub ACTION_ppmdist {
+ my $self = shift;
+ my @types = $self->install_types(1);
+ $self->SUPER::ACTION_ppmdist(@_);
+ $self->install_types(0);
+}
+
+# when supplied a true value, pretends libdoc doesn't exist (preventing man3
+# installation for ppmdist). when supplied false, they exist again
+sub install_types {
+ my ($self, $no_libdoc) = @_;
+ $self->{no_libdoc} = $no_libdoc if defined $no_libdoc;
+ my @types = $self->SUPER::install_types;
+ if ($self->{no_libdoc}) {
+ my @altered_types;
+ foreach my $type (@types) {
+ push(@altered_types, $type) unless $type eq 'libdoc';
+ }
+ return @altered_types;
+ }
+ return @types;
+}
+
+# overridden from Module::Build::PPMMaker for ppd4 compatability
+sub make_ppd {
+ my ($self, %args) = @_;
+
+ require Module::Build::PPMMaker;
+ my $mbp = Module::Build::PPMMaker->new();
+
+ my %dist;
+ foreach my $info (qw(name author abstract version)) {
+ my $method = "dist_$info";
+ $dist{$info} = $self->$method() or die "Can't determine distribution's $info\n";
+ }
+ $dist{codebase} = $self->ppm_name.'.tar.gz';
+ $mbp->_simple_xml_escape($_) foreach $dist{abstract}, $dist{codebase}, @{$dist{author}};
+
+ my (undef, undef, undef, $mday, $mon, $year) = localtime();
+ $year += 1900;
+ $mon++;
+ my $date = "$year-$mon-$mday";
+
+ my $softpkg_version = $self->dist_dir;
+ $softpkg_version =~ s/^$dist{name}-//;
+
+ # to avoid a ppm bug, instead of including the requires in the softpackage
+ # for the distribution we're making, we'll make a seperate Bundle::
+ # softpackage that contains all the requires, and require only the Bundle in
+ # the real softpackage
+ my ($bundle_name) = $dist{name} =~ /^.+-(.+)/;
+ $bundle_name ||= 'core';
+ $bundle_name =~ s/^(\w)/\U$1/;
+ my $bundle_dir = "Bundle-BioPerl-$bundle_name-$softpkg_version-ppm";
+ my $bundle_file = "$bundle_dir.tar.gz";
+ my $bundle_softpkg_name = "Bundle-BioPerl-$bundle_name";
+ $bundle_name = "Bundle::BioPerl::$bundle_name";
+
+ # header
+ my $ppd = <<"PPD";
+ <SOFTPKG NAME=\"$dist{name}\" VERSION=\"$softpkg_version\" DATE=\"$date\">
+ <TITLE>$dist{name}</TITLE>
+ <ABSTRACT>$dist{abstract}</ABSTRACT>
+@{[ join "\n", map " <AUTHOR>$_</AUTHOR>", @{$dist{author}} ]}
+ <PROVIDE NAME=\"$dist{name}::\" VERSION=\"$dist{version}\"/>
+PPD
+
+ # provide section
+ foreach my $pm (@{$self->rscan_dir('Bio', qr/\.pm$/)}) {
+ # convert these filepaths to Module names
+ $pm =~ s/\//::/g;
+ $pm =~ s/\.pm//;
+
+ $ppd .= sprintf(<<'EOF', $pm, $dist{version});
+ <PROVIDE NAME="%s" VERSION="%s"/>
+EOF
+ }
+
+ # rest of softpkg
+ $ppd .= <<"PPD";
+ <IMPLEMENTATION>
+ <ARCHITECTURE NAME=\"MSWin32-x86-multi-thread-5.8\"/>
+ <CODEBASE HREF=\"$dist{codebase}\"/>
+ <REQUIRE NAME=\"$bundle_name\" VERSION=\"$dist{version}\"/>
+ </IMPLEMENTATION>
+ </SOFTPKG>
+PPD
+
+ # now a new softpkg for the bundle
+ $ppd .= <<"PPD";
+
+ <SOFTPKG NAME=\"$bundle_softpkg_name\" VERSION=\"$softpkg_version\" DATE=\"$date\">
+ <TITLE>$bundle_name</TITLE>
+ <ABSTRACT>Bundle of pre-requisites for $dist{name}</ABSTRACT>
+@{[ join "\n", map " <AUTHOR>$_</AUTHOR>", @{$dist{author}} ]}
+ <PROVIDE NAME=\"$bundle_name\" VERSION=\"$dist{version}\"/>
+ <IMPLEMENTATION>
+ <ARCHITECTURE NAME=\"MSWin32-x86-multi-thread-5.8\"/>
+ <CODEBASE HREF=\"$bundle_file\"/>
+PPD
+
+ # required section
+ # we do both requires and recommends to make installation on Windows as
+ # easy (mindless) as possible
+ for my $type ('requires', 'recommends') {
+ my $prereq = $self->$type;
+ while (my ($modname, $version) = each %$prereq) {
+ next if $modname eq 'perl';
+ ($version) = split("/", $version) if $version =~ /\//;
+
+ # Module names must have at least one ::
+ unless ($modname =~ /::/) {
+ $modname .= '::';
+ }
+
+ # Bio::Root::Version number comes out as triplet number like 1.5.2;
+ # convert to our own version
+ if ($modname eq 'Bio::Root::Version') {
+ $version = $dist{version};
+ }
+
+ $ppd .= sprintf(<<'EOF', $modname, $version || '');
+ <REQUIRE NAME="%s" VERSION="%s"/>
+EOF
+ }
+ }
+
+ # footer
+ $ppd .= <<'EOF';
+ </IMPLEMENTATION>
+ </SOFTPKG>
+EOF
+
+ my $ppd_file = "$dist{name}.ppd";
+ my $fh = IO::File->new(">$ppd_file") or die "Cannot write to $ppd_file: $!";
+ print $fh $ppd;
+ close $fh;
+
+ $self->delete_filetree($bundle_dir);
+ mkdir($bundle_dir) or die "Cannot create '$bundle_dir': $!";
+ $self->make_tarball($bundle_dir);
+ $self->delete_filetree($bundle_dir);
+ $self->add_to_cleanup($bundle_file);
+ $self->add_to_manifest_skip($bundle_file);
+
+ return $ppd_file;
+}
+
+# we make all archive formats we want, not just .tar.gz
+# we also auto-run manifest action, since we always want to re-create
+# MANIFEST and MANIFEST.SKIP just-in-time
+sub ACTION_dist {
+ my ($self) = @_;
+
+ $self->depends_on('manifest');
+ $self->depends_on('distdir');
+
+ my $dist_dir = $self->dist_dir;
+
+ $self->make_zip($dist_dir);
+ $self->make_tarball($dist_dir);
+ $self->delete_filetree($dist_dir);
+}
+
+# makes zip file for windows users and bzip2 files as well
+sub make_zip {
+ my ($self, $dir, $file) = @_;
+ $file ||= $dir;
+
+ $self->log_info("Creating $file.zip\n");
+ my $zip_flags = $self->verbose ? '-r' : '-rq';
+ $self->do_system($self->split_like_shell("zip"), $zip_flags, "$file.zip", $dir);
+
+ $self->log_info("Creating $file.bz2\n");
+ require Archive::Tar;
+ # Archive::Tar versions >= 1.09 use the following to enable a compatibility
+ # hack so that the resulting archive is compatible with older clients.
+ $Archive::Tar::DO_NOT_USE_PREFIX = 0;
+ my $files = $self->rscan_dir($dir);
+ Archive::Tar->create_archive("$file.tar", 0, @$files);
+ $self->do_system($self->split_like_shell("bzip2"), "-k", "$file.tar");
+}
+
+# a method that can be called in a Build.PL script to ask the user if they want
+# internet tests.
+# Should only be called if you have tested for yourself that
+# $build->feature('Network') is true
+sub prompt_for_network {
+ my ($self, $accept) = @_;
+
+ my $proceed = $accept ? 0 : $self->y_n("Do you want to run tests that require connection to servers across the internet\n(likely to cause some failures)? y/n", 'n');
+
+ if ($proceed) {
+ $self->notes(network => 1);
+ $self->log_info(" - will run internet-requiring tests\n");
+ }
+ else {
+ $self->notes(network => 0);
+ $self->log_info(" - will not run internet-requiring tests\n");
+ }
+}
+
+1;
471 Bio/Root/Exception.pm
@@ -0,0 +1,471 @@
+#-----------------------------------------------------------------
+# $Id: Exception.pm 15549 2009-02-21 00:48:48Z maj $
+#
+# BioPerl module Bio::Root::Exception
+#
+# Please direct questions and support issues to <bioperl-l@bioperl.org>
+#
+# Cared for by Steve Chervitz <sac@bioperl.org>
+#
+# You may distribute this module under the same terms as perl itself
+#-----------------------------------------------------------------
+
+=head1 NAME
+
+Bio::Root::Exception - Generic exception objects for Bioperl
+
+=head1 SYNOPSIS
+
+=head2 Throwing exceptions using L<Error::throw()>:
+
+ use Bio::Root::Exception;
+ use Error;
+
+ # Set Error::Debug to include stack trace data in the error messages
+ $Error::Debug = 1;
+
+ $file = shift;
+ open (IN, $file) ||
+ throw Bio::Root::FileOpenException ( "Can't open file $file for reading", $!);
+
+=head2 Throwing exceptions using L<Bio::Root::Root::throw()>:
+
+ # Here we have an object that ISA Bio::Root::Root, so it inherits throw().
+
+ open (IN, $file) ||
+ $object->throw(-class => 'Bio::Root::FileOpenException',
+ -text => "Can't open file $file for reading",
+ -value => $!);
+
+=head2 Catching and handling exceptions using L<Error::try()>:
+
+ use Bio::Root::Exception;
+ use Error qw(:try);
+
+ # Note that we need to import the 'try' tag from Error.pm
+
+ # Set Error::Debug to include stack trace data in the error messages
+ $Error::Debug = 1;
+
+ $file = shift;
+ try {
+ open (IN, $file) ||
+ throw Bio::Root::FileOpenException ( "Can't open file $file for reading", $!);
+ }
+ catch Bio::Root::FileOpenException with {
+ my $err = shift;
+ print STDERR "Using default input file: $default_file\n";
+ open (IN, $default_file) || die "Can't open $default_file";
+ }
+ otherwise {
+ my $err = shift;
+ print STDERR "An unexpected exception occurred: \n$err";
+
+ # By placing an the error object reference within double quotes,
+ # you're invoking its stringify() method.
+ }
+ finally {
+ # Any code that you want to execute regardless of whether or not
+ # an exception occurred.
+ };
+ # the ending semicolon is essential!
+
+
+=head2 Defining a new Exception type as a subclass of Bio::Root::Exception:
+
+ @Bio::TestException::ISA = qw( Bio::Root::Exception );
+
+
+=head1 DESCRIPTION
+
+=head2 Exceptions defined in L<Bio::Root::Exception>
+
+These are generic exceptions for typical problem situations that could arise
+in any module or script.
+
+=over 8
+
+=item Bio::Root::Exception()
+
+=item Bio::Root::NotImplemented()
+
+=item Bio::Root::IOException()
+
+=item Bio::Root::FileOpenException()
+
+=item Bio::Root::SystemException()
+
+=item Bio::Root::BadParameter()
+
+=item Bio::Root::OutOfRange()
+
+=item Bio::Root::NoSuchThing()
+
+=back
+
+Using defined exception classes like these is a good idea because it
+indicates the basic nature of what went wrong in a convenient,
+computable way.
+
+If there is a type of exception that you want to throw
+that is not covered by the classes listed above, it is easy to define
+a new one that fits your needs. Just write a line like the following
+in your module or script where you want to use it (or put it somewhere
+that is accessible to your code):
+
+ @NoCanDoException::ISA = qw( Bio::Root::Exception );
+
+All of the exceptions defined in this module inherit from a common
+base class exception, Bio::Root::Exception. This allows a user to
+write a handler for all Bioperl-derived exceptions as follows:
+
+ use Bio::Whatever;
+ use Error qw(:try);
+
+ try {
+ # some code that depends on Bioperl
+ }
+ catch Bio::Root::Exception with {
+ my $err = shift;
+ print "A Bioperl exception occurred:\n$err\n";
+ };
+
+So if you do create your own exceptions, just be sure they inherit
+from Bio::Root::Exception directly, or indirectly by inheriting from a
+Bio::Root::Exception subclass.
+
+The exceptions in Bio::Root::Exception are extensions of Graham Barr's
+L<Error> module available from CPAN. Despite this dependency, the
+L<Bio::Root::Exception> module does not explicitly C<require Error>.
+This permits Bio::Root::Exception to be loaded even when
+Error.pm is not available.
+
+=head2 Throwing exceptions within Bioperl modules
+
+Error.pm is not part of the Bioperl distibution, and may not be
+present within any given perl installation. So, when you want to
+throw an exception in a Bioperl module, the safe way to throw it
+is to use L<Bio::Root::Root::throw()> which can use Error.pm
+when it's available. See documentation in Bio::Root::Root for details.
+
+=head1 SEE ALSO
+
+See the C<examples/exceptions> directory of the Bioperl distribution for
+working demo code.
+
+L<Bio::Root::Root::throw()> for information about throwing
+L<Bio::Root::Exception>-based exceptions.
+
+L<Error> (available from CPAN, author: GBARR)
+
+Error.pm is helping to guide the design of exception handling in Perl 6.
+See these RFC's:
+
+ http://dev.perl.org/rfc/63.pod
+
+ http://dev.perl.org/rfc/88.pod
+
+
+=head1 AUTHOR
+
+Steve Chervitz E<lt>sac@bioperl.orgE<gt>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2001 Steve Chervitz. All Rights Reserved.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=head1 DISCLAIMER
+
+This software is provided "as is" without warranty of any kind.
+
+=head1 EXCEPTIONS
+
+=cut
+
+# Define some generic exceptions.'
+
+package Bio::Root::Exception;
+use Bio::Root::Version;
+
+use strict;
+
+my $debug = $Error::Debug; # Prevents the "used only once" warning.
+my $DEFAULT_VALUE = "__DUMMY__"; # Permits eval{} based handlers to work
+
+=head2 L<Bio::Root::Exception>
+
+ Purpose : A generic base class for all BioPerl exceptions.
+ By including a "catch Bio::Root::Exception" block, you
+ should be able to trap all BioPerl exceptions.
+ Example : throw Bio::Root::Exception("A generic exception", $!);
+
+=cut
+
+#---------------------------------------------------------
+@Bio::Root::Exception::ISA = qw( Error );
+#---------------------------------------------------------
+
+=head2 Methods defined by Bio::Root::Exception
+
+=over 4
+
+=item L<new()>
+
+ Purpose : Guarantees that -value is set properly before
+ calling Error::new().
+
+ Arguments: key-value style arguments same as for Error::new()
+
+ You can also specify plain arguments as ($message, $value)
+ where $value is optional.
+
+ -value, if defined, must be non-zero and not an empty string
+ in order for eval{}-based exception handlers to work.
+ These require that if($@) evaluates to true, which will not
+ be the case if the Error has no value (Error overloads
+ numeric operations to the Error::value() method).
+
+ It is OK to create Bio::Root::Exception objects without
+ specifing -value. In this case, an invisible dummy value is used.
+
+ If you happen to specify a -value of zero (0), it will
+ be replaced by the string "The number zero (0)".
+
+ If you happen to specify a -value of empty string (""), it will
+ be replaced by the string "An empty string ("")".
+
+=cut
+
+sub new {
+ my ($class, @args) = @_;
+ my ($value, %params);
+ if( @args % 2 == 0 && $args[0] =~ /^-/) {
+ %params = @args;
+ $value = $params{'-value'};
+ }
+ else {
+ $params{-text} = $args[0];
+ $value = $args[1];
+ }
+
+ if( defined $value ) {
+ $value = "The number zero (0)" if $value =~ /^\d+$/ && $value == 0;
+ $value = "An empty string (\"\")" if $value eq "";
+ }
+ else {
+ $value ||= $DEFAULT_VALUE;
+ }
+ $params{-value} = $value;
+
+ my $self = $class->SUPER::new( %params );
+ return $self;
+}
+
+=item pretty_format()
+
+ Purpose : Get a nicely formatted string containing information about the
+ exception. Format is similar to that produced by
+ Bio::Root::Root::throw(), with the addition of the name of
+ the exception class in the EXCEPTION line and some other
+ data available via the Error object.
+ Example : print $error->pretty_format;
+
+=cut
+
+sub pretty_format {
+ my $self = shift;
+ my $msg = $self->text;
+ my $stack = '';
+ if( $Error::Debug ) {
+ $stack = $self->_reformat_stacktrace();
+ }
+ my $value_string = $self->value ne $DEFAULT_VALUE ? "VALUE: ".$self->value."\n" : "";
+ my $class = ref($self);
+
+ my $title = "------------- EXCEPTION: $class -------------";
+ my $footer = "\n" . '-' x CORE::length($title);
+ my $out = "\n$title\n" .
+ "MSG: $msg\n". $value_string. $stack. $footer . "\n";
+ return $out;
+}
+
+
+# Reformatting of the stack performed by _reformat_stacktrace:
+# 1. Shift the file:line data in line i to line i+1.
+# 2. change xxx::__ANON__() to "try{} block"
+# 3. skip the "require" and "Error::subs::try" stack entries (boring)
+# This means that the first line in the stack won't have any file:line data
+# But this isn't a big issue since it's for a Bio::Root::-based method
+# that doesn't vary from exception to exception.
+
+sub _reformat_stacktrace {
+ my $self = shift;
+ my $msg = $self->text;
+ my $stack = $self->stacktrace();
+ $stack =~ s/\Q$msg//;
+ my @stack = split( /\n/, $stack);
+ my @new_stack = ();
+ my ($method, $file, $linenum, $prev_file, $prev_linenum);
+ my $stack_count = 0;
+ foreach my $i( 0..$#stack ) {
+ # print "STACK-ORIG: $stack[$i]\n";
+ if( ($stack[$i] =~ /^\s*([^(]+)\s*\(.*\) called at (\S+) line (\d+)/) ||
+ ($stack[$i] =~ /^\s*(require 0) called at (\S+) line (\d+)/)) {
+ ($method, $file, $linenum) = ($1, $2, $3);
+ $stack_count++;
+ }
+ else{
+ next;
+ }
+ if( $stack_count == 1 ) {
+ push @new_stack, "STACK: $method";
+ ($prev_file, $prev_linenum) = ($file, $linenum);
+ next;
+ }
+
+ if( $method =~ /__ANON__/ ) {
+ $method = "try{} block";
+ }
+ if( ($method =~ /^require/ and $file =~ /Error\.pm/ ) ||
+ ($method =~ /^Error::subs::try/ ) ) {
+ last;
+ }
+ push @new_stack, "STACK: $method $prev_file:$prev_linenum";
+ ($prev_file, $prev_linenum) = ($file, $linenum);
+ }
+ push @new_stack, "STACK: $prev_file:$prev_linenum";
+
+ return join "\n", @new_stack;
+}
+
+=item L<stringify()>
+
+ Purpose : Overrides Error::stringify() to call pretty_format().
+ This is called automatically when an exception object
+ is placed between double quotes.
+ Example : catch Bio::Root::Exception with {
+ my $error = shift;
+ print "$error";
+ }
+
+See Also: L<pretty_format()|pretty_format>
+
+=cut
+
+sub stringify {
+ my ($self, @args) = @_;
+ return $self->pretty_format( @args );
+}
+
+
+
+=back
+
+=head1 Subclasses of Bio::Root::Exception
+
+
+=head2 L<Bio::Root::NotImplemented>
+
+ Purpose : Indicates that a method has not been implemented.
+ Example : throw Bio::Root::NotImplemented(
+ -text => "Method \"foo\" not implemented in module FooBar.",
+ -value => "foo" );
+
+=cut
+
+#---------------------------------------------------------
+@Bio::Root::NotImplemented::ISA = qw( Bio::Root::Exception );
+#---------------------------------------------------------
+
+=head2 L<Bio::Root::IOException>
+
+ Purpose : Indicates that some input/output-related trouble has occurred.
+ Example : throw Bio::Root::IOException(
+ -text => "Can't save data to file $file.",
+ -value => $! );
+
+=cut
+
+#---------------------------------------------------------
+@Bio::Root::IOException::ISA = qw( Bio::Root::Exception );
+#---------------------------------------------------------
+
+
+=head2 L<Bio::Root::FileOpenException>
+
+ Purpose : Indicates that a file could not be opened.
+ Example : throw Bio::Root::FileOpenException(
+ -text => "Can't open file $file for reading.",
+ -value => $! );
+
+=cut
+
+#---------------------------------------------------------
+@Bio::Root::FileOpenException::ISA = qw( Bio::Root::IOException );
+#---------------------------------------------------------
+
+
+=head2 L<Bio::Root::SystemException>
+
+ Purpose : Indicates that a system call failed.
+ Example : unlink($file) or throw Bio::Root::SystemException(
+ -text => "Can't unlink file $file.",
+ -value => $! );
+
+=cut
+
+#---------------------------------------------------------
+@Bio::Root::SystemException::ISA = qw( Bio::Root::Exception );
+#---------------------------------------------------------
+
+
+=head2 L<Bio::Root::BadParameter>
+
+ Purpose : Indicates that one or more parameters supplied to a method
+ are invalid, unspecified, or conflicting.
+ Example : throw Bio::Root::BadParameter(
+ -text => "Required parameter \"-foo\" was not specified",
+ -value => "-foo" );
+
+=cut
+
+#---------------------------------------------------------
+@Bio::Root::BadParameter::ISA = qw( Bio::Root::Exception );
+#---------------------------------------------------------
+
+
+=head2 L<Bio::Root::OutOfRange>
+
+ Purpose : Indicates that a specified (start,end) range or
+ an index to an array is outside the permitted range.
+ Example : throw Bio::Root::OutOfRange(
+ -text => "Start coordinate ($start) cannot be less than zero.",
+ -value => $start );
+
+=cut
+
+#---------------------------------------------------------
+@Bio::Root::OutOfRange::ISA = qw( Bio::Root::Exception );
+#---------------------------------------------------------
+
+
+=head2 L<Bio::Root::NoSuchThing>
+
+ Purpose : Indicates that a requested thing cannot be located
+ and therefore could possibly be bogus.
+ Example : throw Bio::Root::NoSuchThing(
+ -text => "Accession M000001 could not be found.",
+ -value => "M000001" );
+
+=cut
+
+#---------------------------------------------------------
+@Bio::Root::NoSuchThing::ISA = qw( Bio::Root::Exception );
+#---------------------------------------------------------
+
+
+1;
+
392 Bio/Root/HTTPget.pm
@@ -0,0 +1,392 @@
+# $Id: HTTPget.pm 15549 2009-02-21 00:48:48Z maj $
+#
+# BioPerl module for fallback HTTP get operations.
+# Module is proxy-aware
+#
+# Please direct questions and support issues to <bioperl-l@bioperl.org>
+#
+# Cared for by Chris Dagdigian <dag@sonsorol.org>
+# but all of the good stuff was written by
+# Lincoln Stein.
+#
+# You may distribute this module under the same terms as perl itself
+
+# POD documentation - main docs before the code
+
+=head1 NAME
+
+Bio::Root::HTTPget - module for fallback HTTP get operations when
+LWP:: is unavailable
+
+=head1 SYNOPSIS
+
+ use Bio::Root::HTTPget;
+ my $web = Bio::Root::HTTPget->new();
+
+ my $response = $web->get('http://localhost');
+ $response = $web->get('http://localhost/images');
+
+ $response = eval { $web->get('http://fred:secret@localhost/ladies_only/')
+ } or warn $@;
+
+ $response = eval { $web->get('http://jeff:secret@localhost/ladies_only/')
+ } or warn $@;
+
+ $response = $web->get('http://localhost/images/navauthors.gif');
+ $response = $web->get(-url=>'http://www.google.com',
+ -proxy=>'http://www.modperl.com');
+
+=head1 DESCRIPTION
+
+This is basically an last-chance module for doing network HTTP get
+requests in situations where more advanced external CPAN modules such
+as LWP:: are not installed.
+
+The particular reason this module was developed was so that the Open
+Bio Database Access code can fallback to fetching the default registry
+files from http://open-bio.org/registry/ without having to depend on
+external dependencies like Bundle::LWP for network HTTP access.
+
+The core of this module was written by Lincoln Stein. It can handle proxies
+and HTTP-based proxy authentication.
+
+=head1 FEEDBACK
+
+=head2 Mailing Lists
+
+User feedback is an integral part of the evolution of this
+and other Bioperl modules. Send your comments and suggestions preferably
+to one of the Bioperl mailing lists.
+Your participation is much appreciated.
+
+ bioperl-l@bioperl.org - General discussion
+ http://bioperl.org/wiki/Mailing_lists - About the mailing lists
+
+ =head2 Reporting Bugs
+
+Report bugs to the Bioperl bug tracking system to help us keep track
+the bugs and their resolution. Bug reports can be submitted via the
+web:
+
+ http://bugzilla.open-bio.org/
+
+=head1 AUTHOR - Lincoln Stein
+
+# Please direct questions and support issues to <bioperl-l@bioperl.org>
+#
+ Cared for by Chris Dagdigian <dag@sonsorol.org>
+
+=head1 APPENDIX
+
+The rest of the documentation details each of the object
+methods. Internal methods are usually preceded with a _
+
+=cut
+
+
+# Let the code begin...
+
+package Bio::Root::HTTPget;
+
+use strict;
+use IO::Socket qw(:DEFAULT :crlf);
+
+use base qw(Bio::Root::Root);
+
+
+=head2 get
+
+ Title : get
+ Usage : my $resp = get(-url => $url);
+ Function:
+ Returns : string
+ Args : -url => URL to HTTPGet
+ -proxy => proxy to use
+ -user => username for proxy or authentication
+ -pass => password for proxy or authentication
+ -timeout => timeout
+
+=cut
+
+sub get {
+ my $self;
+ if( ref($_[0]) ) {
+ $self = shift;
+ }
+
+ my ($url,$proxy,$timeout,$auth_user,$auth_pass) =
+ __PACKAGE__->_rearrange([qw(URL PROXY TIMEOUT USER PASS)],@_);
+ my $dest = $proxy || $url;
+
+ my ($host,$port,$path,$user,$pass)
+ = _http_parse_url($dest) or __PACKAGE__->throw("invalid URL $url");
+ $auth_user ||= $user;
+ $auth_pass ||= $pass;
+ if ($self) {
+ unless ($proxy) {
+ $proxy = $self->proxy;
+ }
+ unless ($auth_user) {
+ ($auth_user, $auth_pass) = $self->authentication;
+ }
+ }
+ $path = $url if $proxy;
+
+ # set up the connection
+ my $socket = _http_connect($host,$port) or __PACKAGE__->throw("can't connect: $@");
+
+ # the request
+ print $socket "GET $path HTTP/1.0$CRLF";
+ print $socket "User-Agent: Bioperl fallback fetcher/1.0$CRLF";
+ # Support virtual hosts
+ print $socket "HOST: $host$CRLF";
+
+ if ($auth_user && $auth_pass) { # authentication information
+ my $token = _encode_base64("$auth_user:$auth_pass");
+ print $socket "Authorization: Basic $token$CRLF";
+ }
+ print $socket "$CRLF";
+
+ # read the response
+ my $response;
+ {
+ local $/ = "$CRLF$CRLF";
+ $response = <$socket>;
+ }
+
+ my ($status_line,@other_lines) = split $CRLF,$response;
+ my ($stat_code,$stat_msg) = $status_line =~ m!^HTTP/1\.[01] (\d+) (.+)!
+ or __PACKAGE__->throw("invalid response from web server: got $response");
+
+ my %headers = map {/^(\S+): (.+)/} @other_lines;
+ if ($stat_code == 302 || $stat_code == 301) { # redirect
+ my $location = $headers{Location} or
+ __PACKAGE__->throw("invalid redirect: no Location header");
+ return get(-url => $location, -proxy => $proxy, -timeout => $timeout, -user => $auth_user, -pass => $auth_pass); # recursive call
+ }
+
+ elsif ($stat_code == 401) { # auth required
+ my $auth_required = $headers{'WWW-Authenticate'};
+ $auth_required =~ /^Basic realm="([^\"]+)"/
+ or __PACKAGE__->throw("server requires unknown type of".
+ " authentication: $auth_required");
+ __PACKAGE__->throw("request failed: $status_line, realm = $1");
+ }
+
+ elsif ($stat_code != 200) {
+ __PACKAGE__->throw("request failed: $status_line");
+ }
+
+ $response = '';
+ while (1) {
+ my $bytes = read($socket,$response,2048,length $response);
+ last unless $bytes > 0;
+ }
+
+ $response;
+}
+
+=head2 getFH
+
+ Title : getFH
+ Usage :
+ Function:
+ Example :
+ Returns : string
+ Args :
+
+=cut
+
+sub getFH {
+ my ($url,$proxy,$timeout,$auth_user,$auth_pass) =
+ __PACKAGE__->_rearrange([qw(URL PROXY TIMEOUT USER PASS)],@_);
+ my $dest = $proxy || $url;
+
+ my ($host,$port,$path,$user,$pass)
+ = _http_parse_url($dest) or __PACKAGE__->throw("invalid URL $url");
+ $auth_user ||= $user;
+ $auth_pass ||= $pass;
+ $path = $url if $proxy;
+
+ # set up the connection
+ my $socket = _http_connect($host,$port) or __PACKAGE__->throw("can't connect: $@");
+
+ # the request
+ print $socket "GET $path HTTP/1.0$CRLF";
+ print $socket "User-Agent: Bioperl fallback fetcher/1.0$CRLF";
+ # Support virtual hosts
+ print $socket "HOST: $host$CRLF";
+
+ if ($auth_user && $auth_pass) { # authentication information
+ my $token = _encode_base64("$auth_user:$auth_pass");
+ print $socket "Authorization: Basic $token$CRLF";
+ }
+ print $socket "$CRLF";
+
+ # read the response
+ my $response;
+ {
+ local $/ = "$CRLF$CRLF";
+ $response = <$socket>;
+ }
+
+ my ($status_line,@other_lines) = split $CRLF,$response;
+ my ($stat_code,$stat_msg) = $status_line =~ m!^HTTP/1\.[01] (\d+) (.+)!
+ or __PACKAGE__->throw("invalid response from web server: got $response");
+
+ my %headers = map {/^(\S+): (.+)/} @other_lines;
+ if ($stat_code == 302 || $stat_code == 301) { # redirect
+ my $location = $headers{Location} or
+ __PACKAGE__->throw("invalid redirect: no Location header");
+ return getFH(-url => $location, -proxy => $proxy, -timeout => $timeout, -user => $auth_user, -pass => $auth_pass); # recursive call
+ }
+
+ elsif ($stat_code == 401) { # auth required
+ my $auth_required = $headers{'WWW-Authenticate'};
+ $auth_required =~ /^Basic realm="([^\"]+)"/
+ or __PACKAGE__->throw("server requires unknown type of ".
+ "authentication: $auth_required");
+ __PACKAGE__->throw("request failed: $status_line, realm = $1");
+ }
+
+ elsif ($stat_code != 200) {
+ __PACKAGE__->throw("request failed: $status_line");
+ }
+
+ # Now that we are reasonably sure the socket and request
+ # are OK we pass the socket back as a filehandle so it can
+ # be processed by the caller...
+
+ $socket;
+
+}
+
+
+=head2 _http_parse_url
+
+ Title :
+ Usage :
+ Function:
+ Example :
+ Returns :
+ Args :
+
+=cut
+
+sub _http_parse_url {
+ my $url = shift;
+ my ($user,$pass,$hostent,$path) =
+ $url =~ m!^http://(?:([^:]+):([^:]+)@)?([^/]+)(/?[^\#]*)! or return;
+ $path ||= '/';
+ my ($host,$port) = split(':',$hostent);
+ return ($host,$port||80,$path,$user,$pass);
+}
+
+=head2 _http_connect
+
+ Title :
+ Usage :
+ Function:
+ Example :
+ Returns :
+ Args :
+
+=cut
+
+sub _http_connect {
+ my ($host,$port,$timeout) = @_;
+ my $sock = IO::Socket::INET->new(Proto => 'tcp',
+ Type => SOCK_STREAM,
+ PeerHost => $host,
+ PeerPort => $port,
+ Timeout => $timeout,
+ );
+ $sock;
+}
+
+
+=head2 _encode_base64
+
+ Title :
+ Usage :
+ Function:
+ Example :
+ Returns :
+ Args :
+
+=cut
+
+sub _encode_base64 {
+ my $res = "";
+ my $eol = $_[1];
+ $eol = "\n" unless defined $eol;
+ pos($_[0]) = 0; # ensure start at the beginning
+
+ $res = join '', map( pack('u',$_)=~ /^.(\S*)/, ($_[0]=~/(.{1,45})/gs));
+
+ $res =~ tr|` -_|AA-Za-z0-9+/|; # `# help emacs
+ # fix padding at the end
+ my $padding = (3 - length($_[0]) % 3) % 3;
+ $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
+ # break encoded string into lines of no more than 76 characters each
+ if (length $eol) {
+ $res =~ s/(.{1,76})/$1$eol/g;
+ }
+ return $res;
+}
+
+
+=head2 proxy
+
+ Title : proxy
+ Usage : $httpproxy = $db->proxy('http') or
+ $db->proxy(['http','ftp'], 'http://myproxy' )
+ Function: Get/Set a proxy for use of proxy. Defaults to environment variable
+ http_proxy if present.
+ Returns : a string indicating the proxy
+ Args : $protocol : an array ref of the protocol(s) to set/get
+ $proxyurl : url of the proxy to use for the specified protocol
+ $username : username (if proxy requires authentication)
+ $password : password (if proxy requires authentication)
+
+=cut
+
+sub proxy {
+ my ($self,$protocol,$proxy,$username,$password) = @_;
+ $protocol ||= 'http';
+ unless ($proxy) {
+ if (defined $ENV{http_proxy}) {
+ $proxy = $ENV{http_proxy};
+ if ($proxy =~ /\@/) {
+ ($username, $password, $proxy) = $proxy =~ m{http://(\S+):(\S+)\@(\S+)};
+ $proxy = 'http://'.$proxy;
+ }
+ }
+ }
+ return unless (defined $proxy);
+ $self->authentication($username, $password)
+ if ($username && $password);
+ return $self->{'_proxy'}->{$protocol} = $proxy;
+}
+
+=head2 authentication
+
+ Title : authentication
+ Usage : $db->authentication($user,$pass)
+ Function: Get/Set authentication credentials
+ Returns : Array of user/pass
+ Args : Array or user/pass
+
+
+=cut
+
+sub authentication{
+ my ($self,$u,$p) = @_;
+
+ if( defined $u && defined $p ) {
+ $self->{'_authentication'} = [ $u,$p];
+ }
+ return @{$self->{'_authentication'} || []};
+}
+
+1;
983 Bio/Root/IO.pm
@@ -0,0 +1,983 @@
+# $Id: IO.pm 15565 2009-02-24 02:02:33Z cjfields $
+#
+# BioPerl module for Bio::Root::IO
+#
+# Please direct questions and support issues to <bioperl-l@bioperl.org>
+#
+# Cared for by Hilmar Lapp <hlapp@gmx.net>
+#
+# Copyright Hilmar Lapp
+#
+# You may distribute this module under the same terms as perl itself
+
+# POD documentation - main docs before the code
+
+=head1 NAME
+
+Bio::Root::IO - module providing several methods often needed when dealing with file IO
+
+=head1 SYNOPSIS
+
+ # utilize stream I/O in your module
+ $self->{'io'} = Bio::Root::IO->new(-file => "myfile");
+ $self->{'io'}->_print("some stuff");
+ $line = $self->{'io'}->_readline();
+ $self->{'io'}->_pushback($line);
+ $self->{'io'}->close();
+
+ # obtain platform-compatible filenames
+ $path = Bio::Root::IO->catfile($dir, $subdir, $filename);
+ # obtain a temporary file (created in $TEMPDIR)
+ ($handle) = $io->tempfile();
+
+=head1 DESCRIPTION
+
+This module provides methods that will usually be needed for any sort
+of file- or stream-related input/output, e.g., keeping track of a file
+handle, transient printing and reading from the file handle, a close
+method, automatically closing the handle on garbage collection, etc.
+
+To use this for your own code you will either want to inherit from
+this module, or instantiate an object for every file or stream you are
+dealing with. In the first case this module will most likely not be
+the first class off which your class inherits; therefore you need to
+call _initialize_io() with the named parameters in order to set file
+handle, open file, etc automatically.
+
+Most methods start with an underscore, indicating they are private. In
+OO speak, they are not private but protected, that is, use them in
+your module code, but a client code of your module will usually not
+want to call them (except those not starting with an underscore).
+
+In addition this module contains a couple of convenience methods for
+cross-platform safe tempfile creation and similar tasks. There are
+some CPAN modules related that may not be available on all
+platforms. At present, File::Spec and File::Temp are attempted. This
+module defines $PATHSEP, $TEMPDIR, and $ROOTDIR, which will always be set,
+and $OPENFLAGS, which will be set if either of File::Spec or File::Temp fails.
+
+The -noclose boolean (accessed via the noclose method) prevents a
+filehandle from being closed when the IO object is cleaned up. This
+is special behavior when a object like a parser might share a
+filehandle with an object like an indexer where it is not proper to
+close the filehandle as it will continue to be reused until the end of the
+stream is reached. In general you won't want to play with this flag.
+
+=head1 FEEDBACK
+
+=head2 Mailing Lists
+
+User feedback is an integral part of the evolution of this
+and other Bioperl modules. Send your comments and suggestions preferably
+ to one of the Bioperl mailing lists.
+Your participation is much appreciated.
+
+ bioperl-l@bioperl.org - General discussion
+ http://bioperl.org/wiki/Mailing_lists - About the mailing lists
+
+=head2 Support
+
+Please direct usage questions or support issues to the mailing list:
+
+L<bioperl-l@bioperl.org>
+
+rather than to the module maintainer directly. Many experienced and
+reponsive experts will be able look at the problem and quickly
+address it. Please include a thorough description of the problem
+with code and data examples if at all possible.
+
+=head2 Reporting Bugs
+
+Report bugs to the Bioperl bug tracking system to help us keep track
+the bugs and their resolution. Bug reports can be submitted via the
+web:
+
+ http://bugzilla.open-bio.org/
+
+=head1 AUTHOR - Hilmar Lapp
+
+Email hlapp@gmx.net
+
+=head1 APPENDIX
+
+The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _
+
+=cut
+
+
+# Let the code begin...
+
+
+package Bio::Root::IO;
+use vars qw($FILESPECLOADED $FILETEMPLOADED $FILEPATHLOADED
+ $TEMPDIR $PATHSEP $ROOTDIR $OPENFLAGS $VERBOSE $ONMAC
+ $HAS_LWP
+ );
+use strict;
+
+use Symbol;
+use POSIX qw(dup);
+use IO::Handle;
+use Bio::Root::HTTPget;
+
+use base qw(Bio::Root::Root);
+
+my $TEMPCOUNTER;
+my $HAS_WIN32 = 0;
+#my $HAS_LWP = 1;
+
+BEGIN {
+ $TEMPCOUNTER = 0;
+ $FILESPECLOADED = 0;
+ $FILETEMPLOADED = 0;
+ $FILEPATHLOADED = 0;
+ $VERBOSE = 0;
+
+ # try to load those modules that may cause trouble on some systems
+ eval {
+ require File::Path;
+ $FILEPATHLOADED = 1;
+ };
+ if( $@ ) {
+ print STDERR "Cannot load File::Path: $@" if( $VERBOSE > 0 );
+ # do nothing
+ }
+
+ eval {
+ require LWP::Simple;
+ };
+ if( $@ ) {
+ print STDERR "Cannot load LWP::Simple: $@" if( $VERBOSE > 0 );
+ $HAS_LWP = 0;
+ } else {
+ $HAS_LWP = 1;
+ }
+
+ # If on Win32, attempt to find Win32 package
+
+ if($^O =~ /mswin/i) {
+ eval {
+ require Win32;
+ $HAS_WIN32 = 1;
+ };
+ }
+
+ # Try to provide a path separator. Why doesn't File::Spec export this,
+ # or did I miss it?
+ if($^O =~ /mswin/i) {
+ $PATHSEP = "\\";
+ } elsif($^O =~ /macos/i) {
+ $PATHSEP = ":";
+ } else { # unix
+ $PATHSEP = "/";
+ }
+ eval {
+ require File::Spec;
+ $FILESPECLOADED = 1;
+ $TEMPDIR = File::Spec->tmpdir();
+ $ROOTDIR = File::Spec->rootdir();
+ require File::Temp; # tempfile creation
+ $FILETEMPLOADED = 1;
+ };
+ if( $@ ) {
+ if(! defined($TEMPDIR)) { # File::Spec failed
+ # determine tempdir
+ if (defined $ENV{'TEMPDIR'} && -d $ENV{'TEMPDIR'} ) {
+ $TEMPDIR = $ENV{'TEMPDIR'};
+ } elsif( defined $ENV{'TMPDIR'} && -d $ENV{'TMPDIR'} ) {
+ $TEMPDIR = $ENV{'TMPDIR'};
+ }
+ if($^O =~ /mswin/i) {
+ $TEMPDIR = 'C:\TEMP' unless $TEMPDIR;
+ $ROOTDIR = 'C:';
+ } elsif($^O =~ /macos/i) {
+ $TEMPDIR = "" unless $TEMPDIR; # what is a reasonable default on Macs?
+ $ROOTDIR = ""; # what is reasonable??
+ } else { # unix
+ $TEMPDIR = "/tmp" unless $TEMPDIR;
+ $ROOTDIR = "/";
+ }
+ if (!( -d $TEMPDIR && -w $TEMPDIR )) {
+ $TEMPDIR = '.'; # last resort
+ }
+ }
+ # File::Temp failed (alone, or File::Spec already failed)
+ #
+ # determine open flags for tempfile creation -- we'll have to do this
+ # ourselves
+ use Fcntl;
+ use Symbol;
+ $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR;
+ for my $oflag (qw/FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT TEMPORARY/){
+ my ($bit, $func) = (0, "Fcntl::O_" . $oflag);
+ no strict 'refs';
+ $OPENFLAGS |= $bit if eval { $bit = &$func(); 1 };
+ }
+ }
+ $ONMAC = "\015" eq "\n";
+}
+
+=head2 new
+
+ Title : new
+ Usage :
+ Function: Overridden here to automatically call _initialize_io().
+ Example :
+ Returns : new instance of this class
+ Args : named parameters
+
+
+=cut
+
+sub new {
+ my ($caller, @args) = @_;
+ my $self = $caller->SUPER::new(@args);
+
+ $self->_initialize_io(@args);
+ return $self;
+}
+
+=head2 _initialize_io
+
+ Title : initialize_io
+ Usage : $self->_initialize_io(@params);
+ Function: Initializes filehandle and other properties from the parameters.
+
+ Currently recognizes the following named parameters:
+ -file name of file to open
+ -url name of URL to open