From 265c959688e5173a1145056a0b222871a3630075 Mon Sep 17 00:00:00 2001 From: Brian Osborne Date: Sat, 20 Jun 2015 17:56:37 -0400 Subject: [PATCH] Add Root back, plus some test and doc fixes --- Bio/DB/Taxonomy/sqlite.pm | 2 +- Bio/Index/Fasta.pm | 3 +- Bio/Index/Qual.pm | 3 +- Bio/Restriction/Enzyme.pm | 29 +- Bio/Restriction/IO/prototype.pm | 1 - Bio/Root/Build.pm | 1277 +++++++++++++++++++++++ Bio/Root/Exception.pm | 424 ++++++++ Bio/Root/IO.pm | 1133 +++++++++++++++++++++ Bio/Root/Root.pm | 535 ++++++++++ Bio/Root/RootI.pm | 794 +++++++++++++++ Bio/Root/Storable.pm | 570 +++++++++++ Bio/Root/Test.pm | 571 +++++++++++ Bio/Root/TestObject.pm | 63 ++ Bio/Root/Utilities.pm | 1338 +++++++++++++++++++++++++ Bio/Root/Version.pm | 59 ++ Bio/Tools/Analysis/Protein/Mitoprot.pm | 5 +- BioPerl.pm | 85 +- Build.PL | 972 +++++++++--------- README | 4 +- README.md | 3 +- maintenance/big_split/file_classification.csv | 2 - t/Restriction/IO.t | 52 +- t/Root/Exception.t | 69 ++ t/Root/HTTPget.t | 1 - t/Root/IO.t | 424 ++++++++ t/Root/RootI.t | 320 ++++++ t/Root/RootIO.t | 19 + t/Root/Storable.t | 79 ++ t/Root/Utilities.t | 119 +++ t/Tools/Analysis/Protein/Mitoprot.t | 4 +- t/Tools/Analysis/Protein/NetPhos.t | 1 - t/data/U71225.gb.mac | 1 + 32 files changed, 8363 insertions(+), 599 deletions(-) create mode 100644 Bio/Root/Build.pm create mode 100644 Bio/Root/Exception.pm create mode 100644 Bio/Root/IO.pm create mode 100644 Bio/Root/Root.pm create mode 100644 Bio/Root/RootI.pm create mode 100644 Bio/Root/Storable.pm create mode 100644 Bio/Root/Test.pm create mode 100644 Bio/Root/TestObject.pm create mode 100644 Bio/Root/Utilities.pm create mode 100644 Bio/Root/Version.pm rewrite Build.PL (65%) create mode 100644 t/Root/Exception.t create mode 100644 t/Root/IO.t create mode 100644 t/Root/RootI.t create mode 100644 t/Root/RootIO.t create mode 100644 t/Root/Storable.t create mode 100644 t/Root/Utilities.t create mode 100644 t/data/U71225.gb.mac diff --git a/Bio/DB/Taxonomy/sqlite.pm b/Bio/DB/Taxonomy/sqlite.pm index d79419422..a0e24116e 100644 --- a/Bio/DB/Taxonomy/sqlite.pm +++ b/Bio/DB/Taxonomy/sqlite.pm @@ -42,7 +42,7 @@ A few key differences: @ids = sort $db->get_taxonids('Chloroflexi%'); =item * In-memory database is allowed - + my $db = Bio::DB::Taxonomy->new(-source => 'sqlite', -db => ':memory:', -nodesfile => 'nodes.dmp', diff --git a/Bio/Index/Fasta.pm b/Bio/Index/Fasta.pm index 2acd088b5..25470621e 100644 --- a/Bio/Index/Fasta.pm +++ b/Bio/Index/Fasta.pm @@ -54,8 +54,7 @@ retrieving the sequence from them. For best results 'use strict'. Bio::Index::Fasta supports the Bio::DB::BioSeqI interface, meaning it can be used as a Sequence database for other parts of bioperl -Additional example code is available in scripts/index/*PLS and in -the Bioperl Tutorial (L) +Additional example code is available in scripts/index/. Note that by default the key for the sequence will be the first continuous string after the 'E' in the fasta header. If you want to use a specific diff --git a/Bio/Index/Qual.pm b/Bio/Index/Qual.pm index 4e29ab421..66b1ab32a 100755 --- a/Bio/Index/Qual.pm +++ b/Bio/Index/Qual.pm @@ -52,8 +52,7 @@ retrieving the sequence from them. For best results 'use strict'. Bio::Index::Qual supports the Bio::DB::BioSeqI interface, meaning it can be used as a Sequence database for other parts of bioperl -Additional example code is available in scripts/index/*PLS and in -the Bioperl Tutorial (L). +Additional example code is available in scripts/index. Note that by default the key for the sequence will be the first continuous string after the 'E' in the qual header. If you want to use a specific diff --git a/Bio/Restriction/Enzyme.pm b/Bio/Restriction/Enzyme.pm index 6b7bc1207..7a18baf3b 100644 --- a/Bio/Restriction/Enzyme.pm +++ b/Bio/Restriction/Enzyme.pm @@ -527,11 +527,13 @@ ACCTGC(4/8) is at 6+4 i.e. 10. =cut sub site { - my ($self, $site) = @_; - if ( $site ) { + my ( $self, $site ) = @_; + + if ($site) { $self->throw("Unrecognized characters in site: [$site]") if $site =~ /[^ATGCMRWSYKVHDBN\^]/i; + # we may have to redefine this if there is a ^ in the sequence # first, check and see if we have a cut site in the sequence @@ -539,22 +541,23 @@ sub site { $self->{'_site'} = $site; - my ($first, $second) = $site =~ /(.*)\^(.*)/; + my ( $first, $second ) = $site =~ /(.*)\^(.*)/; $site = "$1$2" if defined $first; $self->{'_site'} = $site; - # now set the recognition site as a new Bio::PrimarySeq object # we need it before calling cut() and complementary_cut() - $self->{_seq} = Bio::PrimarySeq->new(-id=>$self->name, - -seq=>$site, - -verbose=>$self->verbose, - -alphabet=>'dna'); - - if (defined $first) { - $self->cut(length $first); - $self->complementary_cut(length $second); - $self->revcom_site(); + $self->{_seq} = Bio::PrimarySeq->new( + -id => $self->name, + -seq => $site, + -verbose => $self->verbose, + -alphabet => 'dna' + ); + + if ( defined $first ) { + $self->cut( length $first ); + $self->complementary_cut( length $second ); + $self->revcom_site(); } } return $self->{'_site'}; diff --git a/Bio/Restriction/IO/prototype.pm b/Bio/Restriction/IO/prototype.pm index bed07bb14..16fde4330 100644 --- a/Bio/Restriction/IO/prototype.pm +++ b/Bio/Restriction/IO/prototype.pm @@ -76,7 +76,6 @@ package Bio::Restriction::IO::prototype; use vars qw(%WITH_REFM_FIELD); use strict; -#use Bio::Restriction::IO; use Bio::Restriction::Enzyme; use Bio::Restriction::EnzymeCollection; diff --git a/Bio/Root/Build.pm b/Bio/Root/Build.pm new file mode 100644 index 000000000..efb24ee31 --- /dev/null +++ b/Bio/Root/Build.pm @@ -0,0 +1,1277 @@ +package Bio::Root::Build; +use strict; +use warnings; + +=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. + +B: per bug 3196, the majority of the code in this module has been revised +or commented out to bring it in line with the Module::Build API. In particular, +'requires/recommends' tags in the Build.PL file were not of the same format as +those for Module::Build, and so caused serious issues with newer versions +(including giving incorrect meta data). Other problematic methods involving +automatic installation of prereq modules via CPAN were also removed as they do +not work with more modern perl tools such as perlbrew and cpanm. + +=head1 AUTHOR Sendu Bala + +=cut + +BEGIN { + # we really need Module::Build to be installed + eval "use base 'Module::Build'; 1" or die "This package requires Module::Build v0.2805 or greater to install itself.\n$@"; + + # ensure we'll be able to reload this module later by adding its path to inc + use Cwd; + use lib Cwd::cwd(); +} + +our $VERSION = '1.006925'; # 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); + +=head2 find_pm_files + +Our modules are in Bio, not lib +=cut + +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'); +} + +=head2 choose_scripts + +Ask what scripts to install (this method is unique to bioperl) +=cut + +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; + + # only retain top-level script directories (the 'categories') + while (my $thing = readdir($scripts_dir)) { + next if $thing =~ /^\./; + $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"; +} + +=head2 script_files + +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 +=cut + +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$/)} }; +} + +# 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"); +#} + +# TODO: STDERR output redirect is causing some installations to fail, commenting +# out until a fix is in place + +# overriden just to hide pointless ugly warnings +#sub check_installed_status { +# my $self = shift; +# +# open (my $olderr, ">&". fileno(STDERR)); +# my $null = ($^O =~ m/mswin/i) ? 'NUL' : '/dev/null'; +# open(STDERR, $null); +# my $return = $self->SUPER::check_installed_status(@_); +# open(STDERR, ">&". fileno($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); +# next if $status->{ok}; +# +# if ($type =~ /^(?:\w+_)?conflicts$/) { +# $status->{conflicts} = delete $status->{need}; +# $status->{message} = "$modname ($status->{have}) conflicts with this distribution"; +# } +# elsif ($type =~ /^(?:\w+_)?recommends$/) { +# 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 '' +# ? "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/) { +# # 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 { +# 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, $required) = @_; +# +# 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 { +# my $question = $required ? "$desired is absolutely required prior to installation: shall I install it now using a CPAN shell?" : +# "To install $desired I'll need to open a CPAN shell right now; is that OK?"; +# my $do_install = $self->y_n($question.' y/n', 'y'); +# +# if ($do_install) { +# # 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; +# } +# else { +# return $required ? "You chose not to install the REQUIRED module $desired: you'd better install it yourself manually!" : +# "Even though you wanted the optional module $desired, you chose not to actually install it: do it yourself manually."; +# } +# } +#} + +# 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, 1); +#} + +# 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 +# +# my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; +# if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { +# $self->{under_cpan} = $cpan_env ? 'CPAN' : 'CPANPLUS'; +# } +# +# require CPAN; +# +# unless (defined $self->{under_cpan}) { +# if ($CPAN::VERSION > '1.89') { +# if ($cpan_env) { +# $self->{under_cpan} = 'CPAN'; +# } +# else { +# $self->{under_cpan} = 0; +# } +# } +# } +# +# unless (defined $self->{under_cpan}) { +# # load cpan config +# 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/CPANPLUS, so will rely on it 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}; +#} + +=head2 prompt + +Overridden simply to not print the default answer if chosen by hitting return +=cut + +sub prompt { + my $self = shift; + my $mess = shift or die "prompt() called without a prompt message"; + + my $def; + if ( $self->_is_unattended && !@_ ) { + die <_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; +} + +=head2 find_dist_packages + +Like the Module::Build version, except that we always get version from +dist_version + +=cut + +#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 my $key ( grep { exists $prime{$_}->{version} } +# keys %prime ) { +# $prime{$key}->{version} +# = $prime{$key}->{version}->stringify if ref($prime{$key}->{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.9402 nothing useful is done +# with this information, which is why we implement our own request to install +# the optional modules in install_optional(). +# Also note that CPAN PLUS complains with an [ERROR] when it sees this META.yml, +# but it isn't fatal and installation continues fine. + +# 'recommends' groups broken up now into separate modules and grouping the +# 'requires' instead of lumping modules together (quotes were choking YAML +# parsing). Now passes Parse::CPAN::Meta w/o errors. +# -cjfields 9-17-09 + +# 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 my $piece (qw(manifest_skip post_install_scripts)) { +# my $file = File::Spec->catfile($self->config_dir, $piece); +# $ph->{$piece} = Module::Build::Notes->new(file => $file); +# $ph->{$piece}->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 "Could not create directory '$filedir': $!\n" 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); +#} + +=head2 ACTION_manifest + +We always generate a new MANIFEST instead of allowing existing files to remain +MANIFEST.SKIP is left alone +=cut + +sub ACTION_manifest { + my ($self) = @_; + if ( -e 'MANIFEST' || -e 'MANIFEST.SKIP' ) { + $self->log_warn("MANIFEST files already exist, will overwrite them\n"); + unlink('MANIFEST'); + } + 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 append MANIFEST.SKIP file\n"; +# print $fh "\n# Avoid additional run-time generated things\n"; +# foreach my $line (@extra) { +# print $fh $line, "\n"; +# } +# close($fh); +# } +#} + + +=head2 ACTION_install + +Extended to run scripts post-installation +=cut + +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); +# } +#} + +=head2 test_internet + +For use with auto_features, which should require LWP::UserAgent as one of +its reqs + +Note: as of 4-11-11, this is no longer called - if someone wants to run +network tests (off by default) w/o a network, then they are hanging themselves +by their own shoelaces. +=cut + +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; +} + +=head2 dist_dir + +Nice directory names for dist-related actions +=cut + +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"; +} + +# try to be as consistent as possible with Module::Build API +#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*'); +#} + +=head2 ACTION_ppmdist + +Don't copy across man3 docs since they're of little use under Windows and +have bad filenames +=cut + +sub ACTION_ppmdist { + my $self = shift; + my @types = $self->install_types(1); + $self->SUPER::ACTION_ppmdist(@_); + $self->install_types(0); +} + +=head2 install_types + +When supplied a true value, pretends libdoc doesn't exist (preventing man3 +installation for ppmdist). when supplied false, they exist again +=cut + +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 + +# note: no longer needed with more recent versions of Module::Build + +#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"; +# +# $dist{name} +# $dist{abstract} +#@{[ join "\n", map " $_", @{$dist{author}} ]} +# +#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}); +# +#EOF +# } +# +# # rest of softpkg +# $ppd .= <<"PPD"; +# +# +# +# +# +# +#PPD +# +# # now a new softpkg for the bundle +# $ppd .= <<"PPD"; +# +# +# $bundle_name +# Bundle of pre-requisites for $dist{name} +#@{[ join "\n", map " $_", @{$dist{author}} ]} +# +# +# +# +#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 || ''); +# +#EOF +# } +# } +# +# # footer +# $ppd .= <<'EOF'; +# +# +#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; +#} + +=head2 ACTION_dist + +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 +=cut + +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); +} + +=head2 ACTION_clean + +Define custom clean/realclean actions to rearrange config file cleanup +=cut + +sub ACTION_clean { + my ($self) = @_; + $self->log_info("Cleaning up build files\n"); + foreach my $item (map glob($_), $self->cleanup) { + $self->delete_filetree($item); + } + $self->log_info("Cleaning up configuration files\n"); + $self->delete_filetree($self->config_dir); +} + +=head2 ACTION_realclean + +Define custom clean/realclean actions to rearrange config file cleanup +=cut + +sub ACTION_realclean { + my ($self) = @_; + $self->depends_on('clean'); + for my $method (qw(mymetafile mymetafile2 build_script)) { + if ($self->can($method)) { + $self->delete_filetree($self->$method); + $self->log_info("Cleaning up $method data\n"); + } + } +} + +=head2 make_zip + +Makes zip file for windows users and bzip2 files as well +=cut + +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"); +} + +=head2 prompt_for_network + +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 Tests') is true +=cut + +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"); + my $use_email = $self->y_n("Do you want to run tests requiring a valid email address? y/n",'n'); + if ($use_email) { + my $address = $self->prompt("Enter email address:"); + $self->notes(email => $address); + } + } + else { + $self->notes(network => 0); + $self->log_info(" - will not run internet-requiring tests\n"); + } +} + +=head2 print_build_script + +Override the build script warnings flag +=cut + +sub print_build_script { + my ($self, $fh) = @_; + + my $build_package = $self->build_class; + + my $closedata=""; + + my $config_requires; + if ( -f $self->metafile ) { + my $meta = eval { $self->read_metafile( $self->metafile ) }; + $config_requires = $meta && $meta->{configure_requires}{'Module::Build'}; + } + $config_requires ||= 0; + + my %q = map {$_, $self->$_()} qw(config_dir base_dir); + + $q{base_dir} = Win32::GetShortPathName($q{base_dir}) if $self->is_windowsish; + + $q{magic_numfile} = $self->config_file('magicnum'); + + my @myINC = $self->_added_to_INC; + @myINC = map { $_ = File::Spec->canonpath( $_ ); + $_ =~ s/([\\\'])/\\$1/g; + $_; + } @myINC; + # Remove duplicates + @myINC = sort {$a cmp $b} + keys %{ { map { $_ => 1 } @myINC } }; + + foreach my $key (keys %q) { + $q{$key} = File::Spec->canonpath( $q{$key} ); + $q{$key} =~ s/([\\\'])/\\$1/g; + } + + my $quoted_INC = join ",\n", map " '$_'", @myINC; + my $shebang = $self->_startperl; + my $magic_number = $self->magic_number; + + # unique to bioperl, shut off overly verbose warnings on windows, bug 3215 + my $w = $^O =~ /win/i ? '# no warnings (win)' : '$^W = 1; # Use warnings'; + + print $fh <; + close \$FH; + return \$filenum == $magic_number; +} + +my \$progname; +my \$orig_dir; +BEGIN { + $w + \$progname = basename(\$0); + \$orig_dir = Cwd::cwd(); + my \$base_dir = '$q{base_dir}'; + if (!magic_number_matches()) { + unless (chdir(\$base_dir)) { + die ("Could not chdir '\$base_dir', aborting\\n"); + } + unless (magic_number_matches()) { + die ("Configuration seems to be out of date, please re-run 'perl Build.PL' again.\\n"); + } + } + unshift \@INC, + ( +$quoted_INC + ); +} + +close(*DATA) unless eof(*DATA); # ensure no open handles to this script + +use $build_package; +Module::Build->VERSION(q{$config_requires}); + +# Some platforms have problems setting \$^X in shebang contexts, fix it up here +\$^X = Module::Build->find_perl_interpreter; + +if (-e 'Build.PL' and not $build_package->up_to_date('Build.PL', \$progname)) { + warn "Warning: Build.PL has been altered. You may need to run 'perl Build.PL' again.\\n"; +} + +# This should have just enough arguments to be able to bootstrap the rest. +my \$build = + $build_package->resume( properties => { config_dir => '$q{config_dir}', + orig_dir => \$orig_dir, }, +); + +\$build->dispatch; +EOF +} + +1; diff --git a/Bio/Root/Exception.pm b/Bio/Root/Exception.pm new file mode 100644 index 000000000..f2458b1a8 --- /dev/null +++ b/Bio/Root/Exception.pm @@ -0,0 +1,424 @@ +package Bio::Root::Exception; +use strict; + +=head1 SYNOPSIS + +=head2 Throwing exceptions using L: + + use Bio::Root::Exception; + use Error; + + # Set Error::Debug to include stack trace data in the error messages + $Error::Debug = 1; + + $file = shift; + open my $IN, '<', $file + or Bio::Root::FileOpenException->throw("Could not read file '$file': $!"); + +=head2 Throwing exceptions using L: + + # Here we have an object that ISA Bio::Root::Root, so it inherits throw(). + + open my $IN, '<', $file + or $object->throw(-class => 'Bio::Root::FileOpenException', + -text => "Could not read file '$file'", + -value => $!); + +=head2 Catching and handling exceptions using L: + + 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; + + my $file = shift; + my $IN; + try { + open $IN, '<', $file + or Bio::Root::FileOpenException->throw("Could not read file '$file': $!"); + } + catch Bio::Root::FileOpenException with { + my $err = shift; + print STDERR "Using default input file: $default_file\n"; + open $IN, '<', $default_file or die "Could not read file '$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 + +These are generic exceptions for typical problem situations that could arise +in any module or script. + +=for :list +* C +* C +* C +* C +* C +* C +* C +* C + +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 module available from CPAN. Despite this dependency, the +L module does not explicitly C. +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 which can use Error.pm +when it's available. See documentation in Bio::Root::Root for details. + +=head1 SEE ALSO + +See the C directory of the Bioperl distribution for +working demo code. + +L for information about throwing +L-based exceptions. + +L (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 EXCEPTIONS + +=head1 AUTHOR Steve Chervitz + +=cut + +my $debug = $Error::Debug; # Prevents the "used only once" warning. +my $DEFAULT_VALUE = "__DUMMY__"; # Permits eval{} based handlers to work + +=head2 L + + 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 ); +#--------------------------------------------------------- + +=head1 Methods defined by Bio::Root::Exception + +=head2 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 + specifying -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; +} + +=head2 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; +} + + +=head2 _reformat_stacktrace + +Reformatting of the stack performed by _reformat_stacktrace: +for :list +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. + +=cut + +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; +} + +=head2 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 + +=cut + +sub stringify { + my ($self, @args) = @_; + return $self->pretty_format( @args ); +} + +=head1 Subclasses of Bio::Root::Exception + +=head2 L + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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; diff --git a/Bio/Root/IO.pm b/Bio/Root/IO.pm new file mode 100644 index 000000000..df680786c --- /dev/null +++ b/Bio/Root/IO.pm @@ -0,0 +1,1133 @@ +package Bio::Root::IO; + +use strict; +use Symbol; +use IO::Handle; +use File::Copy; +use Fcntl; +use base qw(Bio::Root::Root); + +=head1 SYNOPSIS + + # Use stream I/O in your module + $self->{'io'} = Bio::Root::IO->new(-file => "myfile"); + $self->{'io'}->_print("some stuff"); + my $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 AUTHOR Hilmar Lapp + +=cut + +our ($FILESPECLOADED, $FILETEMPLOADED, + $FILEPATHLOADED, $TEMPDIR, + $PATHSEP, $ROOTDIR, + $OPENFLAGS, $VERBOSE, + $ONMAC, $HAS_EOL, ); + +my $TEMPCOUNTER; +my $HAS_WIN32 = 0; + +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 + } + + # 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 using Fcntl + $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 : my $io = Bio::Root::IO->new( -file => 'data.txt' ); + Function: Create new class instance. It automatically calls C<_initialize_io>. + Args : Same named parameters as C<_initialize_io>. + Returns : A Bio::Root::IO object + +=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 : $io->_initialize_io(@params); + Function: Initializes filehandle and other properties from the parameters. + Args : The following named parameters are currently recognized: + -file name of file to read or write to + -fh file handle to read or write to (mutually exclusive + with -file and -string) + -input name of file, or filehandle (GLOB or IO::Handle object) + to read of write to + -string string to read from (will be converted to filehandle) + -url name of URL to open + -flush boolean flag to autoflush after each write + -noclose boolean flag, when set to true will not close a + filehandle (must explicitly call close($io->_fh) + -retries number of times to try a web fetch before failure + -ua_parms when using -url, hashref of key => value parameters + to pass to LWP::UserAgent->new(). A useful value might + be, for example, {timeout => 60 } (ua defaults to 180s) + Returns : True + +=cut + +sub _initialize_io { + my($self, @args) = @_; + + $self->_register_for_cleanup(\&_io_cleanup); + + my ($input, $noclose, $file, $fh, $string, + $flush, $url, $retries, $ua_parms) = + $self->_rearrange([qw(INPUT NOCLOSE FILE FH STRING FLUSH URL RETRIES UA_PARMS)], + @args); + + my $mode; + + if ($url) { + $retries ||= 5; + + require LWP::UserAgent; + my $ua = LWP::UserAgent->new(%$ua_parms); + my $http_result; + my ($handle, $tempfile) = $self->tempfile(); + CORE::close($handle); + + for (my $try = 1 ; $try <= $retries ; $try++) { + $http_result = $ua->get($url, ':content_file' => $tempfile); + $self->warn("[$try/$retries] tried to fetch $url, but server ". + "threw ". $http_result->code . ". retrying...") + if !$http_result->is_success; + last if $http_result->is_success; + } + $self->throw("Failed to fetch $url, server threw ".$http_result->code) + if !$http_result->is_success; + + $file = $tempfile; + $mode = '>'; + } + + delete $self->{'_readbuffer'}; + delete $self->{'_filehandle'}; + $self->noclose( $noclose) if defined $noclose; + # determine whether the input is a file(name) or a stream + if ($input) { + if (ref(\$input) eq 'SCALAR') { + # we assume that a scalar is a filename + if ($file && ($file ne $input)) { + $self->throw("Input file given twice: '$file' and '$input' disagree"); + } + $file = $input; + } elsif (ref($input) && + ((ref($input) eq 'GLOB') || $input->isa('IO::Handle'))) { + # input is a stream + $fh = $input; + } else { + # let's be strict for now + $self->throw("Unable to determine type of input $input: ". + "not string and not GLOB"); + } + } + + if (defined($file) && defined($fh)) { + $self->throw("Providing both a file and a filehandle for reading - ". + "only one please!"); + } + + if ($string) { + if (defined($file) || defined($fh)) { + $self->throw("File or filehandle provided with -string, ". + "please unset if you are using -string as a file"); + } + open $fh, '<', \$string or $self->throw("Could not read string: $!"); + } + + if (defined($file) && ($file ne '')) { + $self->file($file); + ($mode, $file) = $self->cleanfile; + $mode ||= '<'; + my $action = ($mode =~ m/>/) ? 'write' : 'read'; + $fh = Symbol::gensym(); + open $fh, $mode, $file or $self->throw("Could not $action file '$file': $!"); + } + + if (defined $fh) { + # check filehandle to ensure it's one of: + # a GLOB reference, as in: open(my $fh, "myfile"); + # an IO::Handle or IO::String object + # the UNIVERSAL::can added to fix Bug2863 + unless ( ( ref $fh and ( ref $fh eq 'GLOB' ) ) + or ( ref $fh and ( UNIVERSAL::can( $fh, 'can' ) ) + and ( $fh->isa('IO::Handle') + or $fh->isa('IO::String') ) ) + ) { + $self->throw("Object $fh does not appear to be a file handle"); + } + if ($HAS_EOL) { + binmode $fh, ':raw:eol(LF-Native)'; + } + $self->_fh($fh); # if $fh not provided, defaults to STDIN and STDOUT + } + + $self->_flush_on_write(defined $flush ? $flush : 1); + + return 1; +} + + +=head2 _fh + + Title : _fh + Usage : $io->_fh($newval); + Function: Get or set the file handle for the stream encapsulated. + Args : Optional filehandle to use + Returns : Filehandle for the stream + +=cut + +sub _fh { + my ($self, $value) = @_; + if ( defined $value) { + $self->{'_filehandle'} = $value; + } + return $self->{'_filehandle'}; +} + + +=head2 mode + + Title : mode + Usage : $io->mode(); + $io->mode(-force => 1); + Function: Determine if the object was opened for reading or writing + Args : -force: Boolean. Once mode() has been called, the mode is cached for + further calls to mode(). Use this argument to override this + behavior and re-check the object's mode. + Returns : Mode of the object: + 'r' for readable + 'w' for writable + 'rw' for readable and writable + '?' if mode could not be determined (e.g. for a -url) + +=cut + +sub mode { + my ($self, %arg) = @_; + + # Method 1: IO::Handle::fdopen + # my $iotest = new IO::Handle; + # $iotest->fdopen( dup(fileno($fh)) , 'r' ); + # if ($iotest->error == 0) { ... } + # It did not actually seem to work under any platform, since there would no + # error if the filehandle had been opened writable only. It could not be + # hacked around when dealing with unseekable (piped) filehandles. + + # Method 2: readline, a.k.a. the <> operator + # no warnings "io"; + # my $line = <$fh>; + # if (defined $line) { + # $self->{'_mode'} = 'r'; + # ... + # It did not work well either because <> returns undef, i.e. querying the + # mode() after having read an entire file returned 'w'. + + if ( $arg{-force} || not exists $self->{'_mode'} ) { + # Determine stream mode + my $mode; + my $fh = $self->_fh; + if (defined $fh) { + # Determine read/write status of filehandle + no warnings 'io'; + if ( defined( read $fh, my $content, 0 ) ) { + # Successfully read 0 bytes + $mode = 'r' + } + if ( defined( syswrite $fh, '') ) { + # Successfully wrote 0 bytes + $mode ||= ''; + $mode .= 'w'; + } + } else { + # Stream does not have a filehandle... cannot determine mode + $mode = '?'; + } + # Save mode for future use + $self->{'_mode'} = $mode; + } + return $self->{'_mode'}; +} + + +=head2 file + + Title : file + Usage : $io->file('>'.$file); + my $file = $io->file; + Function: Get or set the name of the file to read or write. + Args : Optional file name (including its mode, e.g. '<' for reading or '>' + for writing) + Returns : A string representing the filename and its mode. + +=cut + +sub file { + my ($self, $value) = @_; + if ( defined $value) { + $self->{'_file'} = $value; + } + return $self->{'_file'}; +} + + +=head2 cleanfile + + Title : cleanfile + Usage : my ($mode, $file) = $io->cleanfile; + Function: Get the name of the file to read or write, stripped of its mode + ('>', '<', '+>', '>>', etc). + Args : None + Returns : In array context, an array of the mode and the clean filename. + +=cut + +sub cleanfile { + my ($self) = @_; + return ($self->{'_file'} =~ m/^ (\+?[><]{1,2})?\s*(.*) $/x); +} + + +=head2 format + + Title : format + Usage : $io->format($newval) + Function: Get the format of a Bio::Root::IO sequence file or filehandle. Every + object inheriting Bio::Root::IO is guaranteed to have a format. + Args : None + Returns : Format of the file or filehandle, e.g. fasta, fastq, genbank, embl. + +=cut + +sub format { + my ($self) = @_; + my $format = (split '::', ref($self))[-1]; + return $format; +} + + +=head2 variant + + Title : format + Usage : $io->format($newval) + Function: Get the variant of a Bio::Root::IO sequence file or filehandle. + The format variant depends on the specific format used. Note that + not all formats have variants. Also, the Bio::Root::IO-implementing + modules that require access to variants need to define a global hash + that has the allowed variants as its keys. + Args : None + Returns : Variant of the file or filehandle, e.g. sanger, solexa or illumina for + the fastq format, or undef for formats that do not have variants. + +=cut + +sub variant { + my ($self, $variant) = @_; + if (defined $variant) { + $variant = lc $variant; + my $var_name = '%'.ref($self).'::variant'; + my %ok_variants = eval $var_name; # e.g. %Bio::Assembly::IO::ace::variant + if (scalar keys %ok_variants == 0) { + $self->throw("Could not validate variant because global variant ". + "$var_name was not set or was empty\n"); + } + if (not exists $ok_variants{$variant}) { + $self->throw("$variant is not a valid variant of the " . + $self->format . ' format'); + } + $self->{variant} = $variant; + } + return $self->{variant}; +} + + +=head2 _print + + Title : _print + Usage : $io->_print(@lines) + Function: Print lines of text to the IO stream object. + Args : List of strings to print + Returns : True on success, undef on failure + +=cut + +sub _print { + my $self = shift; + my $fh = $self->_fh() || \*STDOUT; + my $ret = print $fh @_; + return $ret; +} + + +=head2 _insert + + Title : _insert + Usage : $io->_insert($string,1) + Function: Insert some text in a file at the given line number (1-based). + Args : * string to write in file + * line number to insert the string at + Returns : True + +=cut + +sub _insert { + my ($self, $string, $line_num) = @_; + # Line number check + if ($line_num < 1) { + $self->throw("Could not insert text at line $line_num: the minimum ". + "line number possible is 1."); + } + # File check + my ($mode, $file) = $self->cleanfile; + if (not defined $file) { + $self->throw('Could not insert a line: IO object was initialized with '. + 'something else than a file.'); + } + # Everything that needs to be written is written before we read it + $self->flush; + + # Edit the file line by line (no slurping) + $self->close; + my $temp_file; + my $number = 0; + while (-e "$file.$number.temp") { + $number++; + } + $temp_file = "$file.$number.temp"; + copy($file, $temp_file); + open my $fh1, '<', $temp_file or $self->throw("Could not read temporary file '$temp_file': $!"); + open my $fh2, '>', $file or $self->throw("Could not write file '$file': $!"); + while (my $line = <$fh1>) { + if ($. == $line_num) { # right line for new data + print $fh2 $string . $line; + } + else { + print $fh2 $line; + } + } + CORE::close $fh1; + CORE::close $fh2; + unlink $temp_file or $self->throw("Could not delete temporary file '$temp_file': $!"); + + # Line number check (again) + if ( $. > 0 && $line_num > $. ) { + $self->throw("Could not insert text at line $line_num: there are only ". + "$. lines in file '$file'"); + } + # Re-open the file in append mode to be ready to add text at the end of it + # when the next _print() statement comes + open my $new_fh, '>>', $file or $self->throw("Could not append to file '$file': $!"); + $self->_fh($new_fh); + # If file is empty and we're inserting at line 1, simply append text to file + if ( $. == 0 && $line_num == 1 ) { + $self->_print($string); + } + return 1; +} + + +=head2 _readline + + Title : _readline + Usage : local $Bio::Root::IO::HAS_EOL = 1; + my $io = Bio::Root::IO->new(-file => 'data.txt'); + my $line = $io->_readline(); + $io->close; + Function: Read a line of input and normalize all end of line characters. + + End of line characters are typically "\n" on Linux platforms, "\r\n" + on Windows and "\r" on older Mac OS. By default, the _readline() + method uses the value of $/, Perl's input record separator, to + detect the end of each line. This means that you will not get the + expected lines if your input has Mac-formatted end of line characters. + Also, note that the current implementation does not handle pushed + back input correctly unless the pushed back input ends with the + value of $/. For each line parsed, its line ending, e.g. "\r\n" is + converted to "\n", unless you provide the -raw argument. + + Altogether it is easier to let the PerlIO::eol module automatically + detect the proper end of line character and normalize it to "\n". Do + so by setting $Bio::Root::IO::HAS_EOL to 1. + + Args : -raw : Avoid converting end of line characters to "\n" This option + has no effect when using $Bio::Root::IO::HAS_EOL = 1. + Returns : Line of input, or undef when there is nothing to read anymore + +=cut + +sub _readline { + my ($self, %param) = @_; + my $fh = $self->_fh or return; + my $line; + + # if the buffer been filled by _pushback then return the buffer + # contents, rather than read from the filehandle + if( @{$self->{'_readbuffer'} || [] } ) { + $line = shift @{$self->{'_readbuffer'}}; + } else { + $line = <$fh>; + } + + # Note: In Windows the "-raw" parameter has no effect, because Perl already discards + # the '\r' from the line when reading in text mode from the filehandle + # ($line = <$fh>), and put it back automatically when printing + if( !$HAS_EOL && !$param{-raw} && (defined $line) ) { + # don't strip line endings if -raw or $HAS_EOL is specified + $line =~ s/\015\012/\012/g; # Change all CR/LF pairs to LF + $line =~ tr/\015/\n/ unless $ONMAC; # Change all single CRs to NEWLINE + } + return $line; +} + + +=head2 _pushback + + Title : _pushback + Usage : $io->_pushback($newvalue) + Function: Puts a line previously read with _readline back into a buffer. + buffer can hold as many lines as system memory permits. + + Note that this is only supported for pushing back data ending with + the current, localized value of $/. Using this method to push + modified data back onto the buffer stack is not supported; see bug + 843. + + Args : newvalue + Returns : True + +=cut + +# fix for bug 843, this reveals some unsupported behavior + +#sub _pushback { +# my ($self, $value) = @_; +# if (index($value, $/) >= 0) { +# push @{$self->{'_readbuffer'}}, $value; +# } else { +# $self->throw("Pushing modifed data back not supported: $value"); +# } +#} + +sub _pushback { + my ($self, $value) = @_; + return unless $value; + unshift @{$self->{'_readbuffer'}}, $value; + return 1; +} + + +=head2 close + + Title : close + Usage : $io->close() + Function: Closes the file handle associated with this IO instance, + excepted if -noclose was specified. + Args : None + Returns : True + +=cut + +sub close { + my ($self) = @_; + + # do not close if we explicitly asked not to + return if $self->noclose; + + if( defined( my $fh = $self->{'_filehandle'} )) { + $self->flush; + return if ref $fh eq 'GLOB' && ( + \*STDOUT == $fh || \*STDERR == $fh || \*STDIN == $fh + ); + + # don't close IO::Strings + CORE::close $fh unless ref $fh && $fh->isa('IO::String'); + } + $self->{'_filehandle'} = undef; + delete $self->{'_readbuffer'}; + return 1; +} + + +=head2 flush + + Title : flush + Usage : $io->flush() + Function: Flushes the filehandle + Args : None + Returns : True + +=cut + +sub flush { + my ($self) = shift; + + if( !defined $self->{'_filehandle'} ) { + $self->throw("Flush failed: no filehandle was active"); + } + + if( ref($self->{'_filehandle'}) =~ /GLOB/ ) { + my $oldh = select($self->{'_filehandle'}); + $| = 1; + select($oldh); + } else { + $self->{'_filehandle'}->flush(); + } + return 1; +} + + +=head2 noclose + + Title : noclose + Usage : $io->noclose($newval) + Function: Get or set the NOCLOSE flag - setting this to true will prevent a + filehandle from being closed when an object is cleaned up or + explicitly closed. + Args : Optional new value (a scalar or undef) + Returns : Value of noclose (a scalar) + +=cut + +sub noclose { + my $self = shift; + return $self->{'_noclose'} = shift if @_; + return $self->{'_noclose'}; +} + + +=head2 _io_cleanup + +=cut + +sub _io_cleanup { + my ($self) = @_; + $self->close(); + my $v = $self->verbose; + + # we are planning to cleanup temp files no matter what + if ( exists($self->{'_rootio_tempfiles'}) + and ref($self->{'_rootio_tempfiles'}) =~ /array/i + and not $self->save_tempfiles + ) { + if( $v > 0 ) { + warn( "going to remove files ", + join(",", @{$self->{'_rootio_tempfiles'}}), + "\n"); + } + unlink (@{$self->{'_rootio_tempfiles'}} ); + } + # cleanup if we are not using File::Temp + if ( $self->{'_cleanuptempdir'} + and exists($self->{'_rootio_tempdirs'}) + and ref($self->{'_rootio_tempdirs'}) =~ /array/i + and not $self->save_tempfiles + ) { + if( $v > 0 ) { + warn( "going to remove dirs ", + join(",", @{$self->{'_rootio_tempdirs'}}), + "\n"); + } + $self->rmtree( $self->{'_rootio_tempdirs'}); + } +} + + +=head2 exists_exe + + Title : exists_exe + Usage : $exists = $io->exists_exe('clustalw'); + $exists = Bio::Root::IO->exists_exe('clustalw') + $exists = Bio::Root::IO::exists_exe('clustalw') + Function: Determines whether the given executable exists either as file + or within the path environment. The latter requires File::Spec + to be installed. + On Win32-based system, .exe is automatically appended to the program + name unless the program name already ends in .exe. + Args : Name of the executable + Returns : 1 if the given program is callable as an executable, and 0 otherwise + +=cut + +sub exists_exe { + my ($self, $exe) = @_; + $self->throw("Must pass a defined value to exists_exe") unless defined $exe; + $exe = $self if (!(ref($self) || $exe)); + $exe .= '.exe' if(($^O =~ /mswin/i) && ($exe !~ /\.(exe|com|bat|cmd)$/i)); + return $exe if ( -f $exe && -x $exe ); # full path and exists + + # Ewan's comment. I don't think we need this. People should not be + # asking for a program with a pathseparator starting it + # $exe =~ s/^$PATHSEP//; + + # Not a full path, or does not exist. Let's see whether it's in the path. + if($FILESPECLOADED) { + for my $dir (File::Spec->path()) { + my $f = Bio::Root::IO->catfile($dir, $exe); + return $f if( -f $f && -x $f ); + } + } + return 0; +} + + +=head2 tempfile + + Title : tempfile + Usage : my ($handle,$tempfile) = $io->tempfile(); + Function: Create a temporary filename and a handle opened for reading and + writing. + Caveats: If you do not have File::Temp on your system you should + avoid specifying TEMPLATE and SUFFIX. + Args : Named parameters compatible with File::Temp: DIR (defaults to + $Bio::Root::IO::TEMPDIR), TEMPLATE, SUFFIX. + Returns : A 2-element array, consisting of temporary handle and temporary + file name. + +=cut + +sub tempfile { + my ($self, @args) = @_; + my ($tfh, $file); + my %params = @args; + + # map between naming with and without dash + for my $key (keys(%params)) { + if( $key =~ /^-/ ) { + my $v = $params{$key}; + delete $params{$key}; + $params{uc(substr($key,1))} = $v; + } else { + # this is to upper case + my $v = $params{$key}; + delete $params{$key}; + $params{uc($key)} = $v; + } + } + $params{'DIR'} = $TEMPDIR if(! exists($params{'DIR'})); + unless (exists $params{'UNLINK'} && + defined $params{'UNLINK'} && + ! $params{'UNLINK'} ) { + $params{'UNLINK'} = 1; + } else { + $params{'UNLINK'} = 0; + } + + if($FILETEMPLOADED) { + if(exists($params{'TEMPLATE'})) { + my $template = $params{'TEMPLATE'}; + delete $params{'TEMPLATE'}; + ($tfh, $file) = File::Temp::tempfile($template, %params); + } else { + ($tfh, $file) = File::Temp::tempfile(%params); + } + } else { + my $dir = $params{'DIR'}; + $file = $self->catfile( + $dir, + (exists($params{'TEMPLATE'}) ? + $params{'TEMPLATE'} : + sprintf( "%s.%s.%s", $ENV{USER} || 'unknown', $$, $TEMPCOUNTER++)) + ); + + # sneakiness for getting around long filenames on Win32? + if( $HAS_WIN32 ) { + $file = Win32::GetShortPathName($file); + } + + # Try to make sure this will be marked close-on-exec + # XXX: Win32 doesn't respect this, nor the proper fcntl, + # but may have O_NOINHERIT. This may or may not be in Fcntl. + local $^F = 2; + # Store callers umask + my $umask = umask(); + # Set a known umaskr + umask(066); + # Attempt to open the file + if ( sysopen($tfh, $file, $OPENFLAGS, 0600) ) { + # Reset umask + umask($umask); + } else { + $self->throw("Could not write temporary file '$file': $!"); + } + } + + if( $params{'UNLINK'} ) { + push @{$self->{'_rootio_tempfiles'}}, $file; + } + + return wantarray ? ($tfh,$file) : $tfh; +} + + +=head2 tempdir + + Title : tempdir + Usage : my ($tempdir) = $io->tempdir(CLEANUP=>1); + Function: Creates and returns the name of a new temporary directory. + + Note that you should not use this function for obtaining "the" + temp directory. Use $Bio::Root::IO::TEMPDIR for that. Calling this + method will in fact create a new directory. + + Args : args - ( key CLEANUP ) indicates whether or not to cleanup + dir on object destruction, other keys as specified by File::Temp + Returns : The name of a new temporary directory. + +=cut + +sub tempdir { + my ($self, @args) = @_; + if ($FILETEMPLOADED && File::Temp->can('tempdir')) { + return File::Temp::tempdir(@args); + } + + # we have to do this ourselves, not good + # we are planning to cleanup temp files no matter what + my %params = @args; + print "cleanup is " . $params{CLEANUP} . "\n"; + $self->{'_cleanuptempdir'} = ( defined $params{CLEANUP} && + $params{CLEANUP} == 1); + my $tdir = $self->catfile( $TEMPDIR, + sprintf("dir_%s-%s-%s", + $ENV{USER} || 'unknown', + $$, + $TEMPCOUNTER++)); + mkdir($tdir, 0755); + push @{$self->{'_rootio_tempdirs'}}, $tdir; + return $tdir; +} + + +=head2 catfile + + Title : catfile + Usage : $path = Bio::Root::IO->catfile(@dirs, $filename); + Function: Constructs a full pathname in a cross-platform safe way. + + If File::Spec exists on your system, this routine will merely + delegate to it. Otherwise it tries to make a good guess. + + You should use this method whenever you construct a path name + from directory and filename. Otherwise you risk cross-platform + compatibility of your code. + + You can call this method both as a class and an instance method. + + Args : components of the pathname (directories and filename, NOT an + extension) + Returns : a string + +=cut + +sub catfile { + my ($self, @args) = @_; + + return File::Spec->catfile(@args) if $FILESPECLOADED; + # this is clumsy and not very appealing, but how do we specify the + # root directory? + if($args[0] eq '/') { + $args[0] = $ROOTDIR; + } + return join($PATHSEP, @args); +} + + +=head2 rmtree + + Title : rmtree + Usage : Bio::Root::IO->rmtree($dirname ); + Function: Remove a full directory tree + + If File::Path exists on your system, this routine will merely + delegate to it. Otherwise it runs a local version of that code. + + You should use this method to remove directories which contain + files. + + You can call this method both as a class and an instance method. + + Args : roots - rootdir to delete or reference to list of dirs + + verbose - a boolean value, which if TRUE will cause + C to print a message each time it + examines a file, giving the name of the file, and + indicating whether it's using C or + C to remove it, or that it's skipping it. + (defaults to FALSE) + + safe - a boolean value, which if TRUE will cause C + to skip any files to which you do not have delete + access (if running under VMS) or write access (if + running under another OS). This will change in the + future when a criterion for 'delete permission' + under OSs other than VMS is settled. (defaults to + FALSE) + Returns : number of files successfully deleted + +=cut + +# taken straight from File::Path VERSION = "1.0403" +sub rmtree { + my ($self, $roots, $verbose, $safe) = @_; + if ( $FILEPATHLOADED ) { + return File::Path::rmtree ($roots, $verbose, $safe); + } + + my $force_writable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' || + $^O eq 'amigaos' || $^O eq 'cygwin'); + my $Is_VMS = $^O eq 'VMS'; + + my @files; + my $count = 0; + $verbose ||= 0; + $safe ||= 0; + if ( defined($roots) && length($roots) ) { + $roots = [$roots] unless ref $roots; + } else { + $self->warn("No root path(s) specified\n"); + return 0; + } + + my $root; + for $root (@{$roots}) { + $root =~ s#/\z##; + (undef, undef, my $rp) = lstat $root or next; + $rp &= 07777; # don't forget setuid, setgid, sticky bits + if ( -d _ ) { + # notabene: 0777 is for making readable in the first place, + # it's also intended to change it to writable in case we have + # to recurse in which case we are better than rm -rf for + # subtrees with strange permissions + chmod(0777, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) + or $self->warn("Could not make directory '$root' read+writable: $!") + unless $safe; + if (opendir DIR, $root){ + @files = readdir DIR; + closedir DIR; + } else { + $self->warn("Could not read directory '$root': $!"); + @files = (); + } + + # Deleting large numbers of files from VMS Files-11 filesystems + # is faster if done in reverse ASCIIbetical order + @files = reverse @files if $Is_VMS; + ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS; + @files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files); + $count += $self->rmtree([@files],$verbose,$safe); + if ($safe && + ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { + print "skipped '$root'\n" if $verbose; + next; + } + chmod 0777, $root + or $self->warn("Could not make directory '$root' writable: $!") + if $force_writable; + print "rmdir '$root'\n" if $verbose; + if (rmdir $root) { + ++$count; + } + else { + $self->warn("Could not remove directory '$root': $!"); + chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root)) + or $self->warn("and can't restore permissions to " + . sprintf("0%o",$rp) . "\n"); + } + } + else { + if ( $safe + and ($Is_VMS ? !&VMS::Filespec::candelete($root) + : !(-l $root || -w $root)) + ) { + print "skipped '$root'\n" if $verbose; + next; + } + chmod 0666, $root + or $self->warn( "Could not make file '$root' writable: $!") + if $force_writable; + warn "unlink '$root'\n" if $verbose; + # delete all versions under VMS + for (;;) { + unless (unlink $root) { + $self->warn("Could not unlink file '$root': $!"); + if ($force_writable) { + chmod $rp, $root + or $self->warn("and can't restore permissions to " + . sprintf("0%o",$rp) . "\n"); + } + last; + } + ++$count; + last unless $Is_VMS && lstat $root; + } + } + } + + return $count; +} + + +=head2 _flush_on_write + + Title : _flush_on_write + Usage : $io->_flush_on_write($newval) + Function: Boolean flag to indicate whether to flush + the filehandle on writing when the end of + a component is finished (Sequences, Alignments, etc) + Args : Optional new value + Returns : Value of _flush_on_write + +=cut + +sub _flush_on_write { + my ($self, $value) = @_; + if (defined $value) { + $self->{'_flush_on_write'} = $value; + } + return $self->{'_flush_on_write'}; +} + + +=head2 save_tempfiles + + Title : save_tempfiles + Usage : $io->save_tempfiles(1) + Function: Boolean flag to indicate whether to retain tempfiles/tempdir + Args : Value evaluating to TRUE or FALSE + Returns : Boolean value : 1 = save tempfiles/tempdirs, 0 = remove (default) + +=cut + +sub save_tempfiles { + my $self = shift; + if (@_) { + my $value = shift; + $self->{save_tempfiles} = $value ? 1 : 0; + } + return $self->{save_tempfiles} || 0; +} + + +1; diff --git a/Bio/Root/Root.pm b/Bio/Root/Root.pm new file mode 100644 index 000000000..e8b85624b --- /dev/null +++ b/Bio/Root/Root.pm @@ -0,0 +1,535 @@ +package Bio::Root::Root; +use strict; +use Bio::Root::IO; +use Scalar::Util qw(blessed reftype); +use base qw(Bio::Root::RootI); + +=head1 SYNOPSIS + + # Any Bioperl-compliant object is a RootI compliant object + + # Here's how to throw and catch an exception using the eval-based syntax. + + $obj->throw("This is an exception"); + + eval { + $obj->throw("This is catching an exception"); + }; + + if( $@ ) { + print "Caught exception"; + } else { + print "no exception"; + } + + # Alternatively, using the new typed exception syntax in the throw() call: + + $obj->throw( -class => 'Bio::Root::BadParameter', + -text => "Can not open file $file", + -value => $file ); + + # Want to see debug() outputs for this object + + my $obj = Bio::Object->new(-verbose=>1); + + my $obj = Bio::Object->new(%args); + $obj->verbose(2); + + # Print debug messages which honour current verbosity setting + + $obj->debug("Boring output only to be seen if verbose > 0\n"); + + # Deep-object copy + + my $clone = $obj->clone; + +=head1 DESCRIPTION + +This is a hashref-based implementation of the Bio::Root::RootI +interface. Most Bioperl objects should inherit from this. + +See the documentation for L for most of the methods +implemented by this module. Only overridden methods are described +here. + +=head2 Throwing Exceptions + +One of the functionalities that L provides is the +ability to L() exceptions with pretty stack traces. Bio::Root::Root +enhances this with the ability to use L (available from CPAN) +if it has also been installed. + +If L has been installed, L() will use it. This causes an +Error.pm-derived object to be thrown. This can be caught within a +C block, from wich you can extract useful bits of +information. If L is not installed, it will use the +L-based exception throwing facilty. + +=head2 Typed Exception Syntax + +The typed exception syntax of L() has the advantage of plainly +indicating the nature of the trouble, since the name of the class +is included in the title of the exception output. + +To take advantage of this capability, you must specify arguments +as named parameters in the L() call. Here are the parameters: + +=over 4 + +=item -class + +name of the class of the exception. +This should be one of the classes defined in L, +or a custom error of yours that extends one of the exceptions +defined in L. + +=item -text + +a sensible message for the exception + +=item -value + +the value causing the exception or $!, if appropriate. + +=back + +Note that Bio::Root::Exception does not need to be imported into +your module (or script) namespace in order to throw exceptions +via Bio::Root::Root::throw(), since Bio::Root::Root imports it. + +=head2 Try-Catch-Finally Support + +In addition to using an eval{} block to handle exceptions, you can +also use a try-catch-finally block structure if L has been +installed in your system (available from CPAN). See the documentation +for Error for more details. + +Here's an example. See the L module for +other pre-defined exception types: + + my $IN; + try { + open $IN, '<', $file or $obj->throw( -class => 'Bio::Root::FileOpenException', + -text => "Cannot read file '$file'", + -value => $!); + } + catch Bio::Root::BadParameter with { + my $err = shift; # get the Error object + # Perform specific exception handling code for the FileOpenException + } + catch Bio::Root::Exception with { + my $err = shift; # get the Error object + # Perform general exception handling code for any Bioperl exception. + } + otherwise { + # A catch-all for any other type of exception + } + finally { + # Any code that you want to execute regardless of whether or not + # an exception occurred. + }; + # the ending semicolon is essential! + +=head1 AUTHOR Steve Chervitz + +Ewan Birney, Lincoln Stein + +=cut + +our ($DEBUG, $ID, $VERBOSITY, $ERRORLOADED, $CLONE_CLASS); + +BEGIN { + $ID = 'Bio::Root::Root'; + $DEBUG = 0; + $VERBOSITY = 0; + $ERRORLOADED = 0; + + # Check whether or not Error.pm is available. + + # $main::DONT_USE_ERROR is intended for testing purposes and also + # when you don't want to use the Error module, even if it is installed. + # Just put a INIT { $DONT_USE_ERROR = 1; } at the top of your script. + if( not $main::DONT_USE_ERROR ) { + if ( eval "require Error; 1;" ) { + import Error qw(:try); + require Bio::Root::Exception; + $ERRORLOADED = 1; + $Error::Debug = 1; # enable verbose stack trace + } + } + if( !$ERRORLOADED ) { + require Carp; import Carp qw( confess ); + } + + # set up _dclone() + for my $class (qw(Clone Storable)) { + eval "require $class; 1;"; + if (!$@) { + $CLONE_CLASS = $class; + if ($class eq 'Clone') { + *Bio::Root::Root::_dclone = sub {shift; return Clone::clone(shift)}; + } else { + *Bio::Root::Root::_dclone = sub { + shift; + local $Storable::Deparse = 1; + local $Storable::Eval = 1; + return Storable::dclone(shift); + }; + } + last; + } + } + if (!defined $CLONE_CLASS) { + *Bio::Root::Root::_dclone = sub { + my ($self, $orig, $level) = @_; + my $class = Scalar::Util::blessed($orig) || ''; + my $reftype = Scalar::Util::reftype($orig) || ''; + my $data; + if (!$reftype) { + $data = $orig + } elsif ($reftype eq "ARRAY") { + $data = [map $self->_dclone($_), @$orig]; + } elsif ($reftype eq "HASH") { + $data = { map { $_ => $self->_dclone($orig->{$_}) } keys %$orig }; + } elsif ($reftype eq 'CODE') { # nothing, maybe shallow copy? + $self->throw("Code reference cloning not supported; install Clone or Storable from CPAN"); + } else { $self->throw("What type is $_?")} + if ($class) { + bless $data, $class; + } + $data; + } + } + + $main::DONT_USE_ERROR; # so that perl -w won't warn "used only once" +} + +=head2 new + + Purpose : generic instantiation function can be overridden if + special needs of a module cannot be done in _initialize + +=cut + +sub new { +# my ($class, %param) = @_; + my $class = shift; + my $self = {}; + bless $self, ref($class) || $class; + + if(@_ > 1) { + # if the number of arguments is odd but at least 3, we'll give + # it a try to find -verbose + shift if @_ % 2; + my %param = @_; + ## See "Comments" above regarding use of _rearrange(). + $self->verbose($param{'-VERBOSE'} || $param{'-verbose'}); + } + return $self; +} + + +=head2 clone + + Title : clone + Usage : my $clone = $obj->clone(); + or + my $clone = $obj->clone( -start => 110 ); + Function: Deep recursion copying of any object via Storable dclone() + Returns : A cloned object. + Args : Any named parameters provided will be set on the new object. + Unnamed parameters are ignored. + Comments: Where possible, faster clone methods are used, in order: + Clone::Fast::clone(), Clone::clone(), Storable::dclone. If neither + is present, a pure perl fallback (not very well tested) is used + instead. Storable dclone() cannot clone CODE references. Therefore, + any CODE reference in your original object will remain, but will not + exist in the cloned object. This should not be used for anything + other than cloning of simple objects. Developers of subclasses are + encouraged to override this method with one of their own. + +=cut + +sub clone { + my ($orig, %named_params) = @_; + + __PACKAGE__->throw("Can't call clone() as a class method") unless + ref $orig && $orig->isa('Bio::Root::Root'); + + # Can't dclone CODE references... + # Should we shallow copy these? Should be harmless for these specific + # methods... + + my %put_these_back = ( + _root_cleanup_methods => $orig->{'_root_cleanup_methods'}, + ); + delete $orig->{_root_cleanup_methods}; + + # call the proper clone method, set lazily above + my $clone = __PACKAGE__->_dclone($orig); + + $orig->{_root_cleanup_methods} = $put_these_back{_root_cleanup_methods}; + + foreach my $key (grep { /^-/ } keys %named_params) { + my $method = $key; + $method =~ s/^-//; + if ($clone->can($method)) { + $clone->$method($named_params{$key}) + } else { + $orig->warn("Parameter $method is not a method for ".ref($clone)); + } + } + return $clone; +} + +=head2 _dclone + + Title : clone + Usage : my $clone = $obj->_dclone($ref); + or + my $clone = $obj->_dclone($ref); + Function: Returns a copy of the object passed to it (a deep clone) + Returns : clone of passed argument + Args : Anything + NOTE : This differs from clone significantly in that it does not clone + self, but the data passed to it. This code may need to be optimized + or overridden as needed. + Comments: This is set in the BEGIN block to take advantage of optimized + cloning methods if Clone or Storable is present, falling back to a + pure perl kludge. May be moved into a set of modules if the need + arises. At the moment, code ref cloning is not supported. + +=cut + +=head2 verbose + + Title : verbose + Usage : $self->verbose(1) + Function: Sets verbose level for how ->warn behaves + -1 = no warning + 0 = standard, small warning + 1 = warning with stack trace + 2 = warning becomes throw + Returns : The current verbosity setting (integer between -1 to 2) + Args : -1,0,1 or 2 + + +=cut + +sub verbose { + my ($self,$value) = @_; + # allow one to set global verbosity flag + return $DEBUG if $DEBUG; + return $VERBOSITY unless ref $self; + + if (defined $value || ! defined $self->{'_root_verbose'}) { + $self->{'_root_verbose'} = $value || 0; + } + return $self->{'_root_verbose'}; +} + +=head2 _register_for_cleanup + +=cut + +sub _register_for_cleanup { + my ($self,$method) = @_; + if ($method) { + if(! exists($self->{'_root_cleanup_methods'})) { + $self->{'_root_cleanup_methods'} = []; + } + push(@{$self->{'_root_cleanup_methods'}},$method); + } +} + +=head2 _unregister_for_cleanup + +=cut + +sub _unregister_for_cleanup { + my ($self,$method) = @_; + my @methods = grep {$_ ne $method} $self->_cleanup_methods; + $self->{'_root_cleanup_methods'} = \@methods; +} + +=head2 _cleanup_methods + +=cut + +sub _cleanup_methods { + my $self = shift; + return unless ref $self && $self->isa('HASH'); + my $methods = $self->{'_root_cleanup_methods'} or return; + @$methods; +} + +=head2 throw + + Title : throw + Usage : $obj->throw("throwing exception message"); + or + $obj->throw( -class => 'Bio::Root::Exception', + -text => "throwing exception message", + -value => $bad_value ); + Function: Throws an exception, which, if not caught with an eval or + a try block will provide a nice stack trace to STDERR + with the message. + If Error.pm is installed, and if a -class parameter is + provided, Error::throw will be used, throwing an error + of the type specified by -class. + If Error.pm is installed and no -class parameter is provided + (i.e., a simple string is given), A Bio::Root::Exception + is thrown. + Returns : n/a + Args : A string giving a descriptive error message, optional + Named parameters: + '-class' a string for the name of a class that derives + from Error.pm, such as any of the exceptions + defined in Bio::Root::Exception. + Default class: Bio::Root::Exception + '-text' a string giving a descriptive error message + '-value' the value causing the exception, or $! (optional) + + Thus, if only a string argument is given, and Error.pm is available, + this is equivalent to the arguments: + -text => "message", + -class => Bio::Root::Exception + Comments : If Error.pm is installed, and you don't want to use it + for some reason, you can block the use of Error.pm by + Bio::Root::Root::throw() by defining a scalar named + $main::DONT_USE_ERROR (define it in your main script + and you don't need the main:: part) and setting it to + a true value; you must do this within a BEGIN subroutine. + +=cut + +sub throw { + my ($self, @args) = @_; + + my ($text, $class, $value) = $self->_rearrange( [qw(TEXT + CLASS + VALUE)], @args); + $text ||= $args[0] if @args == 1; + + if ($ERRORLOADED) { + # Enable re-throwing of Error objects. + # If the error is not derived from Bio::Root::Exception, + # we can't guarantee that the Error's value was set properly + # and, ipso facto, that it will be catchable from an eval{}. + # But chances are, if you're re-throwing non-Bio::Root::Exceptions, + # you're probably using Error::try(), not eval{}. + # TODO: Fix the MSG: line of the re-thrown error. Has an extra line + # containing the '----- EXCEPTION -----' banner. + if (ref($args[0])) { + if( $args[0]->isa('Error')) { + my $class = ref $args[0]; + $class->throw( @args ); + } + else { + my $text .= "\nWARNING: Attempt to throw a non-Error.pm object: " . ref$args[0]; + my $class = "Bio::Root::Exception"; + $class->throw( '-text' => $text, '-value' => $args[0] ); + } + } + else { + $class ||= "Bio::Root::Exception"; + + my %args; + if( @args % 2 == 0 && $args[0] =~ /^-/ ) { + %args = @args; + $args{-text} = $text; + $args{-object} = $self; + } + + $class->throw( scalar keys %args > 0 ? %args : @args ); # (%args || @args) puts %args in scalar context! + } + } + else { + $class ||= ''; + $class = ': '.$class if $class; + my $std = $self->stack_trace_dump(); + my $title = "------------- EXCEPTION$class -------------"; + my $footer = ('-' x CORE::length($title))."\n"; + $text ||= ''; + + die "\n$title\n", "MSG: $text\n", $std, $footer, "\n"; + } +} + +=head2 debug + + Title : debug + Usage : $obj->debug("This is debugging output"); + Function: Prints a debugging message when verbose is > 0 + Returns : none + Args : message string(s) to print to STDERR + +=cut + +sub debug { + my ($self, @msgs) = @_; + + # using CORE::warn doesn't give correct backtrace information; we want the + # line from the previous call in the call stack, not this call (similar to + # cluck). For now, just add a stack trace dump and simple comment under the + # correct conditions. + if (defined $self->verbose && $self->verbose > 0) { + if (!@msgs || $msgs[-1] !~ /\n$/) { + push @msgs, "Debugging comment:" if !@msgs; + push @msgs, sprintf("%s %s:%s", @{($self->stack_trace)[2]}[3,1,2])."\n"; + } + CORE::warn @msgs; + } +} + +=head2 _load_module + + Title : _load_module + Usage : $self->_load_module("Bio::SeqIO::genbank"); + Function: Loads up (like use) the specified module at run time on demand. + Example : + Returns : TRUE on success. Throws an exception upon failure. + Args : The module to load (_without_ the trailing .pm). + +=cut + +sub _load_module { + my ($self, $name) = @_; + my ($module, $load, $m); + $module = "_<$name.pm"; + return 1 if $main::{$module}; + + # untaint operation for safe web-based running (modified after + # a fix by Lincoln) HL + if ($name !~ /^([\w:]+)$/) { + $self->throw("$name is an illegal perl package name"); + } else { + $name = $1; + } + + $load = "$name.pm"; + my $io = Bio::Root::IO->new(); + # catfile comes from IO + $load = $io->catfile((split(/::/,$load))); + eval { + require $load; + }; + if ( $@ ) { + $self->throw("Failed to load module $name. ".$@); + } + return 1; +} + +=head2 DESTROY + +=cut + +sub DESTROY { + my $self = shift; + my @cleanup_methods = $self->_cleanup_methods or return; + for my $method (@cleanup_methods) { + $method->($self); + } +} + +1; diff --git a/Bio/Root/RootI.pm b/Bio/Root/RootI.pm new file mode 100644 index 000000000..e3359786a --- /dev/null +++ b/Bio/Root/RootI.pm @@ -0,0 +1,794 @@ +package Bio::Root::RootI; +use strict; +use Carp 'confess','carp'; + +=head1 SYNOPSIS + + # any bioperl or bioperl compliant object is a RootI + # compliant object + + $obj->throw("This is an exception"); + + eval { + $obj->throw("This is catching an exception"); + }; + + if( $@ ) { + print "Caught exception"; + } else { + print "no exception"; + } + + # Using throw_not_implemented() within a RootI-based interface module: + + package Foo; + use base qw(Bio::Root::RootI); + + sub foo { + my $self = shift; + $self->throw_not_implemented; + } + + +=head1 DESCRIPTION + +This is just a set of methods which do not assume B about the object +they are on. The methods provide the ability to throw exceptions with nice +stack traces. + +This is what should be inherited by all Bioperl compliant interfaces, even +if they are exotic XS/CORBA/Other perl systems. + +=head2 Using throw_not_implemented() + +The method L should be +called by all methods within interface modules that extend RootI so +that if an implementation fails to override them, an exception will be +thrown. + +For example, say there is an interface module called C that +provides a method called C. Since this method is considered +abstract within FooI and should be implemented by any module claiming to +implement C, the C method should consist of the +following: + + sub foo { + my $self = shift; + $self->throw_not_implemented; + } + +So, if an implementer of C forgets to implement C +and a user of the implementation calls C, a +L exception will result. + +Unfortunately, failure to implement a method can only be determined at +run time (i.e., you can't verify that an implementation is complete by +running C on it). So it should be standard practice for a test +of an implementation to check each method and verify that it doesn't +throw a L. + +=head1 AUTHOR Steve Chervitz + +Ewan Birney, Lincoln Stein, Steve Chervitz, Sendu Bala, Jason Stajich + +=cut + +use vars qw($DEBUG $ID $VERBOSITY); +BEGIN { + $ID = 'Bio::Root::RootI'; + $DEBUG = 0; + $VERBOSITY = 0; +} + +=head2 new + +=cut + +sub new { + my $class = shift; + my @args = @_; + unless ( $ENV{'BIOPERLDEBUG'} ) { + carp("Use of new in Bio::Root::RootI is deprecated. Please use Bio::Root::Root instead"); + } + eval "require Bio::Root::Root"; + return Bio::Root::Root->new(@args); +} + +# for backwards compatibility +sub _initialize { + my($self,@args) = @_; + return 1; +} + + +=head2 throw + + Title : throw + Usage : $obj->throw("throwing exception message") + Function: Throws an exception, which, if not caught with an eval brace + will provide a nice stack trace to STDERR with the message + Returns : nothing + Args : A string giving a descriptive error message + + +=cut + +sub throw{ + my ($self,$string) = @_; + + my $std = $self->stack_trace_dump(); + + my $out = "\n-------------------- EXCEPTION --------------------\n" + . "MSG: " . $string . "\n" + . $std."-------------------------------------------\n"; + die $out; +} + +=head2 warn + + Title : warn + Usage : $object->warn("Warning message"); + Function: Places a warning. What happens now is down to the + verbosity of the object (value of $obj->verbose) + verbosity 0 or not set => small warning + verbosity -1 => no warning + verbosity 1 => warning with stack trace + verbosity 2 => converts warnings into throw + Returns : n/a + Args : string (the warning message) + +=cut + +sub warn { + my ($self,$string) = @_; + + my $verbose = $self->verbose; + + my $header = "\n--------------------- WARNING ---------------------\nMSG: "; + my $footer = "---------------------------------------------------\n"; + + if ($verbose >= 2) { + $self->throw($string); + } + elsif ($verbose <= -1) { + return; + } + elsif ($verbose == 1) { + CORE::warn $header, $string, "\n", $self->stack_trace_dump, $footer; + return; + } + + CORE::warn $header, $string, "\n", $footer; +} + +=head2 deprecated + + Title : deprecated + Usage : $obj->deprecated("Method X is deprecated"); + $obj->deprecated("Method X is deprecated", 1.007); + $obj->deprecated(-message => "Method X is deprecated"); + $obj->deprecated(-message => "Method X is deprecated", + -version => 1.007); + Function: Prints a message about deprecation unless verbose is < 0 + (which means be quiet) + Returns : none + Args : Message string to print to STDERR + Version of BioPerl where use of the method results in an exception + Notes : The method can be called two ways, either by positional arguments: + + $obj->deprecated('This module is deprecated', 1.006); + + or by named arguments: + + $obj->deprecated( + -message => 'use of the method foo() is deprecated, use bar() instead', + -version => 1.006 # throw if $VERSION is >= this version + ); + + or timed to go off at a certain point: + + $obj->deprecated( + -message => 'use of the method foo() is deprecated, use bar() instead', + -warn_version => 1.006 # warn if $VERSION is >= this version + -throw_version => 1.007 # throw if $VERSION is >= this version + ); + + Using the last two named argument versions is suggested and will + likely be the only supported way of calling this method in the future + Yes, we see the irony of deprecating that particular usage of + deprecated(). + + The main difference between usage of the two named argument versions + is that by designating a 'warn_version' one indicates the + functionality is officially deprecated beginning in a future version + of BioPerl (so warnings are issued only after that point), whereas + setting either 'version' or 'throw_version' (synonyms) converts the + deprecation warning to an exception. + + For proper comparisons one must use a version in lines with the + current versioning scheme for Perl and BioPerl, (i.e. where 1.006000 + indicates v1.6.0, 5.010000 for v5.10.0, etc.). + +=cut + +sub deprecated{ + my ($self) = shift; + + my $class = ref $self || $self; + my $class_version = do { + no strict 'refs'; + ${"${class}::VERSION"} + }; + + if( $class_version && $class_version =~ /set by/ ) { + $class_version = 0.0001; + } + + my ($msg, $version, $warn_version, $throw_version) = + $self->_rearrange([qw(MESSAGE VERSION WARN_VERSION THROW_VERSION)], @_); + + $throw_version ||= $version; + $warn_version ||= $class_version; + + for my $v ( $warn_version, $throw_version) { + no warnings 'numeric'; + $self->throw("Version must be numerical, such as 1.006000 for v1.6.0, not $v") + unless !defined $v || $v + 0 eq $v; + } + + # below default insinuates we're deprecating a method and not a full module + # but it's the most common use case + $msg ||= "Use of ".(caller(1))[3]."() is deprecated."; + + if( $throw_version && $class_version && $class_version >= $throw_version ) { + $self->throw($msg) + } + elsif( $warn_version && $class_version && $class_version >= $warn_version ) { + + $msg .= "\nTo be removed in $throw_version." if $throw_version; + + # passing this on to warn() should deal properly with verbosity issues + $self->warn($msg); + } +} + +=head2 stack_trace_dump + + Title : stack_trace_dump + Usage : + Function: + Example : + Returns : + Args : + + +=cut + +sub stack_trace_dump{ + my ($self) = @_; + + my @stack = $self->stack_trace(); + + shift @stack; + shift @stack; + shift @stack; + + my $out; + my ($module,$function,$file,$position); + + + foreach my $stack ( @stack) { + ($module,$file,$position,$function) = @{$stack}; + $out .= "STACK $function $file:$position\n"; + } + + return $out; +} + + +=head2 stack_trace + + Title : stack_trace + Usage : @stack_array_ref= $self->stack_trace + Function: gives an array to a reference of arrays with stack trace info + each coming from the caller(stack_number) call + Returns : array containing a reference of arrays + Args : none + + +=cut + +sub stack_trace{ + my ($self) = @_; + + my $i = 0; + my @out = (); + my $prev = []; + while( my @call = caller($i++)) { + # major annoyance that caller puts caller context as + # function name. Hence some monkeying around... + $prev->[3] = $call[3]; + push(@out,$prev); + $prev = \@call; + } + $prev->[3] = 'toplevel'; + push(@out,$prev); + return @out; +} + + +=head2 _rearrange + + Usage : $object->_rearrange( array_ref, list_of_arguments) + Purpose : Rearranges named parameters to requested order. + Example : $self->_rearrange([qw(SEQUENCE ID DESC)],@param); + : Where @param = (-sequence => $s, + : -desc => $d, + : -id => $i); + Returns : @params - an array of parameters in the requested order. + : The above example would return ($s, $i, $d). + : Unspecified parameters will return undef. For example, if + : @param = (-sequence => $s); + : the above _rearrange call would return ($s, undef, undef) + Argument : $order : a reference to an array which describes the desired + : order of the named parameters. + : @param : an array of parameters, either as a list (in + : which case the function simply returns the list), + : or as an associative array with hyphenated tags + : (in which case the function sorts the values + : according to @{$order} and returns that new array.) + : The tags can be upper, lower, or mixed case + : but they must start with a hyphen (at least the + : first one should be hyphenated.) + Source : This function was taken from CGI.pm, written by Dr. Lincoln + : Stein, and adapted for use in Bio::Seq by Richard Resnick and + : then adapted for use in Bio::Root::Object.pm by Steve Chervitz, + : then migrated into Bio::Root::RootI.pm by Ewan Birney. + Comments : + : Uppercase tags are the norm, + : (SAC) + : This method may not be appropriate for method calls that are + : within in an inner loop if efficiency is a concern. + : + : Parameters can be specified using any of these formats: + : @param = (-name=>'me', -color=>'blue'); + : @param = (-NAME=>'me', -COLOR=>'blue'); + : @param = (-Name=>'me', -Color=>'blue'); + : @param = ('me', 'blue'); + : A leading hyphenated argument is used by this function to + : indicate that named parameters are being used. + : Therefore, the ('me', 'blue') list will be returned as-is. + : + : Note that Perl will confuse unquoted, hyphenated tags as + : function calls if there is a function of the same name + : in the current namespace: + : -name => 'foo' is interpreted as -&name => 'foo' + : + : For ultimate safety, put single quotes around the tag: + : ('-name'=>'me', '-color' =>'blue'); + : This can be a bit cumbersome and I find not as readable + : as using all uppercase, which is also fairly safe: + : (-NAME=>'me', -COLOR =>'blue'); + : + : Personal note (SAC): I have found all uppercase tags to + : be more manageable: it involves less single-quoting, + : the key names stand out better, and there are no method naming + : conflicts. + : The drawbacks are that it's not as easy to type as lowercase, + : and lots of uppercase can be hard to read. + : + : Regardless of the style, it greatly helps to line + : the parameters up vertically for long/complex lists. + : + : Note that if @param is a single string that happens to start with + : a dash, it will be treated as a hash key and probably fail to + : match anything in the array_ref, so not be returned as normally + : happens when @param is a simple list and not an associative array. + +=cut + +sub _rearrange { + my ($self, $order, @args) = @_; + + return @args unless $args[0] && $args[0] =~ /^\-/; + + push @args, undef unless $#args % 2; + + my %param; + for( my $i = 0; $i < @args; $i += 2 ) { + (my $key = $args[$i]) =~ tr/a-z\055/A-Z/d; #deletes all dashes! + $param{$key} = $args[$i+1]; + } + return @param{map uc, @$order}; +} + +=head2 _set_from_args + + Usage : $object->_set_from_args(\%args, -methods => \@methods) + Purpose : Takes a hash of user-supplied args whose keys match method names, + : and calls the method supplying it the corresponding value. + Example : $self->_set_from_args(\%args, -methods => [qw(sequence id desc)]); + : Where %args = (-sequence => $s, + : -description => $d, + : -ID => $i); + : + : the above _set_from_args calls the following methods: + : $self->sequence($s); + : $self->id($i); + : ( $self->description($i) is not called because 'description' wasn't + : one of the given methods ) + Argument : \%args | \@args : a hash ref or associative array ref of arguments + : where keys are any-case strings corresponding to + : method names but optionally prefixed with + : hyphens, and values are the values the method + : should be supplied. If keys contain internal + : hyphens (eg. to separate multi-word args) they + : are converted to underscores, since method names + : cannot contain dashes. + : -methods => [] : (optional) only call methods with names in this + : array ref. Can instead supply a hash ref where + : keys are method names (of real existing methods + : unless -create is in effect) and values are array + : refs of synonyms to allow access to the method + : using synonyms. If there is only one synonym it + : can be supplied as a string instead of a single- + : element array ref + : -force => bool : (optional, default 0) call methods that don't + : seem to exist, ie. let AUTOLOAD handle them + : -create => bool : (optional, default 0) when a method doesn't + : exist, create it as a simple getter/setter + : (combined with -methods it would create all the + : supplied methods that didn't exist, even if not + : mentioned in the supplied %args) + : -code => '' | {}: (optional) when creating methods use the supplied + : code (a string which will be evaulated as a sub). + : The default code is a simple get/setter. + : Alternatively you can supply a hash ref where + : the keys are method names and the values are + : code strings. The variable '$method' will be + : available at evaluation time, so can be used in + : your code strings. Beware that the strict pragma + : will be in effect. + : -case_sensitive => bool : require case sensitivity on the part of + : user (ie. a() and A() are two different + : methods and the user must be careful + : which they use). + Comments : + : The \%args argument will usually be the args received during new() + : from the user. The user is allowed to get the case wrong, include + : 0 or more than one hyphens as a prefix, and to include hyphens as + : multi-word arg separators: '--an-arg' => 1, -an_arg => 1 and + : An_Arg => 1 are all equivalent, calling an_arg(1). However, in + : documentation users should only be told to use the standard form + : -an_arg to avoid confusion. A possible exception to this is a + : wrapper module where '--an-arg' is what the user is used to + : supplying to the program being wrapped. + : + : Another issue with wrapper modules is that there may be an + : argument that has meaning both to Bioperl and to the program, eg. + : -verbose. The recommended way of dealing with this is to leave + : -verbose to set the Bioperl verbosity whilst requesting users use + : an invented -program_verbose (or similar) to set the program + : verbosity. This can be resolved back with + : Bio::Tools::Run::WrapperBase's _setparams() method and code along + : the lines of: + : my %methods = map { $_ => $_ } @LIST_OF_ALL_ALLOWED_PROGRAM_ARGS + : delete $methods{'verbose'}; + : $methods{'program_verbose'} = 'verbose'; + : my $param_string = $self->_setparams(-methods => \%methods); + : system("$exe $param_string"); + +=cut + +sub _set_from_args { + my ($self, $args, @own_args) = @_; + $self->throw("a hash/array ref of arguments must be supplied") unless ref($args); + + my ($methods, $force, $create, $code, $case); + if (@own_args) { + ($methods, $force, $create, $code, $case) = + $self->_rearrange([qw(METHODS + FORCE + CREATE + CODE + CASE_SENSITIVE)], @own_args); + } + my $default_code = 'my $self = shift; + if (@_) { $self->{\'_\'.$method} = shift } + return $self->{\'_\'.$method};'; + + my %method_names = (); + my %syns = (); + if ($methods) { + my @names; + if (ref($methods) eq 'HASH') { + @names = keys %{$methods}; + %syns = %{$methods}; + } + else { + @names = @{$methods}; + %syns = map { $_ => $_ } @names; + } + %method_names = map { $case ? $_ : lc($_) => $_ } @names; + } + + # deal with hyphens + my %orig_args = ref($args) eq 'HASH' ? %{$args} : @{$args}; + my %args; + while (my ($method, $value) = each %orig_args) { + $method =~ s/^-+//; + $method =~ s/-/_/g; + $args{$method} = $value; + } + + # create non-existing methods on request + if ($create) { + unless ($methods) { + %syns = map { $_ => $case ? $_ : lc($_) } keys %args; + } + + foreach my $method (keys %syns) { + $self->can($method) && next; + + my $string = $code || $default_code; + if (ref($code) && ref($code) eq 'HASH') { + $string = $code->{$method} || $default_code; + } + + my $sub = eval "sub { $string }"; + $self->throw("Compilation error for $method : $@") if $@; + + no strict 'refs'; + *{ref($self).'::'.$method} = $sub; + } + } + + # create synonyms of existing methods + while (my ($method, $syn_ref) = each %syns) { + my $method_ref = $self->can($method) || next; + + foreach my $syn (@{ ref($syn_ref) ? $syn_ref : [$syn_ref] }) { + next if $syn eq $method; + $method_names{$case ? $syn : lc($syn)} = $syn; + next if $self->can($syn); + no strict 'refs'; + *{ref($self).'::'.$syn} = $method_ref; + } + } + + # set values for methods + while (my ($method, $value) = each %args) { + $method = $method_names{$case ? $method : lc($method)} || ($methods ? next : $method); + $self->can($method) || next unless $force; + $self->$method($value); + } +} + + +=head2 _rearrange_old + +=cut + +#----------------' +sub _rearrange_old { +#---------------- + my($self,$order,@param) = @_; + + # JGRG -- This is wrong, because we don't want + # to assign empty string to anything, and this + # code is actually returning an array 1 less + # than the length of @param: + + ## If there are no parameters, we simply wish to return + ## an empty array which is the size of the @{$order} array. + #return ('') x $#{$order} unless @param; + + # ...all we need to do is return an empty array: + # return unless @param; + + # If we've got parameters, we need to check to see whether + # they are named or simply listed. If they are listed, we + # can just return them. + + # The mod test fixes bug where a single string parameter beginning with '-' gets lost. + # This tends to happen in error messages such as: $obj->throw("-id not defined") + return @param unless (defined($param[0]) && $param[0]=~/^-/o && ($#param % 2)); + + # Tester +# print "\n_rearrange() named parameters:\n"; +# my $i; for ($i=0;$i<@param;$i+=2) { printf "%20s => %s\n", $param[$i],$param[$i+1]; }; ; + + # Now we've got to do some work on the named parameters. + # The next few lines strip out the '-' characters which + # preceed the keys, and capitalizes them. + for (my $i=0;$i<@param;$i+=2) { + $param[$i]=~s/^\-//; + $param[$i]=~tr/a-z/A-Z/; + } + + # Now we'll convert the @params variable into an associative array. + # local($^W) = 0; # prevent "odd number of elements" warning with -w. + my(%param) = @param; + + # my(@return_array); + + # What we intend to do is loop through the @{$order} variable, + # and for each value, we use that as a key into our associative + # array, pushing the value at that key onto our return array. + # my($key); + + #foreach (@{$order}) { + # my($value) = $param{$key}; + # delete $param{$key}; + #push(@return_array,$param{$_}); + #} + + return @param{@{$order}}; + +# print "\n_rearrange() after processing:\n"; +# my $i; for ($i=0;$i<@return_array;$i++) { printf "%20s => %s\n", ${$order}[$i], $return_array[$i]; } ; + + # return @return_array; +} + +=head2 _register_for_cleanup + + Title : _register_for_cleanup + Usage : -- internal -- + Function: Register a method to be called at DESTROY time. This is useful + and sometimes essential in the case of multiple inheritance for + classes coming second in the sequence of inheritance. + Returns : + Args : a code reference + +The code reference will be invoked with the object as the first +argument, as per a method. You may register an unlimited number of +cleanup methods. + +=cut + +sub _register_for_cleanup { + my ($self,$method) = @_; + $self->throw_not_implemented(); +} + +=head2 _unregister_for_cleanup + + Title : _unregister_for_cleanup + Usage : -- internal -- + Function: Remove a method that has previously been registered to be called + at DESTROY time. If called with a method to be called at DESTROY time. + Has no effect if the code reference has not previously been registered. + Returns : nothing + Args : a code reference + +=cut + +sub _unregister_for_cleanup { + my ($self,$method) = @_; + $self->throw_not_implemented(); +} + +=head2 _cleanup_methods + + Title : _cleanup_methods + Usage : -- internal -- + Function: Return current list of registered cleanup methods. + Returns : list of coderefs + Args : none + +=cut + +sub _cleanup_methods { + my $self = shift; + unless ( $ENV{'BIOPERLDEBUG'} || $self->verbose > 0 ) { + carp("Use of Bio::Root::RootI is deprecated. Please use Bio::Root::Root instead"); + } + return; +} + +=head2 throw_not_implemented + + Purpose : Throws a Bio::Root::NotImplemented exception. + Intended for use in the method definitions of + abstract interface modules where methods are defined + but are intended to be overridden by subclasses. + Usage : $object->throw_not_implemented(); + Example : sub method_foo { + $self = shift; + $self->throw_not_implemented(); + } + Returns : n/a + Args : n/a + Throws : A Bio::Root::NotImplemented exception. + The message of the exception contains + - the name of the method + - the name of the interface + - the name of the implementing class + + If this object has a throw() method, $self->throw will be used. + If the object doesn't have a throw() method, + Carp::confess() will be used. + + +=cut + +#' + +sub throw_not_implemented { + my $self = shift; + + # Bio::Root::Root::throw() knows how to check for Error.pm and will + # throw an Error-derived object of the specified class (Bio::Root::NotImplemented), + # which is defined in Bio::Root::Exception. + # If Error.pm is not available, the name of the class is just included in the + # error message. + + my $message = $self->_not_implemented_msg; + + if ( $self->can('throw') ) { + my @args; + if ( $self->isa('Bio::Root::Root') ) { + # Use Root::throw() hash-based arguments instead of RootI::throw() + # single string argument whenever possible + @args = ( -text => $message, -class => 'Bio::Root::NotImplemented' ); + } else { + @args = ( $message ); + } + $self->throw(@args); + + } else { + confess $message; + } +} + + +=head2 warn_not_implemented + + Purpose : Generates a warning that a method has not been implemented. + Intended for use in the method definitions of + abstract interface modules where methods are defined + but are intended to be overridden by subclasses. + Generally, throw_not_implemented() should be used, + but warn_not_implemented() may be used if the method isn't + considered essential and convenient no-op behavior can be + provided within the interface. + Usage : $object->warn_not_implemented( method-name-string ); + Example : $self->warn_not_implemented( "get_foobar" ); + Returns : Calls $self->warn on this object, if available. + If the object doesn't have a warn() method, + Carp::carp() will be used. + Args : n/a + + +=cut + +#' + +sub warn_not_implemented { + my $self = shift; + my $message = $self->_not_implemented_msg; + if( $self->can('warn') ) { + $self->warn( $message ); + }else { + carp $message ; + } +} + +=head2 _not_implemented_msg + +Unify 'not implemented' message. -Juguang +=cut + +sub _not_implemented_msg { + my $self = shift; + my $package = ref $self; + my $meth = (caller(2))[3]; + my $msg =<new(); + + # Store/retrieve using class retriever + my $token = $storable->store(); + my $storable2 = Bio::Root::Storable->retrieve( $token ); + + # Store/retrieve using object retriever + my $storable2 = $storable->new_retrievable(); + $storable2->retrieve(); + +=head1 DESCRIPTION + +Generic module that allows objects to be safely stored/retrieved from +disk. Can be inhereted by any BioPerl object. As it will not usually +be the first class in the inheretence list, _initialise_storable() +should be called during object instantiation. + +Object storage is recursive; If the object being stored contains other +storable objects, these will be stored separately, and replaced by a +skeleton object in the parent heirarchy. When the parent is later +retrieved, its children remain in the skeleton state until explicitly +retrieved by the parent. This lazy-retrieve approach has obvious +memory efficiency benefits for certain applications. + + +By default, objects are stored in binary format (using the Perl +Storable module). Earlier versions of Perl5 do not include Storable as +a core module. If this is the case, ASCII object storage (using the +Perl Data::Dumper module) is used instead. + +ASCII storage can be enabled by default by setting the value of +$Bio::Root::Storable::BINARY to false. + +=head1 AUTHOR Will Spooner + +=cut + +use vars qw( $BINARY ); + +BEGIN{ + if( eval "require Storable" ){ + Storable->import( 'freeze', 'thaw' ); + $BINARY = 1; + } +} + +#---------------------------------------------------------------------- + +=head2 new + + Arg [1] : -workdir => filesystem path, + -template => tmpfile template, + -suffix => tmpfile suffix, + Function : Builds a new Bio::Root::Storable inhereting object + Returntype: Bio::Root::Storable inhereting object + Exceptions: + Caller : + Example : $storable = Bio::Root::Storable->new() + +=cut + +sub new { + my ($caller, @args) = @_; + my $self = $caller->SUPER::new(@args); + $self->_initialise_storable; + return $self; +} + +#---------------------------------------------------------------------- + +=head2 _initialise_storable + + Arg [1] : See 'new' method + Function : Initialises storable-specific attributes + Returntype: boolean + Exceptions: + Caller : + Example : + +=cut + +sub _initialise_storable { + my $self = shift; + my( $workdir, $template, $suffix ) = + $self->_rearrange([qw(WORKDIR TEMPLATE SUFFIX)], @_ ); + $workdir && $self->workdir ( $workdir ); + $template && $self->template( $template ); + $suffix && $self->suffix ( $suffix ); + return 1; +} + + + +#---------------------------------------------------------------------- + +=head2 statefile + + Arg [1] : string (optional) + Function : Accessor for the file to write state into. + Should not normaly use as a setter - let Root::IO + do this for you. + Returntype: string + Exceptions: + Caller : Bio::Root::Storable->store + Example : my $statefile = $obj->statefile(); + +=cut + +sub statefile{ + my $key = '_statefile'; + my $self = shift; + + if( @_ ){ $self->{$key} = shift } + + if( ! $self->{$key} ){ # Create a new statefile + my $workdir = $self->workdir; + my $template = $self->template; + my $suffix = $self->suffix; + + # TODO: add cleanup and unlink methods. For now, we'll keep the + # statefile hanging around. + my @args = ( CLEANUP=>0, UNLINK=>0 ); + if( $template ){ push( @args, 'TEMPLATE' => $template )}; + if( $workdir ){ push( @args, 'DIR' => $workdir )}; + if( $suffix ){ push( @args, 'SUFFIX' => $suffix )}; + my( $fh, $file ) = Bio::Root::IO->new->tempfile( @args ); + # If filehandle is not stored, don't leave it open + $fh->close; + + $self->{$key} = $file; + } + + return $self->{$key}; +} + +#---------------------------------------------------------------------- + +=head2 workdir + + Arg [1] : string (optional) (TODO - convert to array for x-platform) + Function : Accessor for the statefile directory. Defaults to File::Spec->tmpdir + Returntype: string + Exceptions: + Caller : + Example : $obj->workdir('/tmp/foo'); + +=cut + +sub workdir { + my $key = '_workdir'; + my $self = shift; + if( @_ ){ + my $caller = join( ', ', (caller(0))[1..2] ); + $self->{$key} && $self->debug("Overwriting workdir: probably bad!"); + $self->{$key} = shift + } + #$self->{$key} ||= $Bio::Root::IO::TEMPDIR; + $self->{$key} ||= File::Spec->tmpdir(); + return $self->{$key}; +} + +#---------------------------------------------------------------------- + +=head2 template + + Arg [1] : string (optional) + Function : Accessor for the statefile template. Defaults to XXXXXXXX + Returntype: string + Exceptions: + Caller : + Example : $obj->workdir('RES_XXXXXXXX'); + +=cut + +sub template { + my $key = '_template'; + my $self = shift; + if( @_ ){ $self->{$key} = shift } + $self->{$key} ||= 'XXXXXXXX'; + return $self->{$key}; +} + +#---------------------------------------------------------------------- + +=head2 suffix + + Arg [1] : string (optional) + Function : Accessor for the statefile template. + Returntype: string + Exceptions: + Caller : + Example : $obj->suffix('.state'); + +=cut + +sub suffix { + my $key = '_suffix'; + my $self = shift; + if( @_ ){ $self->{$key} = shift } + return $self->{$key}; +} + +#---------------------------------------------------------------------- + +=head2 new_retrievable + + Arg [1] : Same as for 'new' + Function : Similar to store, except returns a 'skeleton' of the calling + object, rather than the statefile. + The skeleton can be repopulated by calling 'retrieve'. This + will be a clone of the original object. + Returntype: Bio::Root::Storable inhereting object + Exceptions: + Caller : + Example : my $skel = $obj->new_retrievable(); # skeleton + $skel->retrieve(); # clone + +=cut + +sub new_retrievable{ + my $self = shift; + my @args = @_; + + $self->_initialise_storable( @args ); + + if( $self->retrievable ){ return $self->clone } # Clone retrievable + return bless( { _statefile => $self->store(@args), + _workdir => $self->workdir, + _suffix => $self->suffix, + _template => $self->template, + _retrievable => 1 }, + ref( $self ) ); +} + +#---------------------------------------------------------------------- + +=head2 retrievable + + Arg [1] : none + Function : Reports whether the object is in 'skeleton' state, and the + 'retrieve' method can be called. + Returntype: boolean + Exceptions: + Caller : + Example : if( $obj->retrievable ){ $obj->retrieve } + +=cut + +sub retrievable { + my $self = shift; + if( @_ ){ $self->{_retrievable} = shift } + return $self->{_retrievable}; +} + +#---------------------------------------------------------------------- + +=head2 token + + Arg [1] : None + Function : Accessor for token attribute + Returntype: string. Whatever retrieve needs to retrieve. + This base implementation returns the statefile + Exceptions: + Caller : + Example : my $token = $obj->token(); + +=cut + +sub token{ + my $self = shift; + return $self->statefile; +} + + +#---------------------------------------------------------------------- + +=head2 store + + Arg [1] : none + Function : Saves a serialised representation of the object structure + to disk. Returns the name of the file that the object was + saved to. + Returntype: string + + Exceptions: + Caller : + Example : my $token = $obj->store(); + +=cut + +sub store{ + my $self = shift; + my $statefile = $self->statefile; + my $store_obj = $self->serialise; + my $io = Bio::Root::IO->new( ">$statefile" ); + $io->_print( $store_obj ); + $self->debug( "STORING $self to $statefile\n" ); + # If filehandle is not stored, don't leave it open + $io->close; + return $statefile; +} + +#---------------------------------------------------------------------- + +=head2 serialise + + Arg [1] : none + Function : Prepares the the serialised representation of the object. + Object attribute names starting with '__' are skipped. + This is useful for those that do not serialise too well + (e.g. filehandles). + Attributes are examined for other storable objects. If these + are found they are serialised separately using 'new_retrievable' + Returntype: string + Exceptions: + Caller : + Example : my $serialised = $obj->serialise(); + +=cut + +sub serialise{ + my $self = shift; + + # Create a new object of same class that is going to be serialised + my $store_obj = bless( {}, ref( $self ) ); + + my %retargs = ( -workdir =>$self->workdir, + -suffix =>$self->suffix, + -template=>$self->template ); + # Assume that other storable bio objects held by this object are + # only 1-deep. + + foreach my $key( keys( %$self ) ){ + if( $key =~ /^__/ ){ next } # Ignore keys starting with '__' + my $value = $self->{$key}; + + # Scalar value + if( ! ref( $value ) ){ + $store_obj->{$key} = $value; + } + + # Bio::Root::Storable obj: save placeholder + elsif( ref($value) =~ /^Bio::/ and $value->isa('Bio::Root::Storable') ){ + # Bio::Root::Storable + $store_obj->{$key} = $value->new_retrievable( %retargs ); + next; + } + + # Arrayref value. Look for Bio::Root::Storable objs + elsif( ref( $value ) eq 'ARRAY' ){ + my @ary; + foreach my $val( @$value ){ + if( ref($val) =~ /^Bio::/ and $val->isa('Bio::Root::Storable') ){ + push( @ary, $val->new_retrievable( %retargs ) ); + } + else{ push( @ary, $val ) } + } + $store_obj->{$key} = \@ary; + } + + # Hashref value. Look for Bio::Root::Storable objs + elsif( ref( $value ) eq 'HASH' ){ + my %hash; + foreach my $k2( keys %$value ){ + my $val = $value->{$k2}; + if( ref($val) =~ /^Bio::/ and $val->isa('Bio::Root::Storable') ){ + $hash{$k2} = $val->new_retrievable( %retargs ); + } + else{ $hash{$k2} = $val } + } + $store_obj->{$key} = \%hash; + } + + # Unknown, just add to the store object regardless + else{ $store_obj->{$key} = $value } + } + $store_obj->retrievable(0); # Once deserialised, obj not retrievable + return $self->_freeze( $store_obj ); +} + + +#---------------------------------------------------------------------- + +=head2 retrieve + + Arg [1] : string; filesystem location of the state file to be retrieved + Function : Retrieves a stored object from disk. + Note that the retrieved object will be blessed into its original + class, and not the + Returntype: Bio::Root::Storable inhereting object + Exceptions: + Caller : + Example : my $obj = Bio::Root::Storable->retrieve( $token ); + +=cut + +sub retrieve{ + my( $caller, $statefile ) = @_; + + my $self = {}; + my $class = ref( $caller ) || $caller; + + # Is this a call on a retrievable object? + if ( ref( $caller ) + and $caller->retrievable + ){ + $self = $caller; + $statefile = $self->statefile; + } + bless( $self, $class ); + + # Recover serialised object + if( ! -f $statefile ){ + $self->throw( "Token $statefile is not found" ); + } + my $io = Bio::Root::IO->new( $statefile ); + local $/ = undef; + my $state_str = $io->_readline('-raw'=>1); + # If filehandle is not stored, don't leave it open + $io->close; + + # Dynamic-load modules required by stored object + my $stored_obj; + my $success; + for( my $i=0; $i<10; $i++ ){ + eval{ $stored_obj = $self->_thaw( $state_str ) }; + if( ! $@ ){ + $success = 1; + last; + } + my $package; + if( $@ =~ /Cannot restore overloading(.*)/i ){ + my $postmatch = $1; #' + if( $postmatch =~ /\(package +([\w\:]+)\)/ ) { + $package = $1; + } + } + if( $package ){ + eval "require $package"; + $self->throw($@) if $@; + } + else{ $self->throw($@) } + } + if( ! $success ){ $self->throw("maximum number of requires exceeded" ) } + + if( ! ref( $stored_obj ) ){ + $self->throw( "Token $statefile returned no data" ); + } + map{ $self->{$_} = $stored_obj->{$_} } keys %$stored_obj; # Copy hasheys + $self->retrievable(0); + + # Maintain class of stored obj + return $self; +} + +#---------------------------------------------------------------------- + + +=head2 clone + + Arg [1] : none + Function : Returns a clone of the calling object + Returntype: Bio::Root::Storable inhereting object + Exceptions: + Caller : + Example : my $clone = $obj->clone(); + +=cut + +sub clone { + my $self = shift; + my $frozen = $self->_freeze( $self ); + return $self->_thaw( $frozen ); +} + + + +#---------------------------------------------------------------------- + +=head2 remove + + Arg [1] : none + Function : Clears the stored object from disk + Returntype: boolean + Exceptions: + Caller : + Example : $obj->remove(); + +=cut + +sub remove { + my $self = shift; + if( -e $self->statefile ){ + unlink( $self->statefile ); + } + return 1; +} + +#---------------------------------------------------------------------- + +=head2 _freeze + + Arg [1] : variable + Function : Converts whatever is in the the arg into a string. + Uses either Storable::freeze or Data::Dumper::Dump + depending on the value of $Bio::Root::BINARY + Returntype: + Exceptions: + Caller : + Example : + +=cut + +sub _freeze { + my $self = shift; + my $data = shift; + if( $BINARY ){ + return freeze( $data ); + } + else{ + $Data::Dumper::Purity = 1; + return Data::Dumper->Dump( [\$data],["*code"] ); + } +} + +#---------------------------------------------------------------------- + +=head2 _thaw + + Arg [1] : string + Function : Converts the string into a perl 'whatever'. + Uses either Storable::thaw or eval depending on the + value of $Bio::Root::BINARY. + Note; the string arg should have been created with + the _freeze method, or strange things may occur! + Returntype: variable + Exceptions: + Caller : + Example : + +=cut + +sub _thaw { + my $self = shift; + my $data = shift; + if( $BINARY ){ + return thaw( $data ) + } + else{ + my $code; + $code = eval( $data ) ; + if($@) { + $self->throw( "eval: $@" ); + } + ref( $code ) eq 'REF' + or $self->throw( "Serialised string was not a scalar ref" ); + return $$code; + } +} + +1; diff --git a/Bio/Root/Test.pm b/Bio/Root/Test.pm new file mode 100644 index 000000000..9c00068d9 --- /dev/null +++ b/Bio/Root/Test.pm @@ -0,0 +1,571 @@ +package Bio::Root::Test; +use strict; +use warnings; + +# According to Ovid, 'use base' can override signal handling, so use +# old-fashioned way. This should be a Test::Builder::Module subclass +# for consistency (as are any Test modules) +use Test::Most; +use Test::Builder; +use Test::Builder::Module; +use File::Temp qw(tempdir); +use File::Spec; + +our @ISA = qw(Test::Builder::Module); + +=head1 SYNOPSIS + + use lib '.'; # (for core package tests only) + use Bio::Root::Test; + + test_begin(-tests => 20, + -requires_modules => [qw(IO::String XML::Parser)], + -requires_networking => 1); + + my $do_network_tests = test_network(); + my $output_debugging = test_debug(); + + # Bio::Root::Test rewraps Test::Most, so one can carry out tests with + # Test::More, Test::Exception, Test::Warn, Test::Deep, Test::Diff syntax + + SKIP: { + # these tests need version 2.6 of Optional::Module to work + test_skip(-tests => 10, -requires_module => 'Optional::Module 2.6'); + use_ok('Optional::Module'); + + # 9 other optional tests that need Optional::Module + } + + SKIP: { + test_skip(-tests => 10, -requires_networking => 1); + + # 10 optional tests that require internet access (only makes sense in the + # context of a script that doesn't use -requires_networking in the call to + # &test_begin) + } + + # in unix terms, we want to test with a file t/data/input_file.txt + my $input_file = test_input_file('input_file.txt'); + + # we want the name of a file we can write to, that will be automatically + # deleted when the test script finishes + my $output_file = test_output_file(); + + # we want the name of a directory we can store files in, that will be + # automatically deleted when the test script finishes + my $output_dir = test_output_dir(); + +=head1 DESCRIPTION + +This provides a common base for all BioPerl test scripts. It safely handles the +loading of Test::Most, itself a simple wrapper around several highly used test +modules: Test::More, Test::Exception, Test::Warn, Test::Deep, and Test::Diff. It +also presents an interface to common needs such as skipping all tests if +required modules aren't present or if network tests haven't been enabled. See +test_begin(). + +In the same way, it allows you to skip just a subset of tests for those same +reasons, in addition to requiring certain executables and environment variables. +See test_skip(). + +It also has two further methods that let you decide if network tests should be +run, and if debugging information should be printed. See test_network() and +test_debug(). + +Finally, it presents a consistent way of getting the path to input and output +files. See test_input_file(), test_output_file() and test_output_dir(). + +=head1 AUTHOR Sendu Bala + +Chris Fields + +=cut + +# TODO: Evil magic ahead; can we clean this up? + +{ + my $Tester = Test::Builder->new; + + no warnings 'redefine'; + + sub Test::Warn::_canonical_got_warning { + my ( $called_from, $msg ) = @_; + my $warn_kind + = $called_from eq 'Carp' + ? 'carped' + : ( $called_from =~ /Bio::/ ? 'Bioperl' : 'warn' ); + + my $warning; + if ( $warn_kind eq 'Bioperl' ) { + ($warning) + = $msg + =~ /\n--------------------- WARNING ---------------------\nMSG: (.+)\n---------------------------------------------------\n$/m; + $warning ||= $msg; # shouldn't ever happen + } else { + my @warning_stack = split /\n/, $msg; # some stuff of uplevel is included + $warning = $warning_stack[0]; + } + + return { $warn_kind => $warning }; # return only the real message + } + + sub Test::Warn::_diag_found_warning { + my @warns = @_; + foreach my $warn (@warns) { + if ( ref($warn) eq 'HASH' ) { + ${$warn}{carped} + ? $Tester->diag("found carped warning: ${$warn}{carped}") + : ( + ${$warn}{Bioperl} ? $Tester->diag( + "found Bioperl warning: ${$warn}{Bioperl}") + : $Tester->diag("found warning: ${$warn}{warn}") + ); + } else { + $Tester->diag("found warning: $warn"); + } + } + $Tester->diag("didn't find a warning") unless @warns; + } + + sub Test::Warn::_cmp_got_to_exp_warning { + my ( $got_kind, $got_msg ) = %{ shift() }; + my ( $exp_kind, $exp_msg ) = %{ shift() }; + return 0 if ( $got_kind eq 'warn' ) && ( $exp_kind eq 'carped' ); + + my $cmp; + if ( $got_kind eq 'Bioperl' ) { + $cmp = $got_msg =~ /^\Q$exp_msg\E$/; + } else { + $cmp = $got_msg =~ /^\Q$exp_msg\E at \S+ line \d+\.?$/; + } + + return $cmp; + } +} + +our @EXPORT = ( + @Test::Most::EXPORT, + + #@Bio::Root::Test::Warn::EXPORT, + # Test::Warn method wrappers + + # BioPerl-specific + qw( + test_begin + test_skip + test_output_file + test_output_dir + test_input_file + test_network + test_email + test_debug + float_is + ) +); + +our $GLOBAL_FRAMEWORK = 'Test::Most'; +our @TEMP_FILES; + +=head2 test_begin + + Title : test_begin + Usage : test_begin(-tests => 20); + Function: Begin your test script, setting up the plan (skip all tests, or run + them all) + Returns : True if tests should be run. + Args : -tests => int (REQUIRED, the number of tests that will + be run) + -requires_modules => [] (array ref of module names that are + required; if any don't load, all tests + will be skipped. To specify a required + version of a module, include the version + number after the module name, separated + by a space) + -requires_module => str (as above, but for just one module) + -requires_networking => 1|0 (default 0, if true all tests will be + skipped if network tests haven't been + enabled in Build.PL) + -requires_email => 1 (if true the desired number of tests will + be skipped if either network tests + haven't been enabled in Build.PL or an + email hasn't been entered) + -excludes_os => str (default none, if OS suppied, all tests + will skip if running on that OS (eg. + 'mswin')) + -framework => str (default 'Test::Most', the Test module + to load. NB: experimental, avoid using) + + Note, supplying -tests => 0 is possible, allowing you to skip all + tests in the case that a test script is testing deprecated modules + that have yet to be removed from the distribution + +=cut + +sub test_begin { + my ( $skip_all, $tests, $framework ) = _skip(@_); + $GLOBAL_FRAMEWORK = $framework; + + if ( $framework eq 'Test::Most' ) { + + # ideally we'd delay loading Test::Most until this point, but see BEGIN + # block + + if ($skip_all) { + eval "plan skip_all => '$skip_all';"; + } elsif ( defined $tests && $tests == 0 ) { + eval + "plan skip_all => 'These modules are now probably deprecated';"; + } elsif ($tests) { + eval "plan tests => $tests;"; + } + + return 1; + } + + # go ahead and add support for other frameworks here + else { + die "Only Test::Most is supported at the current time\n"; + } + + return 0; +} + +=head2 test_skip + + Title : test_skip + Usage : SKIP: { + test_skip(-tests => 10, + -requires_module => 'Optional::Module 2.01'); + # 10 tests that need v2.01 of Optional::Module + } + Function: Skip a subset of tests for one of several common reasons: missing one + or more optional modules, network tests haven't been enabled, a + required binary isn't present, or an environmental variable isn't set + Returns : n/a + Args : -tests => int (REQUIRED, the number of tests that are + to be skipped in the event one of the + following options isn't satisfied) + -requires_modules => [] (array ref of module names that are + required; if any don't load, the desired + number of tests will be skipped. To + specify a required version of a module, + include the version number after the + module name, separated by a space) + -requires_module => str (as above, but for just one module) + -requires_executable => Bio::Tools::Run::WrapperBase instance + (checks WrapperBase::executable for the + presence of a binary, skips if absent) + -requires_env => str (checks %ENV for a specific env. variable, + skips if absent) + -excludes_os => str (default none, if OS suppied, desired num + of tests will skip if running on that OS + (eg. 'mswin')) + -requires_networking => 1 (if true the desired number of tests will + be skipped if network tests haven't been + enabled in Build.PL) + -requires_email => 1 (if true the desired number of tests will + be skipped if either network tests + haven't been enabled in Build.PL or an + email hasn't been entered) + +=cut + +sub test_skip { + my ( $skip, $tests, $framework ) = _skip(@_); + $tests || die "-tests must be a number greater than 0"; + + if ( $framework eq 'Test::Most' ) { + if ($skip) { + eval "skip('$skip', $tests);"; + } + } + + # go ahead and add support for other frameworks here + else { + die "Only Test::Most is supported at the current time\n"; + } +} + +=head2 test_output_file + + Title : test_output_file + Usage : my $output_file = test_output_file(); + Function: Get the full path of a file suitable for writing to. + When your test script ends, the file will be automatically deleted. + Returns : string (file path) + Args : none + +=cut + +sub test_output_file { + die "test_output_file takes no args\n" if @_; + + # RT 48813 + my $tmp = File::Temp->new(); + push( @TEMP_FILES, $tmp ); + close($tmp); # Windows needs this + return $tmp->filename; +} + +=head2 test_output_dir + + Title : test_output_dir + Usage : my $output_dir = test_output_dir(); + Function: Get the full path of a directory suitable for storing temporary files + in. + When your test script ends, the directory and its contents will be + automatically deleted. + Returns : string (path) + Args : none + +=cut + +sub test_output_dir { + die "test_output_dir takes no args\n" if @_; + + return tempdir( CLEANUP => 1 ); +} + +=head2 test_input_file + + Title : test_input_file + Usage : my $input_file = test_input_file(); + Function: Get the path of a desired input file stored in the standard location + (currently t/data), but correct for all platforms. + Returns : string (file path) + Args : list of strings (ie. at least the input filename, preceded by the + names of any subdirectories within t/data) + eg. for the file t/data/in.file pass 'in.file', for the file + t/data/subdir/in.file, pass ('subdir', 'in.file') + +=cut + +sub test_input_file { + return File::Spec->catfile( 't', 'data', @_ ); +} + +=head2 test_network + + Title : test_network + Usage : my $do_network_tests = test_network(); + Function: Ask if network tests should be run. + Returns : boolean + Args : none + +=cut + +sub test_network { + require Module::Build; + my $build = Module::Build->current(); + return + $build->notes('network') + || $ENV{AUTHOR_TESTING} + || $ENV{RELEASE_TESTING}; +} + +=head2 test_email + + Title : test_email + Usage : my $do_network_tests = test_email(); + Function: Ask if email address provided + Returns : boolean + Args : none + +=cut + +sub test_email { + require Module::Build; + my $build = Module::Build->current(); + + # this should not be settable unless the network tests work + return + $build->notes('email') + || $ENV{AUTHOR_TESTING} + || $ENV{RELEASE_TESTING}; +} + +=head2 test_debug + + Title : test_debug + Usage : my $output_debugging = test_debug(); + Function: Ask if debugging information should be output. + Returns : boolean + Args : none + +=cut + +sub test_debug { + return $ENV{'BIOPERLDEBUG'} || 0; +} + +=head2 float_is + + Title : float_is + Usage : float_is($val1, $val2); + Function: test two floating point values for equality + Returns : Boolean based on test (can use in combination with diag) + Args : two scalar values (floating point numbers) (required via prototype) + test message (optional) + +=cut + +sub float_is ($$;$) { + my ( $val1, $val2, $message ) = @_; + + # catch any potential undefined values and directly compare + if ( ! defined $val1 || ! defined $val2 ) { + is( $val1, $val2, $message ); + } else { + is( sprintf( "%g", $val1 ), sprintf( "%g", $val2 ), $message ); + } +} + +=head2 _skip + +Decide if should skip and generate skip message +=cut + +sub _skip { + my %args = @_; + + # handle input strictly + my $tests = $args{'-tests'}; + +#(defined $tests && $tests =~ /^\d+$/) || die "-tests must be supplied and be an int\n"; + delete $args{'-tests'}; + + my $req_mods = $args{'-requires_modules'}; + delete $args{'-requires_modules'}; + my @req_mods; + if ($req_mods) { + ref($req_mods) eq 'ARRAY' + || die "-requires_modules takes an array ref\n"; + @req_mods = @{$req_mods}; + } + my $req_mod = $args{'-requires_module'}; + delete $args{'-requires_module'}; + if ($req_mod) { + ref($req_mod) && die "-requires_module takes a string\n"; + push( @req_mods, $req_mod ); + } + + my $req_net = $args{'-requires_networking'}; + delete $args{'-requires_networking'}; + + my $req_email = $args{'-requires_email'}; + delete $args{'-requires_email'}; + + my $req_env = $args{'-requires_env'}; + delete $args{'-requires_env'}; + + # strip any leading $ in case someone passes $FOO instead of 'FOO' + $req_env =~ s{^\$}{} if $req_env; + + my $req_exe = $args{'-requires_executable'}; + delete $args{'-requires_executable'}; + + if ($req_exe + && ( ! ref($req_exe) + || ! $req_exe->isa('Bio::Tools::Run::WrapperBase') ) + ) { + die + "-requires_exe takes an argument of type Bio::Tools::Run::WrapperBase"; + } + + my $os = $args{'-excludes_os'}; + delete $args{'-excludes_os'}; + + my $framework = $args{'-framework'} || $GLOBAL_FRAMEWORK; + delete $args{'-framework'}; + + # catch user mistakes + while ( my ( $key, $val ) = each %args ) { + die + "unknown argument '$key' supplied, did you mistake 'required...' for 'requires...'?\n"; + } + + # test user requirments and return + if ($os) { + if ( $^O =~ /$os/i ) { + return ( 'Not compatible with your Operating System', + $tests, $framework ); + } + } + + foreach my $mod (@req_mods) { + my $skip = _check_module($mod); + if ($skip) { + return ( $skip, $tests, $framework ); + } + } + + if ( $req_net && ! test_network() ) { + return ( 'Network tests have not been requested', $tests, + $framework ); + } + + if ( $req_email && ! test_email() ) { + return ( 'Valid email not provided; required for tests', + $tests, $framework ); + } + + if ($req_exe) { + my $eval = eval { $req_exe->executable }; + if ( $@ or not defined $eval ) { + my $msg + = 'Required executable for ' + . ref($req_exe) + . ' is not present'; + diag($msg); + return ( $msg, $tests, $framework ); + } + } + + if ( $req_env && ! exists $ENV{$req_env} ) { + my $msg + = 'Required environment variable $' . $req_env . ' is not set'; + diag($msg); + return ( $msg, $tests, $framework ); + } + + return ( '', $tests, $framework ); +} + +=head2 _check_module + +=cut + +sub _check_module { + my $mod = shift; + + my $desired_version; + if ( $mod =~ /(\S+)\s+(\S+)/ ) { + $mod = $1; + $desired_version = $2; + } + + eval "require $mod;"; + + if ($@) { + if ( $@ =~ /Can't locate/ ) { + return + "The optional module $mod (or dependencies thereof) was not installed"; + } else { + return + "The optional module $mod generated the following error: \n$@"; + } + } elsif ($desired_version) { + no strict 'refs'; + unless ( defined ${"${mod}::VERSION"} ) { + return + "The optional module $mod didn't have a version, but we want v$desired_version"; + } elsif ( ${"${mod}::VERSION"} < $desired_version ) { + return + "The optional module $mod was out of date (wanted v$desired_version)"; + } + } + + return; +} + +1; diff --git a/Bio/Root/TestObject.pm b/Bio/Root/TestObject.pm new file mode 100644 index 000000000..35b92c9ea --- /dev/null +++ b/Bio/Root/TestObject.pm @@ -0,0 +1,63 @@ +=head1 NAME + +TestObject - An implementation of TestInterface + +=head1 DESCRIPTION + +This module attempts to provide an implementation of TestInterface and +is used for illustrating exception throwing using Graham Barr's +Error.pm object. + +=head1 AUTHOR + +Steve Chervitz Esac@bioperl.orgE + +=cut + +package Bio::Root::TestObject; + +use strict; + +# Define a special type of error "Bio::TestException" as a subclass of Error. +# Note two things: +# 1. The ISA declaration effectively defines our new Exception object. +# 2. This declaration doesn't have to be located in the Bio directory. +# 3. We don't have to use Bio::Root::Exception in this module. +# 4. If Error.pm isn't available this statement doesn't matter. +@Bio::TestException::ISA = qw( Bio::Root::Exception ); + +use base qw( Bio::Root::Root ); + +# Note that we're not implementing foo(), so calling it +# will result in a Bio::Root::NotImplemented exception. + +sub data { + my ($self, $data) = @_; + print "Setting test data ($data)\n" if $data && $self->verbose; + $self->{'data'} = $data if $data; + + return $self->{'data'} +} + +sub bar { + + my $self = shift; + + print "\nExecuting method bar() in TestObject\n" if $self->verbose; + print "Throwing a Bio::TestException\n" if $self->verbose; + + my $message = "A Test error"; + + # Bio::Root::Root::throw() will make use of Error.pm if present. + # The type of Error is specified with a -class parameter. + # If -class is not supplied, a Bio::Root::Exception is throw. + # In this case, the argument can consist of a simple string. + + $self->throw( -class => 'Bio::TestException', + -text => $message ); + + print "Code within bar() below the throw that shouldn't be executed.\n" if $self->verbose; + +} + +1; diff --git a/Bio/Root/Utilities.pm b/Bio/Root/Utilities.pm new file mode 100644 index 000000000..cf7eb6cce --- /dev/null +++ b/Bio/Root/Utilities.pm @@ -0,0 +1,1338 @@ +package Bio::Root::Utilities; +use strict; +use Bio::Root::IO; +use Bio::Root::Exception; +use base qw(Bio::Root::Root Exporter); + +=head1 SYNOPSIS + +=head2 Object Creation + + # Using the supplied singleton object: + use Bio::Root::Utilities qw(:obj); + $Util->some_method(); + + # Create an object manually: + use Bio::Root::Utilities; + my $util = Bio::Root::Utilities->new(); + $util->some_method(); + + $date_stamp = $Util->date_format('yyy-mm-dd'); + + $clean = $Util->untaint($dirty); + + $compressed = $Util->compress('/home/me/myfile.txt') + + my ($mean, $stdev) = $Util->mean_stdev( @data ); + + $Util->authority("me@example.com"); + $Util->mail_authority("Something you should know about..."); + + ...and a host of other methods. See below. + +=head1 DESCRIPTION + +Provides general-purpose utilities of potential interest to any Perl script. + +The C<:obj> tag is a convenience that imports a $Util symbol into your +namespace representing a Bio::Root::Utilities object. This saves you +from creating your own Bio::Root::Utilities object via +Cnew()> or from prefixing all method calls with +C, though feel free to do these things if desired. +Since there should normally not be a need for a script to have more +than one Bio::Root::Utilities object, this module thus comes with it's +own singleton. + +=head1 INSTALLATION + +This module is included with the central Bioperl distribution: + + http://www.bioperl.org/wiki/Getting_BioPerl + ftp://bio.perl.org/pub/DIST + +Follow the installation instructions included in the README file. + +=head1 DEPENDENCIES + +Inherits from L, and uses L +and L. + +Relies on external executables for file compression/uncompression +and sending mail. No paths to these are hard coded but are located +as needed. + +=head1 SEE ALSO + + http://bioperl.org - Bioperl Project Homepage + +=head1 ACKNOWLEDGEMENTS + +This module was originally developed under the auspices of the +Saccharomyces Genome Database: http://www.yeastgenome.org/ + +=head1 AUTHOR Steve Chervitz + +=cut + +use vars qw(@EXPORT_OK %EXPORT_TAGS); +@EXPORT_OK = qw($Util); +%EXPORT_TAGS = ( obj => [qw($Util)], + std => [qw($Util)],); + +use vars qw($ID $Util $GNU_PATH $TIMEOUT_SECS + @COMPRESSION_UTILS @UNCOMPRESSION_UTILS + $DEFAULT_NEWLINE $NEWLINE $AUTHORITY + @MONTHS @DAYS $BASE_YEAR $DEFAULT_CENTURY + ); + +$ID = 'Bio::Root::Utilities'; +# Number of seconds to wait before timing out when reading input (taste_file()) +$TIMEOUT_SECS = 30; +$NEWLINE = $ENV{'NEWLINE'} || undef; +$BASE_YEAR = 1900; # perl's localtime() assumes this for it's year data. +# TODO: update this every hundred years. Y2K-sensitive code. +$DEFAULT_CENTURY = $BASE_YEAR + 100; +@MONTHS = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); +@DAYS = qw(Sun Mon Tue Wed Thu Fri Sat); +# Sets the preference for compression utilities to be used by compress(). +# The first executable in this list to be found in the current PATH will be used, +# unless overridden in the call to that function. See docs for details. +@COMPRESSION_UTILS = qw(gzip bzip2 zip compress); +@UNCOMPRESSION_UTILS = qw(gunzip gzip bunzip2 unzip uncompress); + +# Default person to receive feedback from users and possibly automatic error messages. +$AUTHORITY = ''; + +# Note: $GNU_PATH is now deprecated, shouldn't be needed since now this module +# will automatically locate the compression utility in the current PATH. +# Retaining $GNU_PATH for backward compatibility. +# +# $GNU_PATH points to the directory containing the gzip and gunzip +# executables. It may be required for executing gzip/gunzip +# in some situations (e.g., when $ENV{PATH} doesn't contain this dir. +# Customize $GNU_PATH for your site if the compress() or +# uncompress() functions are generating exceptions. +$GNU_PATH = ''; +#$GNU_PATH = '/tools/gnu/bin/'; + +$DEFAULT_NEWLINE = "\012"; # \n (used if get_newline() fails for some reason) + +## Static UTIL object. +$Util = Bio::Root::Root->new(); + + +=head2 date_format + + Title : date_format + Usage : $Util->date_format( [FMT], [DATE]) + Purpose : -- Get a string containing the formated date or time + : taken when this routine is invoked. + : -- Provides a way to avoid using `date`. + : -- Provides an interface to localtime(). + : -- Interconverts some date formats. + : + : (For additional functionality, use Date::Manip or + : Date::DateCalc available from CPAN). + Example : $Util->date_format(); + : $date = $Util->date_format('yyyy-mmm-dd', '11/22/92'); + Returns : String (unless 'list' is provided as argument, see below) + : + : 'yyyy-mm-dd' = 1996-05-03 # default format. + : 'yyyy-dd-mm' = 1996-03-05 + : 'yyyy-mmm-dd' = 1996-May-03 + : 'd-m-y' = 3-May-1996 + : 'd m y' = 3 May 1996 + : 'dmy' = 3may96 + : 'mdy' = May 3, 1996 + : 'ymd' = 96may3 + : 'md' = may3 + : 'year' = 1996 + : 'hms' = 23:01:59 # when not converting a format, 'hms' can be + : # tacked on to any of the above options + : # to add the time stamp: eg 'dmyhms' + : 'full' | 'unix' = UNIX-style date: Tue May 5 22:00:00 1998 + : 'list' = the contents of localtime(time) in an array. + Argument : (all are optional) + : FMT = yyyy-mm-dd | yyyy-dd-mm | yyyy-mmm-dd | + : mdy | ymd | md | d-m-y | hms | hm + : ('hms' may be appended to any of these to + : add a time stamp) + : + : DATE = String containing date to be converted. + : Acceptable input formats: + : 12/1/97 (for 1 December 1997) + : 1997-12-01 + : 1997-Dec-01 + Throws : + Comments : If you don't care about formatting or using backticks, you can + : always use: $date = `date`; + : + : For more features, use Date::Manip.pm, (which I should + : probably switch to...) + +See Also : L, L + +=cut + +#---------------' +sub date_format { +#--------------- + my $self = shift; + my $option = shift; + my $date = shift; # optional date to be converted. + + my($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst); + + $option ||= 'yyyy-mm-dd'; + + my ($month_txt, $day_txt, $month_num, $fullYear); + my ($converting, @date); + + # Load a supplied date for conversion: + if(defined($date) && ($date =~ /[\D-]+/)) { + $converting = 1; + if( $date =~ m{/}) { + ($mon,$mday,$year) = split(m{/}, $date); + } elsif($date =~ /(\d{4})-(\d{1,2})-(\d{1,2})/) { + ($year,$mon,$mday) = ($1, $2, $3); + } elsif($date =~ /(\d{4})-(\w{3,})-(\d{1,2})/) { + ($year,$mon,$mday) = ($1, $2, $3); + $mon = $self->month2num($2); + } else { + print STDERR "\n*** Unsupported input date format: $date\n"; + } + if(length($year) == 4) { + $fullYear = $year; + $year = substr $year, 2; + } else { + # Heuristics to guess what century was intended when a 2-digit year is given + # If number is over 50, assume it's for prev century; under 50 = default century. + # TODO: keep an eye on this Y2K-sensitive code + if ($year > 50) { + $fullYear = $DEFAULT_CENTURY + $year - 100; + } else { + $fullYear = $DEFAULT_CENTURY + $year; + } + } + $mon -= 1; + } else { + ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = @date = + localtime(($date ? $date : time())); + return @date if $option =~ /list/i; + $fullYear = $BASE_YEAR+$year; + } + $month_txt = $MONTHS[$mon]; + $day_txt = $DAYS[$wday] if defined $wday; + $month_num = $mon+1; + +# print "sec: $sec, min: $min, hour: $hour, month: $mon, m-day: $mday, year: $year\nwday: $wday, yday: $yday, dst: $isdst";; + + if( $option =~ /yyyy-mm-dd/i ) { + $date = sprintf "%4d-%02d-%02d",$fullYear,$month_num,$mday; + } elsif( $option =~ /yyyy-dd-mm/i ) { + $date = sprintf "%4d-%02d-%02d",$fullYear,$mday,$month_num; + } elsif( $option =~ /yyyy-mmm-dd/i ) { + $date = sprintf "%4d-%3s-%02d",$fullYear,$month_txt,$mday; + } elsif( $option =~ /full|unix/i ) { + $date = sprintf "%3s %3s %2d %02d:%02d:%02d %d",$day_txt, $month_txt, $mday, $hour, $min, $sec, $fullYear; + } elsif( $option =~ /mdy/i ) { + $date = "$month_txt $mday, $fullYear"; + } elsif( $option =~ /ymd/i ) { + $date = $year."\l$month_txt$mday"; + } elsif( $option =~ /dmy/i ) { + $date = $mday."\l$month_txt$year"; + } elsif( $option =~ /md/i ) { + $date = "\l$month_txt$mday"; + } elsif( $option =~ /d-m-y/i ) { + $date = "$mday-$month_txt-$fullYear"; + } elsif( $option =~ /d m y/i ) { + $date = "$mday $month_txt $fullYear"; + } elsif( $option =~ /year/i ) { + $date = $fullYear; + } elsif( $option =~ /dmy/i ) { + $date = $mday.'-'.$month_txt.'-'.$fullYear; + } elsif($option and $option !~ /hms/i) { + print STDERR "\n*** Unrecognized date format request: $option\n"; + } + + if( $option =~ /hms/i and not $converting) { + $date .= " $hour:$min:$sec" if $date; + $date ||= "$hour:$min:$sec"; + } + + return $date || join(" ", @date); +} + + +=head2 month2num + + Title : month2num + Purpose : Converts a string containing a name of a month to integer + : representing the number of the month in the year. + Example : $Util->month2num("march"); # returns 3 + Argument : The string argument must contain at least the first + : three characters of the month's name. Case insensitive. + Throws : Exception if the conversion fails. + +=cut + +#--------------' +sub month2num { +#-------------- + my ($self, $str) = @_; + + # Get string in proper format for conversion. + $str = substr($str, 0, 3); + for my $month (0..$#MONTHS) { + return $month+1 if $str =~ /$MONTHS[$month]/i; + } + $self->throw("Invalid month name: $str"); +} + +=head2 num2month + + Title : num2month + Purpose : Does the opposite of month2num. + : Converts a number into a string containing a name of a month. + Example : $Util->num2month(3); # returns 'Mar' + Throws : Exception if supplied number is out of range. + +=cut + +#------------- +sub num2month { +#------------- + my ($self, $num) = @_; + + $self->throw("Month out of range: $num") if $num < 1 or $num > 12; + return $MONTHS[$num-1]; +} + +=head2 compress + + Title : compress + Usage : $Util->compress(full-path-filename); + : $Util->compress(); + Purpose : Compress a file. + Example : $Util->compress("/usr/people/me/data.txt"); + : $Util->compress(-file=>"/usr/people/me/data.txt", + : -tmp=>1, + : -outfile=>"/usr/people/share/data.txt.gz", + : -exe=>"/usr/local/bin/fancyzip"); + Returns : String containing full, absolute path to compressed file + Argument : Named parameters (case-insensitive): + : -FILE => String (name of file to be compressed, full path). + : If the supplied filename ends with '.gz' or '.Z', + : that extension will be removed before attempting to compress. + : Optional: + : -TMP => boolean. If true, (or if user is not the owner of the file) + : the file is compressed to a temp file. If false, file may be + : clobbered with the compressed version (if using a utility like + : gzip, which is the default) + : -OUTFILE => String (name of the output compressed file, full path). + : -EXE => Name of executable for compression utility to use. + : Will supercede those in @COMPRESSION_UTILS defined by + : this module. If the absolute path to the executable is not provided, + : it will be searched in the PATH env variable. + Throws : Exception if file cannot be compressed. + : If user is not owner of the file, generates a warning and compresses to + : a tmp file. To avoid this warning, use the -o file test operator + : and call this function with -TMP=>1. + Comments : Attempts to compress using utilities defined in the @COMPRESSION_UTILS + : defined by this module, in the order defined. The first utility that is + : found to be executable will be used. Any utility defined in optional -EXE param + : will be tested for executability first. + : To minimize security risks, the -EXE parameter value is untained using + : the untaint() method of this module (in 'relaxed' mode to permit path separators). + +See Also : L + +=cut + +#------------' +sub compress { +#------------ + my ($self, @args) = @_; + # This method formerly didn't use named params and expected fileName, tmp + # in that order. This should be backward compatibile. + my ($fileName, $tmp, $outfile, $exe) = $self->_rearrange([qw(FILE TMP OUTFILE EXE)], @args); + my ($file, $get, $fmt); + + # in case the supplied name already has a compressed extension + if($fileName =~ /(\.gz|\.Z|\.bz2|\.zip)$/) { $fileName =~ s/$1$//; }; + $self->debug("compressing file $fileName"); + + my @util_to_use = @COMPRESSION_UTILS; + + if (defined $exe){ + $exe = $self->untaint($exe, 1); + unshift @util_to_use, $exe; + } + + my @checked = @util_to_use; + $exe ||= ''; + while (not -x $exe and scalar(@util_to_use)) { + $exe = $self->find_exe(shift @util_to_use); + } + + unless (-x $exe) { + $self->throw("Can't find compression utility. Looked for @checked"); + } + + my ($compressed, @cmd, $handle); + + if(defined($outfile) or $tmp or not -o $fileName) { + if (defined $outfile) { + $compressed = $outfile; + } else { + # obtain a temporary file name (not using the handle) + # and insert some special text to flag it as a bioperl-based temp file + my $io = Bio::Root::IO->new(); + ($handle, $compressed) = $io->tempfile(); + $compressed .= '.tmp.bioperl.gz'; + } + + # Use double quotes if executable path have empty spaces + if ($exe =~ m/ /) { + $exe = "\"$exe\""; + } + + if ($exe =~ /gzip|bzip2|compress/) { + @cmd = ("$exe -f < \"$fileName\" > \"$compressed\""); + } elsif ($exe eq 'zip') { + @cmd = ("$exe -r \"$fileName.zip\" \"$fileName\""); + } + not $tmp and + $self->warn("Not owner of file $fileName. Compressing to temp file $compressed."); + $tmp = 1; + } else { + # Need to compute the compressed name based on exe since we're returning it. + $compressed = $fileName; + if ($exe =~ /gzip/) { + $compressed .= '.gz'; + } elsif ($exe =~ /bzip2/) { + $compressed .= '.bz2'; + } elsif ($exe =~ /zip/) { + $compressed .= '.zip'; + } elsif ($exe =~ /compress/) { + $compressed .= '.Z'; + } + if ($exe =~ /gzip|bzip2|compress/) { + @cmd = ($exe, '-f', $fileName); + } elsif ($exe eq 'zip') { + @cmd = ($exe, '-r', "$compressed", $fileName); + } + } + + if(system(@cmd) != 0) { + $self->throw( -class => 'Bio::Root::SystemException', + -text => "Failed to compress file $fileName using $exe: $!"); + } + + return $compressed; +} + +=head2 uncompress + + Title : uncompress + Usage : $Util->uncompress(full-path-filename); + : $Util->uncompress(); + Purpose : Uncompress a file. + Example : $Util->uncompress("/usr/people/me/data.txt"); + : $Util->uncompress(-file=>"/usr/people/me/data.txt.gz", + : -tmp=>1, + : -outfile=>"/usr/people/share/data.txt", + : -exe=>"/usr/local/bin/fancyzip"); + Returns : String containing full, absolute path to uncompressed file + Argument : Named parameters (case-insensitive): + : -FILE => String (name of file to be uncompressed, full path). + : If the supplied filename ends with '.gz' or '.Z', + : that extension will be removed before attempting to uncompress. + : Optional: + : -TMP => boolean. If true, (or if user is not the owner of the file) + : the file is uncompressed to a temp file. If false, file may be + : clobbered with the uncompressed version (if using a utility like + : gzip, which is the default) + : -OUTFILE => String (name of the output uncompressed file, full path). + : -EXE => Name of executable for uncompression utility to use. + : Will supercede those in @UNCOMPRESSION_UTILS defined by + : this module. If the absolute path to the executable is not provided, + : it will be searched in the PATH env variable. + Throws : Exception if file cannot be uncompressed. + : If user is not owner of the file, generates a warning and uncompresses to + : a tmp file. To avoid this warning, use the -o file test operator + : and call this function with -TMP=>1. + Comments : Attempts to uncompress using utilities defined in the @UNCOMPRESSION_UTILS + : defined by this module, in the order defined. The first utility that is + : found to be executable will be used. Any utility defined in optional -EXE param + : will be tested for executability first. + : To minimize security risks, the -EXE parameter value is untained using + : the untaint() method of this module (in 'relaxed' mode to permit path separators). + +See Also : L + +=cut + +#------------' +sub uncompress { +#------------ + my ($self, @args) = @_; + # This method formerly didn't use named params and expected fileName, tmp + # in that order. This should be backward compatibile. + my ($fileName, $tmp, $outfile, $exe) = $self->_rearrange([qw(FILE TMP OUTFILE EXE)], @args); + my ($file, $get, $fmt); + + # in case the supplied name lacks a compressed extension + if(not $fileName =~ /(\.gz|\.Z|\.bz2|\.zip)$/) { $fileName .= $1; }; + $self->debug("uncompressing file $fileName"); + + my @util_to_use = @UNCOMPRESSION_UTILS; + + if (defined $exe){ + $exe = $self->untaint($exe, 1); + unshift @util_to_use, $exe; + } + + $exe ||= ''; + while (not -x $exe and scalar(@util_to_use)) { + $exe = $self->find_exe(shift @util_to_use); + } + + unless (-x $exe) { + $self->throw("Can't find compression utility. Looked for @util_to_use"); + } + + my ($uncompressed, @cmd, $handle); + + $uncompressed = $fileName; + $uncompressed =~ s/\.\w+$//; + + if(defined($outfile) or $tmp or not -o $fileName) { + if (defined $outfile) { + $uncompressed = $outfile; + } else { + # obtain a temporary file name (not using the handle) + my $io = Bio::Root::IO->new(); + ($handle, $uncompressed) = $io->tempfile(); + # insert some special text to flag it as a bioperl-based temp file + $uncompressed .= '.tmp.bioperl'; + } + + # Use double quotes if executable path have empty spaces + if ($exe =~ m/ /) { + $exe = "\"$exe\""; + } + + if ($exe =~ /gunzip|bunzip2|uncompress/) { + @cmd = ("$exe -f < \"$fileName\" > \"$uncompressed\""); + } elsif ($exe =~ /gzip/) { + @cmd = ("$exe -df < \"$fileName\" > \"$uncompressed\""); + } elsif ($exe eq 'unzip') { + @cmd = ("$exe -p \"$fileName\" > \"$uncompressed\""); + } + not $tmp and + $self->warn("Not owner of file $fileName. Uncompressing to temp file $uncompressed."); + $tmp = 1; + } else { + if ($exe =~ /gunzip|bunzip2|uncompress/) { + @cmd = ($exe, '-f', $fileName); + } elsif ($exe =~ /gzip/) { + @cmd = ($exe, '-df', $fileName); + } elsif ($exe eq 'zip') { + @cmd = ($exe, $fileName); + } + } + + if(system(@cmd) != 0) { + $self->throw( -class => 'Bio::Root::SystemException', + -text => "Failed to uncompress file $fileName using $exe: $!"); + } + + return $uncompressed; +} + + +=head2 file_date + + Title : file_date + Usage : $Util->file_date( filename [,date_format]) + Purpose : Obtains the date of a given file. + : Provides flexible formatting via date_format(). + Returns : String = date of the file as: yyyy-mm-dd (e.g., 1997-10-15) + Argument : filename = string, full path name for file + : date_format = string, desired format for date (see date_format()). + : Default = yyyy-mm-dd + Thows : Exception if no file is provided or does not exist. + Comments : Uses the mtime field as obtained by stat(). + +=cut + +#-------------- +sub file_date { +#-------------- + my ($self, $file, $fmt) = @_; + + $self->throw("No such file: $file") if not $file or not -e $file; + + $fmt ||= 'yyyy-mm-dd'; + + my @file_data = stat($file); + return $self->date_format($fmt, $file_data[9]); # mtime field +} + + +=head2 untaint + + Title : untaint + Purpose : To remove nasty shell characters from untrusted data + : and allow a script to run with the -T switch. + : Potentially dangerous shell meta characters: &;`'\"|*?!~<>^()[]{}$\n\r + : Accept only the first block of contiguous characters: + : Default allowed chars = "-\w.', ()" + : If $relax is true = "-\w.', ()\/=%:^<>*" + Usage : $Util->untaint($value, $relax) + Returns : String containing the untained data. + Argument: $value = string + : $relax = boolean + Comments: + This general untaint() function may not be appropriate for every situation. + To allow only a more restricted subset of special characters + (for example, untainting a regular expression), then using a custom + untainting mechanism would permit more control. + + Note that special trusted vars (like $0) require untainting. + +=cut + +#------------` +sub untaint { +#------------ + my($self,$value,$relax) = @_; + $relax ||= 0; + my $untainted; + + $self->debug("\nUNTAINT: $value\n"); + + unless (defined $value and $value ne '') { + return $value; + } + + if( $relax ) { + $value =~ /([-\w.\', ()\/=%:^<>*]+)/; + $untainted = $1 +# } elsif( $relax == 2 ) { # Could have several degrees of relax. +# $value =~ /([-\w.\', ()\/=%:^<>*]+)/; +# $untainted = $1 + } else { + $value =~ /([-\w.\', ()]+)/; + $untainted = $1 + } + + $self->debug("UNTAINTED: $untainted\n"); + + $untainted; +} + + +=head2 mean_stdev + + Title : mean_stdev + Usage : ($mean, $stdev) = $Util->mean_stdev( @data ) + Purpose : Calculates the mean and standard deviation given a list of numbers. + Returns : 2-element list (mean, stdev) + Argument : list of numbers (ints or floats) + Thows : n/a + +=cut + +#--------------- +sub mean_stdev { +#--------------- + my ($self, @data) = @_; + return (undef, undef) if not @data; # case of empty @data list + my $mean = 0; + my $N = 0; + foreach my $num (@data) { + $mean += $num; + $N++ + } + $mean /= $N; + my $sum_diff_sqd = 0; + foreach my $num (@data) { + $sum_diff_sqd += ($mean - $num) * ($mean - $num); + } + # if only one element in @data list, unbiased stdev is undefined + my $stdev = $N <= 1 ? undef : sqrt( $sum_diff_sqd / ($N-1) ); + return ($mean, $stdev); +} + + +=head2 count_files + + Title : count_files + Purpose : Counts the number of files/directories within a given directory. + : Also reports the number of text and binary files in the dir + : as well as names of these files and directories. + Usage : count_files(\%data) + : $data{-DIR} is the directory to be analyzed. Default is ./ + : $data{-PRINT} = 0|1; if 1, prints results to STDOUT, (default=0). + Argument : Hash reference (empty) + Returns : n/a; + : Modifies the hash ref passed in as the sole argument. + : $$href{-TOTAL} scalar + : $$href{-NUM_TEXT_FILES} scalar + : $$href{-NUM_BINARY_FILES} scalar + : $$href{-NUM_DIRS} scalar + : $$href{-T_FILE_NAMES} array ref + : $$href{-B_FILE_NAMES} array ref + : $$href{-DIRNAMES} array ref + +=cut + +#---------------- +sub count_files { +#---------------- + my $self = shift; + my $href = shift; # Reference to an empty hash. + my( $name, @fileLine); + my $dir = $$href{-DIR} || './'; # THIS IS UNIX SPECIFIC? FIXME/TODO + my $print = $$href{-PRINT} || 0; + + ### Make sure $dir ends with / + $dir !~ m{/$} and do{ $dir .= '/'; $$href{-DIR} = $dir; }; + + open ( my $PIPE, "ls -1 $dir |" ) || $self->throw("Can't open input pipe: $!"); + + ### Initialize the hash data. + $$href{-TOTAL} = 0; + $$href{-NUM_TEXT_FILES} = $$href{-NUM_BINARY_FILES} = $$href{-NUM_DIRS} = 0; + $$href{-T_FILE_NAMES} = []; + $$href{-B_FILE_NAMES} = []; + $$href{-DIR_NAMES} = []; + while( my $line = <$PIPE> ) { + chomp(); + $$href{-TOTAL}++; + if( -T $dir.$line ) { + $$href{-NUM_TEXT_FILES}++; + push @{$$href{-T_FILE_NAMES}}, $line; } + if( -B $dir.$line and not -d $dir.$line) { + $$href{-NUM_BINARY_FILES}++; + push @{$$href{-B_FILE_NAMES}}, $line; } + if( -d $dir.$line ) { + $$href{-NUM_DIRS}++; + push @{$$href{-DIR_NAMES}}, $line; } + } + close $PIPE; + + if( $print) { + printf( "\n%4d %s\n", $$href{-TOTAL}, "total files+dirs in $dir"); + printf( "%4d %s\n", $$href{-NUM_TEXT_FILES}, "text files"); + printf( "%4d %s\n", $$href{-NUM_BINARY_FILES}, "binary files"); + printf( "%4d %s\n", $$href{-NUM_DIRS}, "directories"); + } +} + + +=head2 file_info + + Title : file_info + Purpose : Obtains a variety of date for a given file. + : Provides an interface to Perl's stat(). + Status : Under development. Not ready. Don't use! + +=cut + +#-------------- +sub file_info { +#-------------- + my ($self, %param) = @_; + my ($file, $get, $fmt) = $self->_rearrange([qw(FILE GET FMT)], %param); + $get ||= 'all'; + $fmt ||= 'yyyy-mm-dd'; + + my($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, + $atime, $mtime, $ctime, $blksize, $blocks) = stat $file; + + if($get =~ /date/i) { + ## I can get the elapsed time since the file was modified but + ## it's not so straightforward to get the date in a nice format... + ## Think about using a standard CPAN module for this, like + ## Date::Manip or Date::DateCalc. + + my $date = $mtime; + my $elsec = time - $mtime; + printf "\nFile age: %.0f sec %.0f hrs %.0f days", $elsec, $elsec/3600, $elsec/(3600*24);; + my $days = sprintf "%.0f", $elsec/(3600*24); + } elsif($get eq 'all') { + return stat $file; + } +} + +=head2 delete + + Title : delete + Purpose : + +=cut + +#------------ +sub delete { +#------------ + my $self = shift; + my $fileName = shift; + if(not -e $fileName) { + $self->throw("Could not delete file '$fileName': Does not exist."); + } elsif(not -o $fileName) { + $self->throw("Could not delete file '$fileName': Not owner."); + } + my $ulval = unlink($fileName) > 0 + or $self->throw("Failed to delete file '$fileName': $!"); +} + + +=head2 create_filehandle + + Usage : $object->create_filehandle(); + Purpose : Create a FileHandle object from a file or STDIN. + : Mainly used as a helper method by read() and get_newline(). + Example : $data = $object->create_filehandle(-FILE =>'usr/people/me/data.txt') + Argument : Named parameters (case-insensitive): + : (all optional) + : -CLIENT => object reference for the object submitting + : the request. Default = $Util. + : -FILE => string (full path to file) or a reference + : to a FileHandle object or typeglob. This is an + : optional parameter (if not defined, STDIN is used). + Returns : Reference to a FileHandle object. + Throws : Exception if cannot open a supplied file or if supplied with a + : reference that is not a FileHandle ref. + Comments : If given a FileHandle reference, this method simply returns it. + : This method assumes the user wants to read ascii data. So, if + : the file is binary, it will be treated as a compressed (gzipped) + : file and access it using gzip -ce. The problem here is that not + : all binary files are necessarily compressed. Therefore, + : this method should probably have a -mode parameter to + : specify ascii or binary. + +See Also : L + +=cut + +#--------------------- +sub create_filehandle { +#--------------------- + my($self, @param) = @_; + my($client, $file, $handle) = + $self->_rearrange([qw( CLIENT FILE HANDLE )], @param); + + if(not ref $client) { $client = $self; } + $file ||= $handle; + if( $client->can('file')) { + $file = $client->file($file); + } + + my $FH; + my ($handle_ref); + + if($handle_ref = ref($file)) { + if($handle_ref eq 'FileHandle') { + $FH = $file; + $client->{'_input_type'} = "FileHandle"; + } elsif($handle_ref eq 'GLOB') { + $FH = $file; + $client->{'_input_type'} = "Glob"; + } else { + $self->throw(-class => 'Bio::Root::IOException', + -text => "Could not read file '$file': Not a FileHandle or GLOB ref."); + } + $self->verbose > 0 and printf STDERR "$ID: reading data from FileHandle\n"; + + } elsif($file) { + $client->{'_input_type'} = "FileHandle for $file"; + + # Use gzip -cd to access compressed data. + if( -B $file ) { + $client->{'_input_type'} .= " (compressed)"; + my $gzip = $self->find_exe('gzip'); + $file = "$gzip -cd $file |" + } + + require FileHandle; + $FH = FileHandle->new(); + open ($FH, $file) || $self->throw(-class=>'Bio::Root::FileOpenException', + -text =>"Could not access data file '$file': $!"); + $self->verbose > 0 and printf STDERR "$ID: reading data from file '$file'\n"; + + } else { + # Read from STDIN. + $FH = \*STDIN; + $self->verbose > 0 and printf STDERR "$ID: reading data from STDIN\n"; + $client->{'_input_type'} = "STDIN"; + } + + return $FH; +} + +=head2 get_newline + + Usage : $object->get_newline(); + Purpose : Determine the character(s) used for newlines in a given file or + : input stream. Delegates to Bio::Root::Utilities::get_newline() + Example : $data = $object->get_newline(-CLIENT => $anObj, + : -FILE =>'usr/people/me/data.txt') + Argument : Same arguemnts as for create_filehandle(). + Returns : Reference to a FileHandle object. + Throws : Propogates any exceptions thrown by Bio::Root::Utilities::get_newline(). + +See Also : L, L + +=cut + +#----------------- +sub get_newline { +#----------------- + my($self, @param) = @_; + + return $NEWLINE if defined $NEWLINE; + + my($client ) = + $self->_rearrange([qw( CLIENT )], @param); + + my $FH = $self->create_filehandle(@param); + + if(not ref $client) { $client = $self; } + + if($client->{'_input_type'} =~ /STDIN|Glob|compressed/) { + # Can't taste from STDIN since we can't seek 0 on it. + # Are other non special Glob refs seek-able? + # Attempt to guess newline based on platform. + # Not robust since we could be reading Unix files on a Mac, e.g. + if(defined $ENV{'MACPERL'}) { + $NEWLINE = "\015"; # \r + } else { + $NEWLINE = "\012"; # \n + } + } else { + $NEWLINE = $self->taste_file($FH); + } + + close ($FH) unless ($client->{'_input_type'} eq 'STDIN' || + $client->{'_input_type'} eq 'FileHandle' || + $client->{'_input_type'} eq 'Glob' ); + + delete $client->{'_input_type'}; + + return $NEWLINE || $DEFAULT_NEWLINE; +} + + +=head2 taste_file + + Usage : $object->taste_file( ); + : Mainly a utility method for get_newline(). + Purpose : Sample a filehandle to determine the character(s) used for a newline. + Example : $char = $Util->taste_file($FH) + Argument : Reference to a FileHandle object. + Returns : String containing an octal represenation of the newline character string. + : Unix = "\012" ("\n") + : Win32 = "\012\015" ("\r\n") + : Mac = "\015" ("\r") + Throws : Exception if no input is read within $TIMEOUT_SECS seconds. + : Exception if argument is not FileHandle object reference. + : Warning if cannot determine neewline char(s). + Comments : Based on code submitted by Vicki Brown (vlb@deltagen.com). + +See Also : L + +=cut + +#--------------- +sub taste_file { +#--------------- + my ($self, $FH) = @_; + my $BUFSIZ = 256; # Number of bytes read from the file handle. + my ($buffer, $octal, $str, $irs, $i); + + ref($FH) eq 'FileHandle' or $self->throw("Can't taste file: not a FileHandle ref"); + + $buffer = ''; + + # this is a quick hack to check for availability of alarm(); just copied + # from Bio/Root/IOManager.pm HL 02/19/01 + my $alarm_available = 1; + eval { + alarm(0); + }; + if($@) { + # alarm() not available (ActiveState perl for win32 doesn't have it. + # See jitterbug PR#98) + $alarm_available = 0; + } + $SIG{ALRM} = sub { die "Timed out!"; }; + my $result; + eval { + $alarm_available && alarm( $TIMEOUT_SECS ); + $result = read($FH, $buffer, $BUFSIZ); # read the $BUFSIZ characters of file + $alarm_available && alarm(0); + }; + if($@ =~ /Timed out!/) { + $self->throw( "Timed out while waiting for input.", + "Timeout period = $TIMEOUT_SECS seconds.\n" + ."For longer time before timing out, edit \$TIMEOUT_SECS in Bio::Root::Utilities.pm."); + + } elsif(not $result) { + my $err = $@; + $self->throw("read taste failed to read from FileHandle.", $err); + + } elsif($@ =~ /\S/) { + my $err = $@; + $self->throw("Unexpected error during read: $err"); + } + + seek($FH, 0, 0) or $self->throw("seek failed to seek 0 on FileHandle."); + + my @chars = split(//, $buffer); + my $flavor; + + for ($i = 0; $i <$BUFSIZ; $i++) { + if (($chars[$i] eq "\012")) { + unless ($chars[$i-1] eq "\015") { + $flavor='Unix'; + $octal = "\012"; + $str = '\n'; + $irs = "^J"; + last; + } + } elsif (($chars[$i] eq "\015") && ($chars[$i+1] eq "\012")) { + $flavor='DOS'; + $octal = "\015\012"; + $str = '\r\n'; + $irs = "^M^J"; + last; + } elsif (($chars[$i] eq "\015")) { + $flavor='Mac'; + $octal = "\015"; + $str = '\r'; + $irs = "^M"; + last; + } + } + if (not $octal) { + $self->warn("Could not determine newline char. Using '\012'"); + $octal = "\012"; + } else { + #print STDERR "FLAVOR=$flavor, NEWLINE CHAR = $irs\n"; + } + return($octal); +} + +=head2 file_flavor + + Usage : $object->file_flavor( ); + Purpose : Returns the 'flavor' of a given file (unix, dos, mac) + Example : print "$file has flavor: ", $Util->file_flavor($file); + Argument : filename = string, full path name for file + Returns : String describing flavor of file and handy info about line endings. + : One of these is returned: + : unix (\n or 012 or ^J) + : dos (\r\n or 015,012 or ^M^J) + : mac (\r or 015 or ^M) + : unknown + Throws : Exception if argument is not a file + : Propogates any exceptions thrown by Bio::Root::Utilities::get_newline(). + +See Also : L, L + +=cut + +#--------------- +sub file_flavor { +#--------------- + my ($self, $file) = @_; + my %flavors=("\012" =>'unix (\n or 012 or ^J)', + "\015\012" =>'dos (\r\n or 015,012 or ^M^J)', + "\015" =>'mac (\r or 015 or ^M)' + ); + + -f $file or $self->throw("Could not determine flavor: arg '$file' is either non existant or is not a file.\n"); + my $octal = $self->get_newline($file); + my $flavor = $flavors{$octal} || "unknown"; + return $flavor; +} + +###################################### +##### Mail Functions ######## +###################################### + +=head2 mail_authority + + Title : mail_authority + Usage : $Util->mail_authority( $message ) + Purpose : Syntactic sugar to send email to $Bio::Root::Global::AUTHORITY + +See Also : L + +=cut + +#--------------- +sub mail_authority { +#--------------- + my( $self, $message ) = @_; + my $script = $self->untaint($0,1); + + my $email = $self->{'_auth_email'} || $AUTHORITY; + if (defined $email) { + $self->send_mail( -TO=>$AUTHORITY, -SUBJ=>$script, -MSG=>$message); + } else { + $self->throw("Can't email authority. No email defined."); + } +} + +=head2 authority + + Title : authority + Usage : $Util->authority('admin@example.com'); + Purpose : Set/get the email address that should be notified by mail_authority() + +See Also : L + +=cut + +#------------- +sub authority { +#------------- + my( $self, $email ) = @_; + $self->{'_auth_email'} = $email if defined $email; + return $self->{'_auth_email'}; +} + + +=head2 send_mail + + Title : send_mail + Usage : $Util->send_mail( named_parameters ) + Purpose : Provides an interface to mail or sendmail, if available + Returns : n/a + Argument : Named parameters: (case-insensitive) + : -TO => e-mail address to send to + : -SUBJ => subject for message (optional) + : -MSG => message to be sent (optional) + : -CC => cc: e-mail address (optional) + Thows : Exception if TO: address appears bad or is missing. + : Exception if mail cannot be sent. + Comments : Based on TomC's tip at: + : http://www.perl.com/CPAN/doc/FMTEYEWTK/safe_shellings + : + : Using default 'From:' information. + : sendmail options used: + : -t: ignore the address given on the command line and + : get To:address from the e-mail header. + : -oi: prevents send_mail from ending the message if it + : finds a period at the start of a line. + +See Also : L + +=cut + + +#------------- +sub send_mail { +#------------- + my( $self, @param) = @_; + my($recipient,$subj,$message,$cc) = $self->_rearrange([qw(TO SUBJ MSG CC)],@param); + + $self->throw("Invalid or missing e-mail address: $recipient") + if not $recipient =~ /\S+\@\S+/; + + $subj ||= 'empty subject'; $message ||= ''; + + # Best to use mail rather than sendmail. Permissions on sendmail in + # linux distros have been significantly locked down in recent years, + # due to the perception that it is insecure. + my ($exe, $ccinfo); + if ($exe = $self->find_exe('mail')) { + if (defined $cc) { + $ccinfo = "-c $cc"; + } + $self->debug("send_mail: $exe -s '$subj' $ccinfo $recipient\n"); + open (MAIL, "| $exe -s '$subj' $ccinfo $recipient") || + $self->throw("Can't send email: mail cannot fork: $!"); + print MAIL <warn("mail didn't exit nicely: $?"); + close(MAIL); + } elsif ($exe = $self->find_exe('sendmail')) { + open (SENDMAIL, "| $exe -oi -t") || + $self->throw("Can't send email: sendmail cannot fork: $!"); + print SENDMAIL <warn("sendmail didn't exit nicely: $?"); + + close(SENDMAIL); + } else { + $self->throw("Can't find executable for mail or sendmail."); + } +} + + +=head2 find_exe + + Title : find_exe + Usage : $Util->find_exe(name); + Purpose : Locate an executable (for use in a system() call, e.g.)) + Example : $Util->find_exe("gzip"); + Returns : String containing executable that passes the -x test. + Returns undef if an executable of the supplied name cannot be found. + Argument : Name of executable to be found. + : Can be a full path. If supplied name is not executable, an executable + : of that name will be searched in all directories in the currently + : defined PATH environment variable. + Throws : No exceptions, but issues a warning if multiple paths are found + : for a given name. The first one is used. + Comments : TODO: Confirm functionality on all bioperl-supported platforms. + May get tripped up by variation in path separator character used + for splitting ENV{PATH}. +See Also : + +=cut + +#------------ +sub find_exe { +#------------ + my ($self, $name) = @_; + my @bindirs; + if ($^O =~ m/mswin/i) { + @bindirs = split ';', $ENV{'PATH'}; + # Add usual executable extension if missing or -x won't work + $name.= '.exe' if ($name !~ m/\.exe$/i); + } + else { + @bindirs = split ':', $ENV{'PATH'}; + } + my $exe = $name; + unless (-x $exe) { + undef $exe; + my @exes; + foreach my $d (@bindirs) { + # Note: Windows also understand '/' as folder separator, + # so there is no need to use a conditional with '\' + push(@exes, "$d/$name") if -x "$d/$name"; + } + if (scalar @exes) { + $exe = $exes[0]; + if (defined $exes[1]) { + $self->warn("find_exe: Multiple paths to '$name' found. Using $exe."); + } + } + } + return $exe; +} + + +###################################### +### Interactive Functions ##### +###################################### + + +=head2 yes_reply + + Title : yes_reply() + Usage : $Util->yes_reply( [query_string]); + Purpose : To test an STDIN input value for affirmation. + Example : print +( $Util->yes_reply('Are you ok') ? "great!\n" : "sorry.\n" ); + : $Util->yes_reply('Continue') || die; + Returns : Boolean, true (1) if input string begins with 'y' or 'Y' + Argument: query_string = string to be used to prompt user (optional) + : If not provided, 'Yes or no' will be used. + : Question mark is automatically appended. + +=cut + +#------------- +sub yes_reply { +#------------- + my $self = shift; + my $query = shift; + my $reply; + $query ||= 'Yes or no'; + print "\n$query? (y/n) [n] "; + chomp( $reply = ); + $reply =~ /^y/i; +} + + + +=head2 request_data + + Title : request_data() + Usage : $Util->request_data( [value_name]); + Purpose : To request data from a user to be entered via keyboard (STDIN). + Example : $name = $Util->request_data('Name'); + : # User will see: % Enter Name: + Returns : String, (data entered from keyboard, sans terminal newline.) + Argument: value_name = string to be used to prompt user. + : If not provided, 'data' will be used, (not very helpful). + : Question mark is automatically appended. + +=cut + +#---------------- +sub request_data { +#---------------- + my $self = shift; + my $data = shift || 'data'; + print "Enter $data: "; + # Remove the terminal newline char. + chomp($data = ); + $data; +} + +=head2 quit_reply + + Title : quit_reply + Usage : + Purpose : + +=cut + +sub quit_reply { +# Not much used since you can use request_data() +# and test for an empty string. + my $self = shift; + my $reply; + chop( $reply = ); + $reply =~ /^q.*/i; +} + + +=head2 verify_version + + Purpose : Checks the version of Perl used to invoke the script. + : Aborts program if version is less than the given argument. + Usage : verify_version('5.000') + +=cut + +#------------------ +sub verify_version { +#------------------ + my $self = shift; + my $reqVersion = shift; + + $] < $reqVersion and do { + printf STDERR ( "\a\n%s %0.3f.\n", "** Sorry. This Perl script requires at least version", $reqVersion); + printf STDERR ( "%s %0.3f %s\n\n", "You are running Perl version", $], "Please update your Perl!\n\n" ); + exit(1); + } +} + +1; + +__END__ diff --git a/Bio/Root/Version.pm b/Bio/Root/Version.pm new file mode 100644 index 000000000..7267b45fb --- /dev/null +++ b/Bio/Root/Version.pm @@ -0,0 +1,59 @@ +package Bio::Root::Version; +use strict; + +=head1 SYNOPSIS + + package Bio::Tools::NiftyFeature; + require Bio::Root::RootI; + + # later, in client code: + package main; + use Bio::Tools::NiftyFeature 3.14; + + ## alternative usage: NiftyFeature defines own $VERSION: + package Bio::Tools::NiftyFeature; + my $VERSION = 9.8; + + # later in client code: + package main; + + # ensure we're using an up-to-date BioPerl distribution + use Bio::Perl 3.14; + + # NiftyFeature has its own versioning scheme: + use Bio::Tools::NiftyFeature 9.8; + +=head1 DESCRIPTION + +This module provides a mechanism by which all other BioPerl modules +can share the same $VERSION, without manually synchronizing each file. + +Bio::Root::RootI itself uses this module, so any module that directly +(or indirectly) uses Bio::Root::RootI will get a global $VERSION +variable set if it's not already. + +=head1 AUTHOR Aaron Mackey + +=cut + +our $VERSION = '1.006925'; # pre-1.7 +$VERSION = eval $VERSION; + +sub import { + # try to handle multiple levels of inheritance: + my $i = 0; + my $pkg = caller($i); + no strict 'refs'; + while ($pkg) { + if ( $pkg =~ m/^Bio::/o + and not defined ${$pkg . "::VERSION"} + ) { + ${$pkg . "::VERSION"} = $VERSION; + } + $pkg = caller(++$i); + } +} + +1; + +__END__ diff --git a/Bio/Tools/Analysis/Protein/Mitoprot.pm b/Bio/Tools/Analysis/Protein/Mitoprot.pm index 637a31336..717191d16 100644 --- a/Bio/Tools/Analysis/Protein/Mitoprot.pm +++ b/Bio/Tools/Analysis/Protein/Mitoprot.pm @@ -146,8 +146,7 @@ use Bio::SeqFeature::Generic; use base qw(Bio::Tools::Analysis::SimpleAnalysisBase); $FLOAT = '[+-]?\d*\.\d*'; -my $URL = 'http://ihg.gsf.de/cgi-bin/paolo/mitofilter?'; - +my $URL = 'https://ihg.gsf.de/cgi-bin/paolo/mitofilter?'; my %STATUS = map { $_ => 1 } qw(CREATED COMPLETED TERMINATED_BY_ERROR); @@ -311,7 +310,7 @@ sub _run { $self->sleep; $self->status('TERMINATED_BY_ERROR'); - my $url = $self->url . "seq=".lc($self->seq->seq). "&seqnam="; + my $url = $self->url . "seq=" . lc($self->seq->seq) . "&seqnam="; my $request = GET $url; my $content = $self->request($request); my $text = $content->content; #1st reponse diff --git a/BioPerl.pm b/BioPerl.pm index 411ac459b..586da4c2b 100644 --- a/BioPerl.pm +++ b/BioPerl.pm @@ -20,54 +20,9 @@ BioPerl - Perl Modules for Biology =head1 SYNOPSIS -If you're new to BioPerl, you should start reading the BioPerl tutorial, an -overview of the BioPerl toolkit: +If you're new to BioPerl, you should start reading the BioPerl HOWTO's: -L - -=head2 Current Overview - -Core Bioperl documentation has been split up into the following sections: - -=over 3 - -=item * bioperl - -BioPerl overview (this document) - -=back - -We may add more documents in the future, including: - -=over 3 - -=item * biodatabases - -How to use databases with BioPerl - -=item * biodesign - -A guide for authoring a BioPerl module - -=item * bioscripts - -Description and overview of BioPerl scripts (in the I directory) - -=back - -=head2 Tutorials - -=over 3 - -=item * BioPerl tutorial for beginners - -L - -=item * Institut Pasteur BioPerl tutorial (note: for older versions of BioPerl) - -L - -=back +L =head2 References for Individual Modules @@ -105,23 +60,6 @@ and archives of standalone bio-related Perl tools that are not affiliated or related to the core BioPerl effort. Check the site for useful code ideas and contribute your own if possible. -=head1 DOCUMENTATION - -The Bio::Perl module (not this document) is designed to flatten the learning -curve for newcomers to Perl/Bioperl. This is a good place to start if you want -some simple functionality. We have a cookbook tutorial on-line: - -L - -which has embedded documentation. Start there if learning-by-example suits you -most, or examine the BioPerl online course at: - -L - -Make sure to check the documentation in the modules as well - there are over 900 -modules in BioPerl, and counting, and there's detail in the modules' -documentation that will not appear in the general documentation. - =head1 INSTALLATION The BioPerl modules are distributed as a tar file that expands into a standard @@ -132,15 +70,6 @@ instructions on the BioPerl website: L -=for TODO: Do we want to add biodesign and biodatabases back in? -The BioPerl modules can interact with local flat file and relational databases. -To learn how to set this up, look at the biodatabases.pod documentation -('perldoc biodatabases.pod' should work once BioPerl has been installed). - -Some BioPerl-related distributions such as Bio::Graphics, BioPerl-db, -BioPerl-run, BioPerl-gui, corba-server, BioPerl-ext, BioPerl-pipeline, -BioPerl-microarray and corba-client packages are installed separately from -BioPerl. Please refer to their respective documentation for more information. Note that only the following are supported at this time with the current API: =over 3 @@ -159,15 +88,10 @@ Note that only the following are supported at this time with the current API: =head1 GETTING STARTED -A good place to start is by reading the tutorial : L - The distribution I directory has working scripts for use with BioPerl, check the self-described I directory as well. You are more than welcome to contribute your script! -=for TODO Should we add bioscripts back to the distributions? -A list and brief description of all these scripts is found in bioscripts.pod. - If you have installed BioPerl in the standard way, as detailed in the INSTALL in the distribution, these scripts should work by just running them. If you have not installed it in a standard way you will have to change the 'use lib' to @@ -226,11 +150,6 @@ If you can make a useful object we will happily include it into the core. Probably you will want to read a lot of the documentation in L and talk to people on the BioPerl mailing list, B. -=for TODO Add biodesign.pod back? -biodesign.pod provides documentation on the conventions and ideas -used in BioPerl, it's definitely worth a read if you would like to be a BioPerl -developer. - =head2 Writing documentation We appreciate good documentation. It's what tells the world what's in BioPerl, diff --git a/Build.PL b/Build.PL dissimilarity index 65% index b171d2187..3604b82a8 100644 --- a/Build.PL +++ b/Build.PL @@ -1,462 +1,510 @@ -#!/usr/bin/perl - -# This is a Module::Build script for Bioperl installation. -# See http://search.cpan.org/~kwilliams/Module-Build/lib/Module/Build.pm - -# Uses a custom subclass of Module::Build called Bio::Root::Build - -# In the future developers may need to alter the requires and recommends -# sections of Bio::Root::Build->new() below, but otherwise nothing else here is -# likely to need changing. - -use strict; -use lib '.'; -use Bio::Root::Build; - -# XML::SAX::RTF doesn't work with BioPerl, at all, nada, zilch. -# -# Since we're running into this now on CPAN Testers, catch it up front and -# deal with it. -# -# See: https://rt.cpan.org/Ticket/Display.html?id=5943 -# https://redmine.open-bio.org/issues/2975 - -{ eval { require XML::SAX; 1; }; - -unless ($@) { - if (grep {$_->{Name} =~ 'XML::SAX::RTF'} @{XML::SAX->parsers()}) { - warn < [0, - # 'Access of ACeDB database/Bio::DB::Ace,Bio::DB::GFF::Adaptor::ace'], - - 'Algorithm::Munkres' => [0, - 'Phylogenetic Networks/Bio::PhyloNetwork'], - - 'Array::Compare' => [0, - 'Phylogenetic Networks/Bio::PhyloNetwork'], - - # this won't actually install due to circular dep, but we have no way of - # doing a post-install the [circular dependency!] specifies it is only - # installed on explicit request for this specific module, not when simply - # choosing to install 'all' modules - - #'Bio::ASN1::EntrezGene' => [0, - # 'Parsing entrezgene/Bio::SeqIO::entrezgene [circular dependency!]'], - - 'Bio::Phylo' => [0, - 'NeXML related modules/Bio::AlignIO::nexml,Bio::Nexml::Factory,'. - 'Bio::SeqIO::nexml,Bio::TreeIO::nexml'], - - 'Clone' => [0, - 'Cloning objects/Bio::Root::Root,Bio::Tools::Primer3'], - - 'Convert::Binary::C' => [0, - 'Strider functionality/Bio::SeqIO::strider'], - - 'DB_File' => [0, - 'Database functionality/Bio::Assemby,Bio::DB'], - - 'Error' => [0, - 'OO-based exception handling (very optional)/Bio::Root::Exception'], - - 'GD' => [0, - 'Alignment graphic output/Bio::Align::Graphics'], - - 'Graph' => [0.50, - 'Phylogenetic Networks, ontology engine implementation, contig analysis'. - '/Bio::PhyloNetwork,Bio::Ontology::SimpleGOEngine::GraphAdaptor,'. - 'Bio::Assembly::Tools::ContigSpectrum'], - - 'GraphViz' => [0, - 'Phylogenetic Network Visualization/Bio::PhyloNetwork::GraphViz'], - - 'HTML::Entities' => [0, - 'Remote analysis POST submissions/Bio::SearchIO::blastxml'], - - 'HTML::HeadParser' => [3, - 'Parsing section of HTML docs/Bio::Tools::Analysis::DNA::ESEfinder'], - - 'HTML::TableExtract' => [0, - 'Parsing HTML tables/Bio::DB::SeqVersion::gi'], - - 'HTTP::Request::Common' => [0, - 'GenBank+GenPept sequence retrieval, remote http Blast jobs'. - '/Bio::DB::*,Bio::Tools::Run::RemoteBlast,'. - 'Bio::Tools::Analysis::Protein*,Bio::Tools::Analysis::DNA*'], - - 'Inline::C' => [0.67, - 'Speeding up code like Fasta Bio::DB::Fasta'], - - 'IO::Scalar' => [0, - 'Deal with non-seekable filehandles/Bio::Tools::GuessSeqFormat'], - - 'List::MoreUtils' => [0, - 'Back- or reverse-translation of sequences/'. - 'Bio::Tools::SeqPattern,Bio::Tools::SeqPattern::BackTranslate'], - - 'LWP::UserAgent' => [0, - 'Remote access/Bio::DB::*,Bio::Tools::Run::RemoteBlast,Bio::WebAgent'], - - 'PostScript::TextBlock' => [0, - 'EPS output/Bio::Tree::Draw::Cladogram'], - - 'Set::Scalar' => [0, - 'Proper operation/Bio::Tree::Compatible'], - - 'SOAP::Lite' => [0, - 'Bibliographic queries/Bio::DB::Biblio::soap'], - - 'Sort::Naturally' => [0, - 'Sort lexically, but sort numeral parts numerically/'. - 'Bio::Assembly::IO::ace,Bio::Assembly::IO::tigr'], - - 'Spreadsheet::ParseExcel' => [0, - 'Parsing Excel files/Bio::SeqIO::excel'], - - 'Storable' => [2.05, - 'Storing sequence objects in local file cache/'. - 'Bio::DB::FileCache,Bio::SeqFeature::Collection,Bio::PopGen::HtSNP,'. - 'Bio::PopGen::TagHaplotype,Bio::DB::GFF::Adaptor::berkeleydb,Bio::Root::Root'], - - 'SVG' => [2.26, - 'Creating SVG images/Bio::Draw::Pictogram'], - - 'SVG::Graph' => [0.01, - 'Creating SVG images/Bio::TreeIO::svggraph'], - - 'Text::ParseWords' => [0, - 'Test scripts/Bio::DB::SeqFeature::Store::FeatureFileLoader'], - - 'XML::DOM' => [0, - 'Parsing XML/Bio::SeqIO::bsml,Bio::SeqIO::interpro'], - - 'XML::DOM::XPath' => [0, - 'Parsing XML/Bio::SeqIO::interpro'], - - 'XML::LibXML' => [0, - 'Parsing XML/Bio::SeqIO::seqxml,Bio::TreeIO::phyloxml'], - - 'XML::Parser' => [0, - 'Parsing XML/Bio::Biblio::IO::medlinexml'], - - 'XML::Parser::PerlSAX' => [0, - 'Parsing XML/Bio::SeqIO::tinyseq,Bio::SeqIO::game::gameSubs,', - 'Bio::OntologyIO::InterProParser,Bio::ClusterIO::dbsnp'], - - 'XML::SAX' => [0.15, - 'Parsing XML/Bio::SearchIO::blastxml,Bio::SeqIO::tigrxml,Bio::SeqIO::bsml_sax'], - - 'XML::SAX::Writer' => [0, - 'Writing XML/Bio::SeqIO::tigrxml'], - - 'XML::Simple' => [0, - 'Reading custom XML/Bio::Tools::EUtilities,Bio::DB::HIV,Bio::DB::Query::HIVQuery'], - - 'XML::Twig' => [0, - 'Parsing XML/Bio::Variation::IO::xml,Bio::DB::Taxonomy::entrez,'. - 'Bio::DB::Biblio::eutils'], - - 'XML::Writer' => [0.4, - 'Parsing and writing XML/Bio::SeqIO::agave,Bio::SeqIO::game::gameWriter,'. - 'Bio::SeqIO::chadoxml,Bio::SeqIO::tinyseq,Bio::Variation::IO::xml,'. - 'Bio::SearchIO::Writer::BSMLResultWriter'], - - 'YAML' => [0, - 'GenBank->GFF3/bp_genbank2gff3.pl'], -); - -my $mysql_ok = 0; - -my @drivers = available_drivers(); - -# Set up the Bio::Root::Build object -my $build = Bio::Root::Build->new( - module_name => 'Bio', - dist_name => 'BioPerl', - dist_version => '1.006925', - dist_author => 'BioPerl Team ', - dist_abstract => 'Bioinformatics Toolkit', - license => 'perl', - requires => { - 'perl' => '5.6.1', - 'IO::String' => 0, # why is this required? - 'Data::Stag' => 0.11, # Bio::SeqIO::swiss, we can change to 'recommend' if needed - 'Scalar::Util' => 0, # not in Perl 5.6.1, arrived in core in 5.7.3 - 'ExtUtils::Manifest' => '1.52', # allows spaces in file names - }, - - build_requires => { - 'CPAN' => 1.81, - 'Module::Build' => 0.2805, - 'Test::Harness' => 2.62, - 'Test::Most' => 0, - 'URI::Escape' => 0 - }, - - recommends => { - # reverted to a simple Module::Build-compatible hash, but we keep - # additional data in the %recommends hash above. May be converted to - # something simpler if there aren't complaints down the line. - map {$_ => $recommends{$_}[0]} sort keys %recommends - }, - - get_options => { - accept => { }, - network => { } # say 'perl Build.PL --network' to manually request network tests - }, - - auto_features => { - 'EntrezGene' => { - description => "Presence of Bio::ASN1::EntrezGene", - requires => { 'Bio::ASN1::EntrezGene' => 0 } # feature_requires is like requires, except that it doesn't trigger installation - }, - - 'DB_File Tests' => { - description => "BDB tests for Bio::DB::SeqFeature::Store", - requires => { 'DB_File' => 0 } # feature_requires is like requires, except that it doesn't trigger installation - }, - - 'Bio::DB::GFF Tests' => { - description => "Bio::DB::GFF database tests (will need to answer questions before really enabling)", - requires => { 'DBI' => 0 }, - }, - - 'MySQL Tests' => { - description => "MySQL-related tests for Bio::DB::SeqFeature::Store", - requires => { 'DBI' => 0, 'DBD::mysql' => 0 }, - }, - - 'Pg Tests' => { - description => "PostgreSQL-related tests for Bio::DB::SeqFeature::Store", - requires => { 'DBI' => 0, 'DBD::Pg' => 0}, - }, - - 'SQLite Tests' => { - description => "SQLite-related tests for Bio::DB::SeqFeature::Store", - requires => { 'DBI' => 0, 'DBD::SQLite' => 0}, - }, - - 'Network Tests' => { - description => "Enable tests that need an internet connection", - requires => { 'LWP::UserAgent' => 0 }, - } - }, - dynamic_config => 1, - recursive_test_files => 1, - - # Extra files needed for BioPerl modules - xml_files => {'./Bio/DB/HIV/lanl-schema.xml' => 'lib/Bio/DB/HIV/lanl-schema.xml'}, - - #pm_files => {} # modules in Bio are treated as if they were in lib and auto-installed - #script_files => [] # scripts in scripts directory are installed on-demand -); - -my $accept = $build->args('accept'); - -my $proceed = prompt_for_biodb($accept) - if $build->feature('Bio::DB::GFF') || $build->feature('MySQL Tests') || - $build->feature('Pg Tests') || $build->feature('SQLite Tests'); - -# Handle auto features -if ($proceed && $build->feature('DB_File Tests')) { - # will return without doing anything if user chose not to run tests during - make_bdb_test(); -} -if ($proceed && ($build->feature('MySQL Tests') || - $build->feature('Pg Tests') || - $build->feature('SQLite Tests'))) { - make_dbi_test(); -} - -# Ask questions -$build->choose_scripts($accept); - -if ($build->args('network')) { - if ($build->feature('Network Tests')) { - $build->notes(network => 1); - $build->log_info(" - will run internet-requiring tests\n"); - } - else { - $build->notes(network => 0); - $build->log_info(" - Missing LWP::UserAgent, can't run network tests\n"); - } -} -else { - $build->prompt_for_network($accept) if $build->feature('Network Tests'); -} - -# Add additional files here -$build->add_build_element('xml'); - -# Create the build script and exit -$build->create_build_script; - -exit; - -########################## Helper subs ########################## - -sub make_bdb_test { - my $path0 = File::Spec->catfile('t', 'LocalDB', 'SeqFeature.t'); - my $path = File::Spec->catfile('t', 'LocalDB','SeqFeature_BDB.t'); - unlink($path) if (-e $path); - open my $F, '>', $path or die "Could not write test file '$path': $!\n"; - print $F <add_to_cleanup($path); - #$build->add_to_manifest_skip($path); -} - -sub available_drivers { - eval {require DBI; 1;}; # if not installed, this sub won't actually be called - return if $@; - @drivers = DBI->available_drivers; - unless (grep {/mysql|Pg|SQLite/i} @drivers) { - $mysql_ok = 0; - return "Only MySQL, Postgres and SQLite DBI drivers supported for Bio::DB::SeqFeature RDMS tests"; - } - $mysql_ok = 1; - return @drivers; -} - -sub make_dbi_test { - my $dsn = $build->notes('test_dsn') || return; - my $path0 = File::Spec->catfile('t', 'LocalDB', 'SeqFeature.t'); - my $driver = $build->notes('dbd_driver'); - my $path = File::Spec->catfile('t', 'LocalDB', - ($driver eq 'mysql') ? 'SeqFeature_mysql.t' : - ($driver eq 'SQLite') ? 'SeqFeature_SQLite.t' : - 'SeqFeature_Pg.t'); - my $test_db = $build->notes('test_db'); - my $user = $build->notes('test_user'); - my $pass = $build->notes('test_pass'); - open my $F, '>', $path or die "Could not write file '$path' for DBI test: $!\n"; - my $str = "$path0 -adaptor DBI::$driver -create 1 -temp 1 -dsn \"$dsn\""; - $str .= " -user $user" if $user; - $str .= " -password $pass" if $pass; - print $F <add_to_cleanup($path); - $build->add_to_cleanup($test_db) if $driver eq 'SQLite'; - #$build->add_to_manifest_skip($path); -} - -sub test_biodbgff { - eval {require DBI;}; # if not installed, this sub won't actually be called - return if $@; - @drivers = DBI->available_drivers; - unless (grep {/mysql|Pg|Oracle/i} @drivers) { - return "MySQL, Pg nor Oracle DBI drivers are installed"; - } - return; -} - -sub prompt_for_biodb { - my $accept = shift; - my $proceed = $accept ? 0 : $build->y_n("Do you want to run the Bio::DB::GFF or ". - "Bio::DB::SeqFeature::Store live database tests? ". - "y/n", 'n'); - - if ($proceed) { - my @driver_choices; - foreach my $poss ('SQLite', 'mysql', 'Pg', 'Oracle') { - if (grep {/$poss/i} @drivers) { - my $choice = $poss; - $choice =~ s/^(.)/[$1]/; - push(@driver_choices, $choice); - } - } - - my $driver; - if (@driver_choices > 1) { - my ($default) = $driver_choices[0] =~ /\[(.)/; - $driver = $build->prompt("Which database driver should be used? ".join(" ", @driver_choices), $default); - } - else { - ($driver) = $driver_choices[0] =~ /\[(.)/; - } - if ($driver =~ /^[mM]/) { - $driver = 'mysql'; - } - elsif ($driver =~ /^[pP]/) { - $driver = 'Pg'; - } - elsif ($driver =~ /^[oO]/) { - $driver = 'Oracle'; - } - elsif ($driver =~ /^[sS]/) { - $driver = 'SQLite'; - } - - my $test_db = $build->prompt("Which database should I use for testing the $driver driver?\n". - "This database should already be present but doesn't have to ". - "be preloaded for any schema", 'test'); - my $test_host = $build->prompt("On which host is database '$test_db' running (hostname, ip address or host:port)", 'localhost'); - my $test_user = $build->prompt("User name for connecting to database '$test_db'?", 'undef'); - my $test_pass = $build->prompt("Password for connecting to database '$test_db'?", 'undef'); - - my $use_host = 1; - if ($test_host eq 'undef' || $test_host eq 'localhost') { - $use_host = 0; - } - - my $test_dsn; - if ($driver eq 'Pg' || $driver eq 'SQLite') { - $test_dsn = "dbi:$driver:dbname=$test_db"; - $mysql_ok = 0; - } - else { - $test_dsn = "dbi:$driver:database=$test_db"; - $mysql_ok = 0; - } - if ($use_host) { - $test_dsn .= ";host=$test_host"; - } - - $build->notes(dbd_driver => $driver); - $build->notes(test_db => $test_db); - $build->notes(test_host => $test_host); - $build->notes(test_user => $test_user eq 'undef' ? undef : $test_user); - $build->notes(test_pass => $test_pass eq 'undef' ? undef : $test_pass); - $build->notes(test_dsn => $test_dsn); - - $build->log_info(" - will run tests with database driver '$driver' and these settings:\n", - " Database $test_db\n", - " Host $test_host\n", - " DSN $test_dsn\n", - " User $test_user\n", - " Password $test_pass\n"); - $build->log_info(" - will not run the BioDBSeqFeature live ". - "database tests (requires MySQL or Pg driver)\n") unless ($driver eq 'mysql' or $driver eq 'Pg'); - } - else { - $build->log_info(" - will not run the BioDBGFF or BioDBSeqFeature live database tests\n"); - } - - $build->log_info("\n"); - return $proceed; -} +#!/usr/bin/perl + +# This is a Module::Build script for Bioperl installation. +# See http://search.cpan.org/~kwilliams/Module-Build/lib/Module/Build.pm + +# Uses a custom subclass of Module::Build called Bio::Root::Build + +# In the future developers may need to alter the requires and recommends +# sections of Bio::Root::Build->new() below, but otherwise nothing else here is +# likely to need changing. + +use strict; +use lib '.'; +use Bio::Root::Build; + +# XML::SAX::RTF doesn't work with BioPerl, at all, nada, zilch. +# +# Since we're running into this now on CPAN Testers, catch it up front and +# deal with it. +# +# See: https://rt.cpan.org/Ticket/Display.html?id=5943 +# https://redmine.open-bio.org/issues/2975 + +{ + eval { require XML::SAX; 1; }; + + unless ($@) { + if ( grep { $_->{Name} =~ 'XML::SAX::RTF' } @{ XML::SAX->parsers() } ) + { + warn < [0, + # 'Access of ACeDB database/Bio::DB::Ace,Bio::DB::GFF::Adaptor::ace'], + + 'Algorithm::Munkres' => [ 0, 'Phylogenetic Networks/Bio::PhyloNetwork' ], + + 'Array::Compare' => [ 0, 'Phylogenetic Networks/Bio::PhyloNetwork' ], + + # this won't actually install due to circular dep, but we have no way of + # doing a post-install the [circular dependency!] specifies it is only + # installed on explicit request for this specific module, not when simply + # choosing to install 'all' modules + + #'Bio::ASN1::EntrezGene' => [0, + # 'Parsing entrezgene/Bio::SeqIO::entrezgene [circular dependency!]'], + + 'Bio::Phylo' => [ + 0, + 'NeXML related modules/Bio::AlignIO::nexml,Bio::Nexml::Factory,' + . 'Bio::SeqIO::nexml,Bio::TreeIO::nexml' + ], + + 'Clone' => [ 0, 'Cloning objects/Bio::Root::Root,Bio::Tools::Primer3' ], + + 'Convert::Binary::C' => + [ 0, 'Strider functionality/Bio::SeqIO::strider' ], + + 'DB_File' => [ 0, 'Database functionality/Bio::Assemby,Bio::DB' ], + + 'Error' => [ + 0, 'OO-based exception handling (very optional)/Bio::Root::Exception' + ], + + 'HTML::TableExtract' => [ + 0, 'HTML parsing/Bio::DB::SeqVersion::gi' + ], + + 'GD' => [ 0, 'Alignment graphic output/Bio::Align::Graphics' ], + + 'Graph' => [ + 0.50, + 'Phylogenetic Networks, ontology engine implementation, contig analysis' + . '/Bio::PhyloNetwork,Bio::Ontology::SimpleGOEngine::GraphAdaptor,' + . 'Bio::Assembly::Tools::ContigSpectrum' + ], + + 'GraphViz' => [ + 0, 'Phylogenetic Network Visualization/Bio::PhyloNetwork::GraphViz' + ], + + 'HTML::Entities' => + [ 0, 'Remote analysis POST submissions/Bio::SearchIO::blastxml' ], + + 'HTML::HeadParser' => [ + 3, + 'Parsing section of HTML docs/Bio::Tools::Analysis::DNA::ESEfinder' + ], + + 'HTML::TableExtract' => + [ 0, 'Parsing HTML tables/Bio::DB::SeqVersion::gi' ], + + 'HTTP::Request::Common' => [ + 0, + 'GenBank+GenPept sequence retrieval, remote http Blast jobs' + . '/Bio::DB::*,Bio::Tools::Run::RemoteBlast,' + . 'Bio::Tools::Analysis::Protein*,Bio::Tools::Analysis::DNA*' + ], + + 'Inline::C' => [ 0.67, 'Speeding up code like Fasta Bio::DB::Fasta' ], + + 'IO::Scalar' => [ + 0, 'Deal with non-seekable filehandles/Bio::Tools::GuessSeqFormat' + ], + + 'List::MoreUtils' => [ + 0, + 'Back- or reverse-translation of sequences/' + . 'Bio::Tools::SeqPattern,Bio::Tools::SeqPattern::BackTranslate' + ], + + 'LWP::UserAgent' => [ + 0, + 'Remote access/Bio::DB::*,Bio::Tools::Run::RemoteBlast,Bio::WebAgent' + ], + + 'PostScript::TextBlock' => [ 0, 'EPS output/Bio::Tree::Draw::Cladogram' ], + + 'Set::Scalar' => [ 0, 'Proper operation/Bio::Tree::Compatible' ], + + 'SOAP::Lite' => [ 0, 'Bibliographic queries/Bio::DB::Biblio::soap' ], + + 'Sort::Naturally' => [ + 0, + 'Sort lexically, but sort numeral parts numerically/' + . 'Bio::Assembly::IO::ace,Bio::Assembly::IO::tigr' + ], + + 'Spreadsheet::ParseExcel' => + [ 0, 'Parsing Excel files/Bio::SeqIO::excel' ], + + 'Storable' => [ + 2.05, + 'Storing sequence objects in local file cache/' + . 'Bio::DB::FileCache,Bio::SeqFeature::Collection,Bio::PopGen::HtSNP,' + . 'Bio::PopGen::TagHaplotype,Bio::DB::GFF::Adaptor::berkeleydb,Bio::Root::Root' + ], + + 'SVG' => [ 2.26, 'Creating SVG images/Bio::Draw::Pictogram' ], + + 'SVG::Graph' => [ 0.01, 'Creating SVG images/Bio::TreeIO::svggraph' ], + + 'Text::ParseWords' => + [ 0, 'Test scripts/Bio::DB::SeqFeature::Store::FeatureFileLoader' ], + + 'XML::DOM' => [ 0, 'Parsing XML/Bio::SeqIO::bsml,Bio::SeqIO::interpro' ], + + 'XML::DOM::XPath' => [ 0, 'Parsing XML/Bio::SeqIO::interpro' ], + + 'XML::LibXML' => + [ 0, 'Parsing XML/Bio::SeqIO::seqxml,Bio::TreeIO::phyloxml' ], + + 'XML::Parser' => [ 0, 'Parsing XML/Bio::Biblio::IO::medlinexml' ], + + 'XML::Parser::PerlSAX' => [ + 0, + 'Parsing XML/Bio::SeqIO::tinyseq,Bio::SeqIO::game::gameSubs,', + 'Bio::OntologyIO::InterProParser,Bio::ClusterIO::dbsnp' + ], + + 'XML::SAX' => [ + 0.15, + 'Parsing XML/Bio::SearchIO::blastxml,Bio::SeqIO::tigrxml,Bio::SeqIO::bsml_sax' + ], + + 'XML::SAX::Writer' => [ 0, 'Writing XML/Bio::SeqIO::tigrxml' ], + + 'XML::Simple' => [ + 0, + 'Reading custom XML/Bio::Tools::EUtilities,Bio::DB::HIV,Bio::DB::Query::HIVQuery' + ], + + 'XML::Twig' => [ + 0, + 'Parsing XML/Bio::Variation::IO::xml,Bio::DB::Taxonomy::entrez,' + . 'Bio::DB::Biblio::eutils' + ], + + 'XML::Writer' => [ + 0.4, + 'Parsing and writing XML/Bio::SeqIO::agave,Bio::SeqIO::game::gameWriter,' + . 'Bio::SeqIO::chadoxml,Bio::SeqIO::tinyseq,Bio::Variation::IO::xml,' + . 'Bio::SearchIO::Writer::BSMLResultWriter' + ], + + 'YAML' => [ 0, 'GenBank->GFF3/bp_genbank2gff3.pl' ], +); + +my $mysql_ok = 0; + +my @drivers = available_drivers(); + +# Set up the Bio::Root::Build object +my $build = Bio::Root::Build->new( + module_name => 'Bio', + dist_name => 'BioPerl', + dist_version => '1.006925', + dist_author => 'BioPerl Team ', + dist_abstract => 'Bioinformatics Toolkit', + license => 'perl', + requires => { + 'perl' => '5.6.1', + 'IO::String' => 0, # why is this required? + 'Data::Stag' => 0.11, # Bio::SeqIO::swiss, we can change to 'recommend' if needed + 'Scalar::Util' => 0, # not in Perl 5.6.1, arrived in core in 5.7.3 + 'ExtUtils::Manifest' => '1.52', # allows spaces in file names + }, + + build_requires => { + 'CPAN' => 1.81, + 'Module::Build' => 0.2805, + 'Test::Harness' => 2.62, + 'Test::Most' => 0, + 'URI::Escape' => 0 + }, + + recommends => { + # reverted to a simple Module::Build-compatible hash, but we keep + # additional data in the %recommends hash above. May be converted to + # something simpler if there aren't complaints down the line. + map { $_ => $recommends{$_}[0] } sort keys %recommends + }, + + get_options => { + accept => {}, + network => {} # say 'perl Build.PL --network' to manually request network tests + }, + + auto_features => { + 'EntrezGene' => { + description => "Presence of Bio::ASN1::EntrezGene", + requires => { 'Bio::ASN1::EntrezGene' => 0 } # feature_requires is like requires, except that it doesn't trigger installation + }, + + 'DB_File Tests' => { + description => "BDB tests for Bio::DB::SeqFeature::Store", + requires => { 'DB_File' => 0 } # feature_requires is like requires, except that it doesn't trigger installation + }, + + 'Bio::DB::GFF Tests' => { + description => + "Bio::DB::GFF database tests (will need to answer questions before really enabling)", + requires => { 'DBI' => 0 }, + }, + + 'MySQL Tests' => { + description => + "MySQL-related tests for Bio::DB::SeqFeature::Store", + requires => { 'DBI' => 0, 'DBD::mysql' => 0 }, + }, + + 'Pg Tests' => { + description => + "PostgreSQL-related tests for Bio::DB::SeqFeature::Store", + requires => { 'DBI' => 0, 'DBD::Pg' => 0 }, + }, + + 'SQLite Tests' => { + description => + "SQLite-related tests for Bio::DB::SeqFeature::Store", + requires => { 'DBI' => 0, 'DBD::SQLite' => 0 }, + }, + + 'Network Tests' => { + description => "Enable tests that need an internet connection", + requires => { 'LWP::UserAgent' => 0 }, + } + }, + dynamic_config => 1, + recursive_test_files => 1, + + # Extra files needed for BioPerl modules + xml_files => { + './Bio/DB/HIV/lanl-schema.xml' => 'lib/Bio/DB/HIV/lanl-schema.xml' + }, + +#pm_files => {} # modules in Bio are treated as if they were in lib and auto-installed +#script_files => [] # scripts in scripts directory are installed on-demand +); + +my $accept = $build->args('accept'); + +my $proceed = prompt_for_biodb($accept) + if $build->feature('Bio::DB::GFF') + || $build->feature('MySQL Tests') + || $build->feature('Pg Tests') + || $build->feature('SQLite Tests'); + +# Handle auto features +if ( $proceed && $build->feature('DB_File Tests') ) { + + # will return without doing anything if user chose not to run tests during + make_bdb_test(); +} +if ($proceed + && ( $build->feature('MySQL Tests') + || $build->feature('Pg Tests') + || $build->feature('SQLite Tests') ) + ) { + make_dbi_test(); +} + +# Ask questions +$build->choose_scripts($accept); + +if ( $build->args('network') ) { + if ( $build->feature('Network Tests') ) { + $build->notes( network => 1 ); + $build->log_info(" - will run internet-requiring tests\n"); + } else { + $build->notes( network => 0 ); + $build->log_info( + " - Missing LWP::UserAgent, can't run network tests\n"); + } +} else { + $build->prompt_for_network($accept) if $build->feature('Network Tests'); +} + +# Add additional files here +$build->add_build_element('xml'); + +# Create the build script and exit +$build->create_build_script; + +exit; + +########################## Helper subs ########################## + +sub make_bdb_test { + my $path0 = File::Spec->catfile( 't', 'LocalDB', 'SeqFeature.t' ); + my $path = File::Spec->catfile( 't', 'LocalDB', 'SeqFeature_BDB.t' ); + unlink($path) if ( -e $path ); + open my $F, '>', $path or die "Could not write test file '$path': $!\n"; + print $F <add_to_cleanup($path); + + #$build->add_to_manifest_skip($path); +} + +sub available_drivers { + eval { require DBI; 1; }; # if not installed, this sub won't actually be called + return if $@; + @drivers = DBI->available_drivers; + unless ( grep {/mysql|Pg|SQLite/i} @drivers ) { + $mysql_ok = 0; + return + "Only MySQL, Postgres and SQLite DBI drivers supported for Bio::DB::SeqFeature RDMS tests"; + } + $mysql_ok = 1; + return @drivers; +} + +sub make_dbi_test { + my $dsn = $build->notes('test_dsn') || return; + my $path0 = File::Spec->catfile( 't', 'LocalDB', 'SeqFeature.t' ); + my $driver = $build->notes('dbd_driver'); + my $path = File::Spec->catfile( 't', 'LocalDB', + ( $driver eq 'mysql' ) ? 'SeqFeature_mysql.t' + : ( $driver eq 'SQLite' ) ? 'SeqFeature_SQLite.t' + : 'SeqFeature_Pg.t' ); + my $test_db = $build->notes('test_db'); + my $user = $build->notes('test_user'); + my $pass = $build->notes('test_pass'); + open my $F, '>', $path + or die "Could not write file '$path' for DBI test: $!\n"; + my $str = "$path0 -adaptor DBI::$driver -create 1 -temp 1 -dsn \"$dsn\""; + $str .= " -user $user" if $user; + $str .= " -password $pass" if $pass; + print $F <add_to_cleanup($path); + $build->add_to_cleanup($test_db) if $driver eq 'SQLite'; + + #$build->add_to_manifest_skip($path); +} + +sub test_biodbgff { + eval { require DBI; }; # if not installed, this sub won't actually be called + return if $@; + @drivers = DBI->available_drivers; + unless ( grep {/mysql|Pg|Oracle/i} @drivers ) { + return "MySQL, Pg nor Oracle DBI drivers are installed"; + } + return; +} + +sub prompt_for_biodb { + my $accept = shift; + my $proceed = $accept ? 0 : $build->y_n( + "Do you want to run the Bio::DB::GFF or " + . "Bio::DB::SeqFeature::Store live database tests? " . "y/n", + 'n' + ); + + if ($proceed) { + my @driver_choices; + foreach my $poss ( 'SQLite', 'mysql', 'Pg', 'Oracle' ) { + if ( grep {/$poss/i} @drivers ) { + my $choice = $poss; + $choice =~ s/^(.)/[$1]/; + push( @driver_choices, $choice ); + } + } + + my $driver; + if ( @driver_choices > 1 ) { + my ($default) = $driver_choices[0] =~ /\[(.)/; + $driver = $build->prompt( + "Which database driver should be used? " + . join( " ", @driver_choices ), + $default + ); + } else { + ($driver) = $driver_choices[0] =~ /\[(.)/; + } + if ( $driver =~ /^[mM]/ ) { + $driver = 'mysql'; + } elsif ( $driver =~ /^[pP]/ ) { + $driver = 'Pg'; + } elsif ( $driver =~ /^[oO]/ ) { + $driver = 'Oracle'; + } elsif ( $driver =~ /^[sS]/ ) { + $driver = 'SQLite'; + } + + my $test_db = $build->prompt( + "Which database should I use for testing the $driver driver?\n" + . "This database should already be present but doesn't have to " + . "be preloaded for any schema", + 'test' + ); + my $test_host = $build->prompt( + "On which host is database '$test_db' running (hostname, ip address or host:port)", + 'localhost' + ); + my $test_user = $build->prompt( + "User name for connecting to database '$test_db'?", 'undef' ); + my $test_pass = $build->prompt( + "Password for connecting to database '$test_db'?", 'undef' ); + + my $use_host = 1; + if ( $test_host eq 'undef' || $test_host eq 'localhost' ) { + $use_host = 0; + } + + my $test_dsn; + if ( $driver eq 'Pg' || $driver eq 'SQLite' ) { + $test_dsn = "dbi:$driver:dbname=$test_db"; + $mysql_ok = 0; + } else { + $test_dsn = "dbi:$driver:database=$test_db"; + $mysql_ok = 0; + } + if ($use_host) { + $test_dsn .= ";host=$test_host"; + } + + $build->notes( dbd_driver => $driver ); + $build->notes( test_db => $test_db ); + $build->notes( test_host => $test_host ); + $build->notes( + test_user => $test_user eq 'undef' ? undef : $test_user ); + $build->notes( + test_pass => $test_pass eq 'undef' ? undef : $test_pass ); + $build->notes( test_dsn => $test_dsn ); + + $build->log_info( + " - will run tests with database driver '$driver' and these settings:\n", + " Database $test_db\n", + " Host $test_host\n", + " DSN $test_dsn\n", + " User $test_user\n", + " Password $test_pass\n" + ); + $build->log_info( " - will not run the BioDBSeqFeature live " + . "database tests (requires MySQL or Pg driver)\n" ) + unless ( $driver eq 'mysql' or $driver eq 'Pg' ); + } else { + $build->log_info( + " - will not run the BioDBGFF or BioDBSeqFeature live database tests\n" + ); + } + + $build->log_info("\n"); + return $proceed; +} diff --git a/README b/README index 9d06d3187..d52b9ede5 100644 --- a/README +++ b/README @@ -58,8 +58,8 @@ o The directory structure o Documentation - For documentation on BioPerl see the HOWTO documents and tutorials - online at http://bioperl.org. + For documentation on BioPerl see the HOWTO documents at + http://www.bioperl.org/wiki/HOWTOs. Useful documentation in the form of example code can also be found in the examples/ and scripts/ directories. The current collection diff --git a/README.md b/README.md index dfccbb4b6..90b4cf47c 100644 --- a/README.md +++ b/README.md @@ -62,8 +62,7 @@ The BioPerl directory structure is organized as follows: # Documentation -For documentation on BioPerl see the **HOWTO** documents and tutorials online at -http://bioperl.org. +For documentation on BioPerl see the **HOWTO** documents online at http://www.bioperl.org/wiki/HOWTOs. Useful documentation in the form of example code can also be found in the **`examples/`** and **`scripts/`** directories. The current collection includes diff --git a/maintenance/big_split/file_classification.csv b/maintenance/big_split/file_classification.csv index 3c36ca646..03bd4bbf6 100644 --- a/maintenance/big_split/file_classification.csv +++ b/maintenance/big_split/file_classification.csv @@ -914,8 +914,6 @@ ,"examples/root/README" ,"examples/root/exceptions1.pl" ,"examples/root/exceptions2.pl" -,"examples/root/lib/TestInterface.pm" -,"examples/root/lib/TestObject.pm" ,"examples/root/exceptions4.pl" ,"examples/sirna/rnai_finder.cgi" ,"examples/sirna/TAG" diff --git a/t/Restriction/IO.t b/t/Restriction/IO.t index 409f2597f..2af928dd0 100644 --- a/t/Restriction/IO.t +++ b/t/Restriction/IO.t @@ -1,22 +1,20 @@ # -*-Perl-*- Test Harness script for Bioperl -# $Id$ - use strict; BEGIN { use lib '.'; use Bio::Root::Test; - - test_begin(-tests => 18); - + + test_begin( -tests => 17 ); + use_ok('Bio::Restriction::IO'); } # # default enz set # -ok my $in = Bio::Restriction::IO->new(); +ok my $in = Bio::Restriction::IO->new(); ok my $renzs = $in->read; is $renzs->each_enzyme, 532; @@ -24,11 +22,12 @@ ok my $e = $renzs->get_enzyme('AccI'); is $e->name, 'AccI'; my $outfile = test_output_file(); -ok my $out = Bio::Restriction::IO->new(-format => 'base', -file => ">$outfile"); +ok my $out = Bio::Restriction::IO->new( -format => 'base', -file => ">$outfile" ); TODO: { local $TODO = "writing to a file doesn't seem to work? prints to STDOUT!"; + #$out->write($renzs); - ok -s $outfile; + # ok -s $outfile; #map {print $_->name, "\t", $_->site, "\t", $_->overhang, "\n"} $renzs->each_enzyme; } @@ -36,10 +35,11 @@ TODO: { # withrefm, 31 # -ok $in = Bio::Restriction::IO->new - (-format=> 'withrefm', - -verbose => 0, - -file => test_input_file('rebase.withrefm')); +ok $in = Bio::Restriction::IO->new( + -format => 'withrefm', + -verbose => 0, + -file => test_input_file('rebase.withrefm') +); ok $renzs = $in->read; is $renzs->each_enzyme, 11; @@ -49,23 +49,29 @@ is $renzs->each_enzyme, 11; #enzyme name [tab] prototype [tab] recognition sequence with cleavage site # [tab] methylation site and type [tab] commercial source [tab] references -ok $in = Bio::Restriction::IO->new - (-format=> 'itype2', -verbose => 0, - -file => test_input_file('rebase.itype2')); +ok $in = Bio::Restriction::IO->new( + -format => 'itype2', + -verbose => 0, + -file => test_input_file('rebase.itype2') +); ok $renzs = $in->read; is $renzs->each_enzyme, 16; -ok $out = Bio::Restriction::IO->new(-format=>'base'); +ok $out = Bio::Restriction::IO->new( -format => 'base' ); SKIP: { - test_skip(-tests => 3, - -requires_module => 'LWP::UserAgent', - -requires_networking => 1); - - ok $in = Bio::Restriction::IO->new(-format=>'prototype', - -current => 1); - + test_skip( + -tests => 3, + -requires_module => 'LWP::UserAgent', + -requires_networking => 1 + ); + + ok $in = Bio::Restriction::IO->new( + -format => 'prototype', + -current => 1 + ); + ok my $coll = $in->read; cmp_ok $coll->each_enzyme, '>=', 307; } diff --git a/t/Root/Exception.t b/t/Root/Exception.t new file mode 100644 index 000000000..0b6fa0733 --- /dev/null +++ b/t/Root/Exception.t @@ -0,0 +1,69 @@ +# -*-Perl-*- Test Harness script for Bioperl + +use strict; + +BEGIN { + eval {require Error;}; + + use lib qw( . t/lib ); + use Bio::Root::Test; + + test_begin(-tests => 7, + -requires_module => 'Error'); + + use_ok('Bio::Root::TestObject'); +} + +use Error qw(:try); +$Error::Debug = test_debug(); + +# Set up a tester object. +ok my $test = Bio::Root::TestObject->new(-verbose => test_debug()); + +is $test->data('Eeny meeny miney moe.'), 'Eeny meeny miney moe.'; + +# This demonstrates what will happen if a method defined in an +# interface that is not implemented in the implementating object. + +eval { + try { + $test->foo(); + } + catch Bio::Root::NotImplemented with { + my $err = shift; + is ref $err, 'Bio::Root::NotImplemented'; + }; +}; + +# TestObject::bar() deliberately throws a Bio::TestException, +# which is defined in TestObject.pm +try { + $test->bar; +} +catch Bio::TestException with { + my $err = shift; + is ref $err, 'Bio::TestException'; +}; + + +# Use the non-object-oriented syntax to throw a generic Bio::Root::Exception. +try { + throw Bio::Root::Exception( "A generic error", 42 ); +} +catch Bio::Root::Exception with { + my $err = shift; + is ref $err, 'Bio::Root::Exception'; + is $err->value, 42; +}; + +# Try to call a subroutine that doesn't exist. But because it occurs +# within a try block, the Error module will create a Error::Simple to +# capture it. Handy eh? + +try { + $test->foobar(); +} +otherwise { + my $err = shift; + is ref $err, 'Error::Simple'; +}; diff --git a/t/Root/HTTPget.t b/t/Root/HTTPget.t index aea8d96c3..934cdba6f 100644 --- a/t/Root/HTTPget.t +++ b/t/Root/HTTPget.t @@ -1,5 +1,4 @@ # -*-Perl-*- Test Harness script for Bioperl -# $Id: RootIO.t 16840 2010-02-16 17:14:12Z cjfields $ use strict; use warnings; diff --git a/t/Root/IO.t b/t/Root/IO.t new file mode 100644 index 000000000..50806ea3d --- /dev/null +++ b/t/Root/IO.t @@ -0,0 +1,424 @@ +# -*-Perl-*- Test Harness script for Bioperl + +use strict; +use warnings; + +BEGIN { + use lib '.'; + use Bio::Root::Test; + test_begin(-tests => 154); + use_ok 'Bio::Root::IO'; +} + + +ok my $obj = Bio::Root::IO->new(); +isa_ok $obj, 'Bio::Root::IO'; + + +############################################# +# tests for exceptions/debugging/verbosity +############################################# + +throws_ok { $obj->throw('Testing throw') } qr/Testing throw/, 'Throw'; + +$obj->verbose(-1); +throws_ok { $obj->throw('Testing throw') } qr/Testing throw/; + +eval { $obj->warn('Testing warn') }; +ok !$@, 'Warn'; + +$obj->verbose(1); +throws_ok { $obj->throw('Testing throw') } qr/Testing throw/; + +ok my @stack = $obj->stack_trace(), 'Stack trace'; +is scalar @stack, 2; + +ok my $verbobj = Bio::Root::IO->new( -verbose => 1, -strict => 1 ), 'Verbosity'; +is $verbobj->verbose(), 1; + +ok $obj->verbose(-1); + + +############################################# +# tests for finding executables +############################################# + +ok my $io = Bio::Root::IO->new(); + +# An executable file +my $out_file = 'test_file.txt'; +my $out_fh; +open $out_fh, '>', $out_file or die "Could not write file '$out_file': $!\n"; +print $out_fh 'test'; +close $out_fh; +# -X test file will fail in Windows regardless of chmod, +# because it looks for the executable suffix (like ".exe") +if ($^O =~ m/mswin/i) { + # An executable file + my $exec_file = 'test_exec.exe'; + open my $exe_fh, '>', $exec_file or die "Could not write file '$exec_file': $!\n"; + close $exe_fh; + ok $obj->exists_exe($exec_file), 'executable file'; + unlink $exec_file or die "Could not delete file '$exec_file': $!\n"; + + # A not executable file + ok (! $obj->exists_exe($out_file), 'non-executable file'); + unlink $out_file or die "Could not delete file '$out_file': $!\n"; +} +else { + # An executable file + chmod 0777, $out_file or die "Could not change permission of file '$out_file': $!\n"; + ok $obj->exists_exe($out_file), 'executable file'; + + # A not executable file + chmod 0444, $out_file or die "Could not change permission of file '$out_file': $!\n"; + ok (! $obj->exists_exe($out_file), 'non-executable file'); + unlink $out_file or die "Could not delete file '$out_file': $!\n"; +} + +# An executable dir +my $out_dir = 'test_dir'; +mkdir $out_dir or die "Could not write dir '$out_dir': $!\n"; +chmod 0777, $out_dir or die "Could not change permission of dir '$out_dir': $!\n"; +ok (! $obj->exists_exe($out_dir), 'executable dir'); +rmdir $out_dir or die "Could not delete dir '$out_dir': $!\n"; + + +############################################# +# tests for handle read and write abilities +############################################# + +# Test catfile + +ok my $in_file = Bio::Root::IO->catfile(qw(t data test.waba)); +is $in_file, test_input_file('test.waba'); + +ok my $in_file_2 = Bio::Root::IO->catfile(qw(t data test.txt)); + +$out_file = test_output_file(); + + +# Test with files + +ok my $rio = Bio::Root::IO->new( -input => $in_file ), 'Read from file'; +is $rio->file, $in_file; +is_deeply [$rio->cleanfile], [undef, $in_file]; +is $rio->mode, 'r'; +ok $rio->close; + +ok $rio = Bio::Root::IO->new( -file => '<'.$in_file ); +is $rio->file, '<'.$in_file; +is_deeply [$rio->cleanfile], ['<', $in_file]; +1 while $rio->_readline; # read entire file content +is $rio->mode, 'r'; +ok $rio->close; + +ok my $wio = Bio::Root::IO->new( -file => ">$out_file" ), 'Write to file'; +is $wio->file, ">$out_file"; +is_deeply [$wio->cleanfile], ['>', $out_file]; +is $wio->mode, 'w'; +ok $wio->close; + +ok $rio = Bio::Root::IO->new( -file => "+>$out_file" ), 'Read+write to file'; +is $rio->file, "+>$out_file"; +is_deeply [$rio->cleanfile], ['+>', $out_file]; +is $rio->mode, 'rw'; +ok $rio->close; + + +# Test with handles + +my $in_fh; +open $in_fh , '<', $in_file or die "Could not read file '$in_file': $!\n", 'Read from GLOB handle'; +ok $rio = Bio::Root::IO->new( -fh => $in_fh ); +is $rio->_fh, $in_fh; +is $rio->mode, 'r'; +close $in_fh; + +open $out_fh, '>', $out_file or die "Could not write file '$out_file': $!\n", 'Write to GLOB handle'; +ok $wio = Bio::Root::IO->new( -fh => $out_fh ); +is $wio->_fh, $out_fh; +is $wio->mode, 'w'; +close $out_fh; + +SKIP: { + eval { require File::Temp; } + or skip 'could not create File::Temp object, maybe your File::Temp is 10 years old', 4; + + $out_fh = File::Temp->new; + ok $wio = Bio::Root::IO->new( -fh => $out_fh ), 'Read from File::Temp handle'; + isa_ok $wio, 'Bio::Root::IO'; + is $wio->mode, 'rw', 'is a write handle'; + warnings_like sub { $wio->close }, '', 'no warnings in ->close()'; + ok $wio->close; +} + + +# Exclusive arguments +open $in_fh , '<', $in_file or die "Could not read file '$in_file': $!\n", 'Read from GLOB handle'; +throws_ok {$rio = Bio::Root::IO->new( -input => $in_file, -fh => $in_fh )} qr/Providing both a file and a filehandle for reading/, 'Exclusive arguments'; +throws_ok {$rio = Bio::Root::IO->new( -input => $in_file, -file => $in_file_2 )} qr/Input file given twice/; +throws_ok {$rio = Bio::Root::IO->new( -input => $in_file, -string => 'abcedf' )} qr/File or filehandle provided with -string/; +throws_ok {$rio = Bio::Root::IO->new( -fh => $in_fh , -file => $in_file )} qr/Providing both a file and a filehandle for reading/; +throws_ok {$rio = Bio::Root::IO->new( -fh => $in_fh , -string => 'abcedf' )} qr/File or filehandle provided with -string/; +throws_ok {$rio = Bio::Root::IO->new( -file => $in_file, -string => 'abcedf' )} qr/File or filehandle provided with -string/; +close $in_fh; + +lives_ok {$rio = Bio::Root::IO->new( -input => $in_file, -file => $in_file )} 'Same file'; + + +############################################## +# tests _pushback for multi-line buffering +############################################## + +ok $rio = Bio::Root::IO->new( -file => $in_file ), 'Pushback'; + +ok my $line1 = $rio->_readline; +ok my $line2 = $rio->_readline; + +ok $rio->_pushback($line2); +ok $rio->_pushback($line1); + +ok my $line3 = $rio->_readline; +ok my $line4 = $rio->_readline; +ok my $line5 = $rio->_readline; + +is $line1, $line3; +is $line2, $line4; +isnt $line5, $line4; + +ok $rio->close; + + +############################################## +# test _print and _insert +############################################## + +ok my $fio = Bio::Root::IO->new( -file => ">$out_file" ); +ok $fio->_print("line 1\n"), '_print'; +ok $fio->_print("line 2\n"); +ok $fio->_insert("insertion at line 2\n",2), '_insert at middle of file'; +ok $fio->_print("line 3\n"); +ok $fio->_print("line 4\n"); +ok $fio->close; + +open my $checkio, '<', $out_file or die "Could not read file '$out_file': $!\n"; +my @content = <$checkio>; +close $checkio; +is_deeply \@content, ["line 1\n","insertion at line 2\n","line 2\n","line 3\n","line 4\n"]; + +ok $fio = Bio::Root::IO->new(-file=>">$out_file"); +ok $fio->_insert("insertion at line 1\n",1), '_insert in empty file'; +ok $fio->close; + +open $checkio, '<', $out_file or die "Could not read file '$out_file': $!\n"; +@content = <$checkio>; +close $checkio; +is_deeply \@content, ["insertion at line 1\n"]; + + +############################################## +# test Win vs UNIX line ending +############################################## + +{ + ok my $unix_rio = Bio::Root::IO->new(-file => test_input_file('U71225.gb.unix')); + ok my $win_rio = Bio::Root::IO->new(-file => test_input_file('U71225.gb.win' )); + ok my $mac_rio = Bio::Root::IO->new(-file => test_input_file('U71225.gb.mac' )); + + my $expected = "LOCUS U71225 1164 bp DNA linear VRT 27-NOV-2001\n"; + is $unix_rio->_readline, $expected; + is $win_rio->_readline , $expected; + like $mac_rio->_readline, qr#^LOCUS.*//\n$#ms; + # line spans entire file because lines end with "\r" but $/ is "\n" + + $expected = "DEFINITION Desmognathus quadramaculatus 12S ribosomal RNA gene, partial\n"; + is $unix_rio->_readline, $expected; + is $win_rio->_readline , $expected; + is $mac_rio->_readline , undef; + + $expected = " sequence; tRNA-Val gene, complete sequence; and 16S ribosomal RNA\n"; + is $unix_rio->_readline, $expected; + is $win_rio->_readline , $expected; + is $mac_rio->_readline , undef; + + $expected = " gene, partial sequence, mitochondrial genes for mitochondrial RNAs.\n"; + is $unix_rio->_readline, $expected; + is $win_rio->_readline , $expected; + is $mac_rio->_readline , undef; + + $expected = "ACCESSION U71225\n"; + is $unix_rio->_readline, $expected; + is $win_rio->_readline , $expected; + is $mac_rio->_readline , undef; + + # In Windows the "-raw" parameter has no effect, because Perl already discards + # the '\r' from the line when reading in text mode from the filehandle + # ($line = <$fh>), and put it back automatically when printing + if ($^O =~ m/mswin/i) { + is $win_rio->_readline( -raw => 1) , "VERSION U71225.1 GI:2804359\n"; + } + else { + is $win_rio->_readline( -raw => 1) , "VERSION U71225.1 GI:2804359\r\n"; + } + is $win_rio->_readline( -raw => 0) , "KEYWORDS .\n"; +} + + +############################################## +# test Win vs UNIX line ending using PerlIO::eol +############################################## + +SKIP: { + test_skip(-tests => 20, -requires_module => 'PerlIO::eol'); + + local $Bio::Root::IO::HAS_EOL = 1; + ok my $unix_rio = Bio::Root::IO->new(-file => test_input_file('U71225.gb.unix')); + ok my $win_rio = Bio::Root::IO->new(-file => test_input_file('U71225.gb.win' )); + ok my $mac_rio = Bio::Root::IO->new(-file => test_input_file('U71225.gb.mac' )); + + my $expected = "LOCUS U71225 1164 bp DNA linear VRT 27-NOV-2001\n"; + is $unix_rio->_readline, $expected; + is $win_rio->_readline , $expected; + is $mac_rio->_readline , $expected; + + $expected = "DEFINITION Desmognathus quadramaculatus 12S ribosomal RNA gene, partial\n"; + is $unix_rio->_readline, $expected; + is $win_rio->_readline , $expected; + is $mac_rio->_readline , $expected; + + $expected = " sequence; tRNA-Val gene, complete sequence; and 16S ribosomal RNA\n"; + is $unix_rio->_readline, $expected; + is $win_rio->_readline , $expected; + is $mac_rio->_readline , $expected; + + $expected = " gene, partial sequence, mitochondrial genes for mitochondrial RNAs.\n"; + is $unix_rio->_readline, $expected; + is $win_rio->_readline , $expected; + is $mac_rio->_readline , $expected; + + $expected = "ACCESSION U71225\n"; + is $unix_rio->_readline, $expected; + is $win_rio->_readline , $expected; + is $mac_rio->_readline , $expected; + + # $HAS_EOL ignores -raw + is $win_rio->_readline( -raw => 1) , "VERSION U71225.1 GI:2804359\n"; + is $win_rio->_readline( -raw => 0) , "KEYWORDS .\n"; +} + + +############################################## +# test Path::Class support +############################################## + +SKIP: { + test_skip(-tests => 2, -requires_module => 'Path::Class'); + my $f = sub { Bio::Root::IO->new( -file => Path::Class::file(test_input_file('U71225.gb.unix') ) ) }; + lives_ok(sub { $f->() } , 'Bio::Root::IO->new can handle a Path::Class object'); + isa_ok($f->(), 'Bio::Root::IO'); +} + + +############################################## +# test -string +############################################## + +my $teststring = "Foo\nBar\nBaz"; +ok $rio = Bio::Root::IO->new(-string => $teststring), 'Read string'; + +is $rio->mode, 'r'; + +ok $line1 = $rio->_readline; +is $line1, "Foo\n"; + +ok $line2 = $rio->_readline; +is $line2, "Bar\n"; +ok $rio->_pushback($line2); + +ok $line3 = $rio->_readline; +is $line3, "Bar\n"; +ok $line3 = $rio->_readline; +is $line3, 'Baz'; + + +############################################## +# test tempfile() +############################################## +{ +ok my $obj = Bio::Root::IO->new(-verbose => 0); + +isa_ok $obj, 'Bio::Root::IO'; + +my $TEST_STRING = "Bioperl rocks!\n"; + +my ($tfh,$tfile); + +eval { + ($tfh, $tfile) = $obj->tempfile(); + isa_ok $tfh, 'GLOB'; + print $tfh $TEST_STRING; + close $tfh; + open my $IN, '<', $tfile or die "Could not read file '$tfile': $!\n"; + my $val = join '', <$IN>; + is $val, $TEST_STRING; + close $IN; + ok -e $tfile; + undef $obj; +}; +undef $obj; +if ( $@ ) { + ok 0; +} else { + ok ! -e $tfile, 'auto UNLINK => 1'; +} + +$obj = Bio::Root::IO->new(); + +eval { + my $tdir = $obj->tempdir(CLEANUP=>1); + ok -d $tdir; + ($tfh, $tfile) = $obj->tempfile(dir => $tdir); + close $tfh; + ok -e $tfile; + undef $obj; # see Bio::Root::IO::_io_cleanup +}; + +if ( $@ ) { + ok 0; +} else { + ok ! -e $tfile, 'tempfile deleted'; +} + +eval { + $obj = Bio::Root::IO->new(-verbose => 0); + ($tfh, $tfile) = $obj->tempfile(UNLINK => 0); + isa_ok $tfh, 'GLOB'; + close $tfh; + ok -e $tfile; + undef $obj; # see Bio::Root::IO::_io_cleanup +}; + +if ( $@ ) { + ok 0; +} else { + ok -e $tfile, 'UNLINK => 0'; +} + +ok unlink( $tfile) == 1 ; + + +ok $obj = Bio::Root::IO->new; + +# check suffix is applied +my ($fh1, $fn1) = $obj->tempfile(SUFFIX => '.bioperl'); +isa_ok $fh1, 'GLOB'; +like $fn1, qr/\.bioperl$/, 'tempfile suffix'; +ok close $fh1; + +# check single return value mode of File::Temp +my $fh2 = $obj->tempfile; +isa_ok $fh2, 'GLOB'; +ok $fh2, 'tempfile() in scalar context'; +ok close $fh2; +} diff --git a/t/Root/RootI.t b/t/Root/RootI.t new file mode 100644 index 000000000..48d6e8aed --- /dev/null +++ b/t/Root/RootI.t @@ -0,0 +1,320 @@ +# -*-Perl-*- Test Harness script for Bioperl +# $Id$ + +use strict; + +BEGIN { + use lib '.'; + use Bio::Root::Test; + + test_begin(-tests => 62); + + use_ok 'Bio::Root::Root'; +} + +ok my $obj = Bio::Root::Root->new(); +isa_ok $obj, 'Bio::Root::RootI'; + +throws_ok { $obj->throw('Testing throw') } qr/Testing throw/;# 'throw failed'; + +# test throw_not_implemented() +throws_ok { $obj->throw_not_implemented() } qr/EXCEPTION: Bio::Root::NotImplemented/; + +{ + package Bio::FooI; + use base qw(Bio::Root::RootI); + sub new { + my $class = shift; + my $self = {}; + bless $self, ref($class) || $class; + return $self; + }; +} +$obj = Bio::FooI->new(); +throws_ok { $obj->throw_not_implemented() } qr/EXCEPTION /; +$obj = Bio::Root::Root->new(); + +# doesn't work in perl 5.00405 +#my $val; +#eval { +# my ($tfh,$tfile) = $obj->tempfile(); +# local * STDERR = $tfh; +# $obj->warn('Testing warn'); +# close $tfh; +# open(IN, $tfile) or die("cannot open $tfile"); +# $val = join("", ) ; +# close IN; +# unlink $tfile; +#}; +#ok $val =~ /Testing warn/; +#'verbose(0) warn did not work properly' . $val; + +$obj->verbose(-1); +throws_ok { $obj->throw('Testing throw') } qr/Testing throw/;# 'verbose(-1) throw did not work properly' . $@; + +lives_ok { $obj->warn('Testing warn') }; + +$obj->verbose(1); +throws_ok { $obj->throw('Testing throw') } qr/Testing throw/;# 'verbose(1) throw did not work properly' . $@; + +# doesn't work in perl 5.00405 +#undef $val; +#eval { +# my ($tfh,$tfile) = $obj->tempfile(); +# local * STDERR = $tfh; +# $obj->warn('Testing warn'); +# close $tfh; +# open(IN, $tfile) or die("cannot open $tfile"); +# $val = join("", ); +# close IN; +# unlink $tfile; +#}; +#ok $val =~ /Testing warn/;# 'verbose(1) warn did not work properly' . $val; + +my @stack = $obj->stack_trace(); +is scalar @stack, 2; + +my $verbobj = Bio::Root::Root->new(-verbose=>1,-strict=>1); +is $verbobj->verbose(), 1; + +$Bio::Root::Root::DEBUG = 1; +my $seq = Bio::Root::Root->new(); +is $seq->verbose, 1; + +# test for bug #1343 +my @vals = Bio::Root::RootI->_rearrange([qw(apples pears)], + -apples => 'up the', + -pears => 'stairs'); +is shift @vals, 'up the'; +is shift @vals, 'stairs'; + +# test deprecated() + +# class method +{ + local $Bio::Root::Root::VERSION = 8.9; + warning_like{ Bio::Root::Root->deprecated('Test1') } qr/Test1/, 'simple'; + warning_like{ Bio::Root::Root->deprecated(-message => 'Test2') } qr/Test2/; + warning_like{ Bio::Root::Root->deprecated('Test3', 999.999) } qr/Test3/, + 'warns for versions below current version'; + warning_like{ Bio::Root::Root->deprecated(-message => 'Test4', + -version => 999.999) } qr/Test4/, + 'warns for versions below current version'; + throws_ok{ Bio::Root::Root->deprecated('Test5', 0.001) } qr/Test5/, + 'throws for versions above current version'; + throws_ok{ Bio::Root::Root->deprecated(-message => 'Test6', + -version => 0.001) } qr/Test6/, + 'throws for versions above current version'; + + throws_ok{ Bio::Root::Root->deprecated(-message => 'Test6', + -version => $Bio::Root::Root::VERSION) } qr/Test6/, + 'throws for versions equal to current version'; + + # object method + my $root = Bio::Root::Root->new(); + warning_like{ $root->deprecated('Test1') } qr/Test1/, 'simple'; + warning_like{ $root->deprecated(-message => 'Test2') } qr/Test2/, 'simple'; + warning_like{ $root->deprecated('Test3', 999.999) } qr/Test3/, + 'warns for versions below current version'; + warning_like{ $root->deprecated(-message => 'Test4', + -version => 999.999) } qr/Test4/, + 'warns for versions below current version'; + throws_ok{ $root->deprecated('Test5', 0.001) } qr/Test5/, + 'throws for versions above current version'; + throws_ok{ $root->deprecated(-message => 'Test6', + -version => 0.001) } qr/Test6/, + 'throws for versions above current version'; + +} + +# tests for _set_from_args() +# Let's not pollute Bio::Root::Root namespace if possible +# Create temp classes instead which inherit Bio::Root::Root, then test + +{ + + package Bio::Foo1; + use base qw(Bio::Root::Root); + our $VERSION = '2.00'; + sub new { + my $class = shift; + my $self = {}; + bless $self, ref($class) || $class; + + $self->_set_from_args(\@_); + + return $self; + }; +} + +$obj = Bio::Foo1->new(-verbose => 1, t1 => 1, '--Test-2' => 2); +#ok ! $obj->can('t1'), 'arg not callable'; + +{ + + package Bio::Foo2; + use base qw(Bio::Root::Root); + sub new { + my $class = shift; + my $self = {}; + bless $self, ref($class) || $class; + + $self->_set_from_args(\@_, -create => 1); + + return $self; + }; + +} + +$obj = Bio::Foo2->new(-verbose => 1, t3 => 1, '--Test-4' => 2); +ok $obj->can('t3'), 'arg callable since method was created'; +ok $obj->can('test_4'), 'mal-formed arg callable since method was created with good name'; +for my $m (qw(t3 test_4)) { + can_ok('Bio::Foo2',$m); + ok ! Bio::Root::Root->can($m), "Methods don't pollute original Bio::Root::Root namespace"; +} + +{ + package Bio::Foo3; + use base qw(Bio::Root::Root); + sub new { + my $class = shift; + my $self = {}; + bless $self, ref($class) || $class; + + $self->_set_from_args(\@_, -methods => ['verbose', 't5'], -create => 1); + + return $self; + }; +} + +$obj = Bio::Foo3->new(-verbose => 1, t5 => 1, '--Test-6' => 2); +can_ok $obj, 't5'; +ok ! $obj->can('test_6'), 'arg not in method list not created'; + +can_ok ('Bio::Foo3','t5'); +ok ! UNIVERSAL::can('Bio::Root::Root','t5'), "Methods don't pollute original Bio::Root::Root namespace"; + +{ + package Bio::Foo4; + use base qw(Bio::Root::Root); + sub new { + my $class = shift; + my $self = {}; + bless $self, ref($class) || $class; + + my %args = @_; + + $self->_set_from_args(\%args, -methods => {(verbose => 'v', + test7 => 't7', + test_8 => 't8')}, + -create => 1); + + return $self; + }; +} + +# with synonyms + +$obj = Bio::Foo4->new(-verbose => 1, t7 => 1, '--Test-8' => 2); +is $obj->verbose, 1, 'verbose was set correctly'; +is $obj->t7, 1, 'synonym was set correctly'; +is $obj->test7, 1, 'real method of synonym was set correctly'; +is $obj->test_8, 2, 'mal-formed arg correctly resolved to created method'; +is $obj->t8, 2, 'synonym of set method was set correctly'; + +for my $m (qw(t7 test7 test_8 t8)) { + can_ok 'Bio::Foo4', $m; + ok ! UNIVERSAL::can('Bio::Root::Root','t7'), "Methods don't pollute original Bio::Root::Root namespace"; +} + +# test basic Root::clone() + +my $clone = $obj->clone; + +is $clone->t7, $obj->t7, 'clone'; +is $clone->test7, $obj->test7, 'clone'; +is $clone->test_8, $obj->test_8, 'clone'; +$clone->test_8('xyz'); +isnt $clone->test_8, $obj->test_8, 'clone changed, original didn\'t'; + +# test Root::clone() with parameter passing, only works for methods +# (introspection via can()) + +my $clone2 = $obj->clone(-t7 => 'foo'); + +is $clone2->t7, 'foo', 'parameters passed to clone() modify object'; +is $obj->t7, 1, 'original is not modified'; + + + +# test deprecations using start_version +{ + package Bio::Foo5; + use base qw(Bio::Root::Root); + + our $v = '18.001'; + our $VERSION = $v; + + sub not_good { + my $self = shift; + $self->deprecated(-message => 'This is not good', + -warn_version => $v, + -throw_version => $v + 0.001); + } + + sub not_good2 { + my $self = shift; + # note, due to _rearrange, ordering is throw version, then warn version + $self->deprecated('This is not good',$v + 0.001,$v); + } + + sub really_not_good { + my $self = shift; + $self->deprecated(-message => 'This is really not good', + -warn_version => $v - 0.001, + -throw_version => $v,); + } + + # version is the same as throw_version (and vice versa) + sub still_very_bad { + my $self = shift; + $self->deprecated(-message => 'This is still very bad', + -warn_version => $v - 0.001, + -version => $v); + } + + sub okay_for_now { + my $self = shift; + $self->deprecated(-message => 'This is okay for now', + -warn_version => $v + 0.001, + -throw_version => $v + 0.002); + } + + sub plain_incorrect { + my $self = shift; + $self->deprecated(-message => 'This is not going to work', + -warn_version => '1.2.3.4', + -throw_version => 'a.b.c.d'); + } +} + +my $foo = Bio::Foo5->new(); + +throws_ok { $foo->plain_incorrect } qr/Version must be numerical/, + 'must use proper versioning scheme'; + +warning_like{ $foo->not_good } qr/This is not good/, + 'warns for versions >= current version'; +# this tests the three-arg (non-named) form just to make sure it works, even +# though we probably won't support it +warning_like{ $foo->not_good2 } qr/This is not good/, + 'warns for versions >= current version'; + +throws_ok { $foo->really_not_good } qr/This is really not good/, + 'throws for versions >= current version'; +throws_ok { $foo->still_very_bad } qr/This is still very bad/, + 'throws for versions >= current version'; +lives_ok { $foo->okay_for_now } 'No warnings/exceptions below current version'; + + diff --git a/t/Root/RootIO.t b/t/Root/RootIO.t new file mode 100644 index 000000000..9779c6a31 --- /dev/null +++ b/t/Root/RootIO.t @@ -0,0 +1,19 @@ +############################################## +# tests http retrieval +############################################## + +use strict; +use warnings; +use Test::More; +use Test::Exception; + +use Bio::Root::IO; + +my $TESTURL = 'http://www.google.com/index.html'; + +my $rio = Bio::Root::IO->new(); + +ok $rio = Bio::Root::IO->new(-url=>$TESTURL), 'default -url method'; +lives_ok {$rio = Bio::Root::IO->new(-url=>$TESTURL)}; + +done_testing; diff --git a/t/Root/Storable.t b/t/Root/Storable.t new file mode 100644 index 000000000..faf5f3112 --- /dev/null +++ b/t/Root/Storable.t @@ -0,0 +1,79 @@ +# -*-Perl-*- Test Harness script for Bioperl +# $Id$ + +use strict; + +BEGIN { + use lib '.'; + use Bio::Root::Test; + + test_begin(-tests => 35); + + use_ok('Bio::Root::Storable'); +} + +foreach my $mode( "BINARY", "ASCII" ){ + if( $mode eq "ASCII" ){ + no warnings; + $Bio::Root::Storable::BINARY = 0; + } + + #------------------------------ + # Test the easy bits that don't need file IO + my $obj = Bio::Root::Storable->new(); + ok defined($obj) && $obj->isa('Bio::Root::Storable'); + + eval { $obj->throw('Testing throw') }; + ok $@ =~ /Testing throw/; # 'throw failed'; + + $obj->{_test} = "_TEST"; # Provide test attributes + $obj->{__test} = "__TEST"; # + + my $state = $obj->serialise; + ok length($state) > 0; + + my $clone = $obj->clone; + ok defined($clone) and $clone->isa('Bio::Root::Storable'); + ok $clone->{_test} eq "_TEST" && $clone->{__test} eq "__TEST"; + + #------------------------------ + # Test standard file IO + my $file = $obj->store; + ok $file && -f $obj->statefile; + + my $retrieved; + eval { $retrieved = Bio::Root::Storable->retrieve( $file ) }; + ok defined($retrieved) && $retrieved->isa('Bio::Root::Storable'); + ok $retrieved->{_test} eq "_TEST" && ! exists $retrieved->{__test}; + + my $skel = $obj->new_retrievable; + ok defined($skel) && $skel->isa('Bio::Root::Storable'); + ok ! exists $skel->{_test} && ! exists $skel->{__test}; + ok $skel->retrievable; + + eval { $skel->retrieve }; + ok ! $skel->retrievable; + ok $skel->{_test} eq "_TEST" && ! exists $skel->{__test}; + + my $obj2 = Bio::Root::Storable->new(); + $obj2->template('TEST_XXXXXX'); + $obj2->suffix('.state'); + my $file2 = $obj2->store; + ok $file2 =~ /TEST_\w{6}?\.state$/ and -f $file2; + + #------------------------------ + # Test recursive file IO + $obj->{_test_lazy} = $obj2; + $obj->store; + my $retrieved2; + eval { $retrieved2 = Bio::Root::Storable->retrieve( $obj->token ) }; + ok $retrieved2->{_test_lazy} && $retrieved2->{_test_lazy}->retrievable; + + #------------------------------ + # Clean up + # Should only be 2 object files; all others were clones in one way or another + $obj->remove; + ok ! -f $obj->statefile; + $obj2->remove; + ok ! -f $obj2->statefile; +} diff --git a/t/Root/Utilities.t b/t/Root/Utilities.t new file mode 100644 index 000000000..d59733b94 --- /dev/null +++ b/t/Root/Utilities.t @@ -0,0 +1,119 @@ +# -*-Perl-*- Test Harness script for Bioperl +# $Id$ + + +use strict; + +BEGIN { + use lib '.'; + use Bio::Root::Test; + + test_begin(-tests => 56); + + use_ok('Bio::Root::Utilities'); +} + +# Object creation +my $u = Bio::Root::Utilities->new(); +isa_ok($u, 'Bio::Root::Utilities') ; + +# month2num() and num2month() + +my @month = qw(XXX Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); +for my $i (1 .. 12) { + is $u->month2num($month[$i]), $i; + is $u->num2month($i), $month[$i]; +} + +# untaint() + +is $u->untaint(''), ''; +is $u->untaint('nice string'), 'nice string'; +is $u->untaint('bad *?&^$! string'), 'bad '; +is $u->untaint( q{100% relaxed&;''\"|*?!~<>^()[]{}$}, 1 ), '100% relaxed'; + +# mean_stdev() + +my($mu,$sd); + +($mu,$sd) = $u->mean_stdev(); +is $mu, undef; +is $sd, undef; + +($mu,$sd) = $u->mean_stdev(42); +is $mu, 42; +is $sd, undef; + +($mu,$sd) = $u->mean_stdev(-1,0,1); +is $mu, 0; +is $sd, 1; + +# file_date(), file_flavor(), date_format() + +my $file = test_input_file('test.txt'); +my $file2 = test_input_file('test 2.txt'); +my $fdate = $u->file_date($file); +like $fdate , qr/\d{4}-\d{2}-\d{2}/, 'file_date()'; +ok $u->file_flavor($file), 'unix (\n or 012 or ^J)'; + +my $date = $u->date_format(); +like $date, qr/\d{4}-\d{2}-\d{2}/, 'date format'; +my $date2 = $u->date_format('yyyy-mmm-dd', $date); +like $date2 , qr/\d{4}-[a-z]{3}-\d{2}/i, 'date format'; +my $date3 = $u->date_format('mdhms'); +like $date3 , qr/[a-z]{3}\d{1,2} \d{1,2}:\d{1,2}:\d{1,2}/, 'date format'; +my $date4 = $u->date_format('d-m-y', '11/22/60'); +like $date4 , qr/\d{1,2}-[a-z]{3}-\d{4}/i, 'date format'; +my $date5 = $u->date_format('mdy', '1/5/01'); +like $date5 , qr/[a-z]{3} \d{1,2}, \d{4}/i, 'date format'; + +# External executable-related functions. + +my $exe = $u->find_exe('some-weird-thing-no-one-will-have'); +ok ! defined $exe ; + +# compress() and uncompress() using gzip. +SKIP: { + my $gzip = $u->find_exe('gzip'); + skip "gzip not found, skipping gzip tests", 12 unless $gzip; + ok -x $gzip; + + # test compression/decompression of a simple file + my $zfile = $u->compress($file); + + # In Windows, the folder separator '\' may brake + # the following qr{}, so change it to '/' + $zfile =~ s'\\'/'g; + $file =~ s'\\'/'g; + + like $zfile, qr/$file.gz|tmp.bioperl.gz/; + ok -s $zfile; + if ($zfile =~ /tmp.bioperl.gz/) { + ok -e $file; + } + else { + ok ! -e $file; + } + my $unzfile = $u->uncompress($zfile); + ok ! -e $zfile; + ok -e $file; + + # test compression/decompression of a filename with spaces keeping the original intact + my $zfile2 = $file2.'.gz'; + my $return = $u->compress(-file => $file2, -outfile => $zfile2, -tmp => 1); + is $return, $zfile2; + ok -e $zfile2; + ok -e $file2; + unlink $file2 or die "Problem deleting $file2: $!\n"; + $return = $u->uncompress(-file => $zfile2, -outfile => $file2, -tmp => 1); + is $return, $file2; + ok -e $file2; + ok -e $zfile2; + unlink $zfile2 or die "Problem deleting $zfile2: $!\n"; +} + +# send_mail() + +# $u->send_mail(-to=>'sac@bioperl.org', # <--- your address here! +# -subj=>'Root-Utilities.t', +# -msg=>'Hey, your send_mail() method works!'); diff --git a/t/Tools/Analysis/Protein/Mitoprot.t b/t/Tools/Analysis/Protein/Mitoprot.t index a900cea30..0b6879f88 100644 --- a/t/Tools/Analysis/Protein/Mitoprot.t +++ b/t/Tools/Analysis/Protein/Mitoprot.t @@ -27,7 +27,9 @@ my $seq = Bio::PrimarySeq->new(-seq => 'MSADQRWRQDSQDSFGDSFDGDSFFGSDFDGDS'. ok $tool = Bio::Tools::Analysis::Protein::Mitoprot->new( -seq=>$seq); SKIP: { ok $tool->run(); - skip('Server terminated with an error, skipping tests', 4) if $tool->status eq 'TERMINATED_BY_ERROR'; + skip( 'Server terminated with an error, skipping tests', 4 ) + if ( $tool->status eq 'TERMINATED_BY_ERROR' + or $tool->result =~ /certificate verify failed/ ); ok my $raw = $tool->result(''); ok my $parsed = $tool->result('parsed'); is ($parsed->{'charge'}, -13); diff --git a/t/Tools/Analysis/Protein/NetPhos.t b/t/Tools/Analysis/Protein/NetPhos.t index ab38d1aa5..1371bf3b8 100644 --- a/t/Tools/Analysis/Protein/NetPhos.t +++ b/t/Tools/Analysis/Protein/NetPhos.t @@ -1,5 +1,4 @@ # -*-Perl-*- Test Harness script for Bioperl -# $Id$ use strict; diff --git a/t/data/U71225.gb.mac b/t/data/U71225.gb.mac new file mode 100644 index 000000000..04d9062c8 --- /dev/null +++ b/t/data/U71225.gb.mac @@ -0,0 +1 @@ +LOCUS U71225 1164 bp DNA linear VRT 27-NOV-2001 DEFINITION Desmognathus quadramaculatus 12S ribosomal RNA gene, partial sequence; tRNA-Val gene, complete sequence; and 16S ribosomal RNA gene, partial sequence, mitochondrial genes for mitochondrial RNAs. ACCESSION U71225 VERSION U71225.1 GI:2804359 KEYWORDS . SOURCE mitochondrion Desmognathus quadramaculatus (black-bellied salamander) ORGANISM Desmognathus quadramaculatus Eukaryota; Metazoa; Chordata; Craniata; Vertebrata; Euteleostomi; Amphibia; Batrachia; Caudata; Salamandroidea; Plethodontidae; Desmognathinae; Desmognathus. REFERENCE 1 (bases 1 to 1164) AUTHORS Titus,T.A. and Larson,A. TITLE Molecular phylogenetics of Desmognathine salamanders (Caudata: Plethodontidae): A reevaluation of evolution in ecology, life history, and morphology JOURNAL Syst. Biol. 45, 451-472 (1996) REFERENCE 2 (bases 1 to 1164) AUTHORS Titus,T.A. TITLE Direct Submission JOURNAL Submitted (19-SEP-1996) Biology, University of Oregon, Eugene, OR 97403, USA FEATURES Location/Qualifiers source 1..1164 /organism="Desmognathus quadramaculatus" /organelle="mitochondrion" /mol_type="genomic DNA" /db_xref="taxon:52105" rRNA <1..638 /product="12S ribosomal RNA" tRNA 639..706 /product="tRNA-Val" rRNA 707..>1164 /product="16S ribosomal RNA" ORIGIN 1 ggcccaaagg gtagttttag gtgaaataaa atagaattta aaatttatct agtagttata 61 tataaacata aaatgtaaaa tcaaaaacga aagtcatact atataacctt gaatctacta 121 cagctgagaa acaaactagg attagatacc ctactatgct caactttaaa atggaccttc 181 ccgccagagc actacgagcc acagcttaaa actcaaagga cttggcggtg ctctacaccc 241 acctagagga gcctgttcta taatcgacac tccccgataa acctcaccac ctcttgctaa 301 tacagcctat ataccaccgc cctcagttca cccttcaaaa gaataatagt gaacaaaata 361 atttaaaata aaaaagtcag gtcaaggtgc agcaaatgaa gtggaaagaa atgggctaca 421 ttttttatag taaaaaatac ggaatattct atgaaataaa atataaagga ggatttagaa 481 gtaaaaagaa aaaagagtgt tctttttaaa ttggcaatag agcacgcaca caccgcccgt 541 caccctcttc aaaattaaat aaactaaata aatatataaa tttataagaa aaggtaagtc 601 gtaacatggt aagtctaccg gaaggtggcc ttggatatcg aagtatagct taaataaagc 661 attttgctta caccaaaaaa atatttgtta acccaaatta ccttaaattt taaatctatg 721 ctaaatataa aatactactt cctaatacac aaaacattat tatatgatag tacgggcgac 781 agaaaactta ttagcgcaat agaaaaagta ctgtaaagga aagatgaaat aaaattgaaa 841 taaaataaaa atataaaaga gcaaagatta taacttttac ctttagcata atggtctagc 901 cagtctatat taacataaag aattttagtt atataccccg aaaccaggcg agctacccta 961 aaacagcaat atatgagcga actcttctct gtggcaaaag agtgagaaga atttttggta 1021 gaggcgaaaa accaaacgag cccggatata gctggttact tgagaatgaa ttttagttca 1081 attaaaagca taaatattat aaaaacataa cgcttttatt ataattaatt gaggtacagc 1141 ccaattaata aaggaaacaa ccta // \ No newline at end of file -- 2.11.4.GIT