Browse files

dev changes assoc w/WrapperMaker

svn path=/bioperl-dev/trunk/; revision=16807
  • Loading branch information...
1 parent 2a8c71b commit 23c5a8703ee1232554cdb4c1c6f2fc7bea3a5296 maj committed Feb 2, 2010
Showing with 1,898 additions and 0 deletions.
  1. +501 −0 Bio/Tools/Run/WrapperBase.pm
  2. +1,397 −0 Bio/Tools/Run/WrapperBase/CommandExts.pm
View
501 Bio/Tools/Run/WrapperBase.pm
@@ -0,0 +1,501 @@
+# $Id$
+#
+# BioPerl module for Bio::Tools::Run::WrapperBase
+#
+# Please direct questions and support issues to <bioperl-l@bioperl.org>
+#
+# Cared for by Jason Stajich <jason@bioperl.org>
+#
+# Copyright Jason Stajich
+#
+# You may distribute this module under the same terms as perl itself
+
+# POD documentation - main docs before the code
+
+=head1 NAME
+
+Bio::Tools::Run::WrapperBase - A Base object for wrappers around executables
+
+=head1 SYNOPSIS
+
+ # do not use this object directly, it provides the following methods
+ # for its subclasses
+
+ my $errstr = $obj->error_string();
+ my $exe = $obj->executable();
+ $obj->save_tempfiles($booleanflag)
+ my $outfile= $obj->outfile_name();
+ my $tempdir= $obj->tempdir(); # get a temporary dir for executing
+ my $io = $obj->io; # Bio::Root::IO object
+ my $cleanup= $obj->cleanup(); # remove tempfiles
+
+ $obj->run({-arg1 => $value});
+
+=head1 DESCRIPTION
+
+This is a basic module from which to build executable wrapper modules.
+It has some basic methods to help when implementing new modules.
+
+=head1 FEEDBACK
+
+=head2 Mailing Lists
+
+User feedback is an integral part of the evolution of this and other
+Bioperl modules. Send your comments and suggestions preferably to
+the Bioperl mailing list. Your participation is much appreciated.
+
+ bioperl-l@bioperl.org - General discussion
+ http://bioperl.org/wiki/Mailing_lists - About the mailing lists
+
+=head2 Support
+
+Please direct usage questions or support issues to the mailing list:
+
+I<bioperl-l@bioperl.org>
+
+rather than to the module maintainer directly. Many experienced and
+reponsive experts will be able look at the problem and quickly
+address it. Please include a thorough description of the problem
+with code and data examples if at all possible.
+
+=head2 Reporting Bugs
+
+Report bugs to the Bioperl bug tracking system to help us keep track of
+the bugs and their resolution. Bug reports can be submitted via the
+web:
+
+ http://bugzilla.open-bio.org/
+
+=head1 AUTHOR - Jason Stajich
+
+Email jason-at-bioperl.org
+
+=head1 CONTRIBUTORS
+
+Sendu Bala, bix@sendu.me.uk
+
+=head1 APPENDIX
+
+The rest of the documentation details each of the object methods.
+Internal methods are usually preceded with a _
+
+=cut
+
+
+# Let the code begin...
+
+
+package Bio::Tools::Run::WrapperBase;
+use strict;
+
+# Object preamble - inherits from Bio::Root::Root
+
+use base qw(Bio::Root::Root);
+
+use File::Spec;
+use File::Path qw(); # don't import anything
+
+use vars qw($TMPMODE);
+
+$TMPMODE = 0777;
+
+=head2 run
+
+ Title : run
+ Usage : $wrapper->run({ARGS HERE});
+ Function: Support generic running with args passed in
+ as a hashref
+ Returns : Depends on the implementation, status OR data
+ Args : hashref of named arguments
+
+
+=cut
+
+sub run {
+ my ($self,@args) = @_;
+ $self->throw_not_implemented();
+}
+
+
+=head2 error_string
+
+ Title : error_string
+ Usage : $obj->error_string($newval)
+ Function: Where the output from the last analysis run is stored.
+ Returns : value of error_string
+ Args : newvalue (optional)
+
+
+=cut
+
+sub error_string{
+ my ($self,$value) = @_;
+ if( defined $value) {
+ $self->{'_error_string'} = $value;
+ }
+ return $self->{'_error_string'} || '';
+}
+
+=head2 arguments
+
+ Title : arguments
+ Usage : $obj->arguments($newval)
+ Function: Commandline parameters
+ Returns : value of arguments
+ Args : newvalue (optional)
+
+
+=cut
+
+sub arguments {
+ my ($self,$value) = @_;
+ if(defined $value) {
+ $self->{'_arguments'} = $value;
+ }
+ return $self->{'_arguments'} || '';
+}
+
+
+=head2 no_param_checks
+
+ Title : no_param_checks
+ Usage : $obj->no_param_checks($newval)
+ Function: Boolean flag as to whether or not we should
+ trust the sanity checks for parameter values
+ Returns : value of no_param_checks
+ Args : newvalue (optional)
+
+
+=cut
+
+sub no_param_checks{
+ my ($self,$value) = @_;
+ if( defined $value || ! defined $self->{'no_param_checks'} ) {
+ $value = 0 unless defined $value;
+ $self->{'no_param_checks'} = $value;
+ }
+ return $self->{'no_param_checks'};
+}
+
+=head2 save_tempfiles
+
+ Title : save_tempfiles
+ Usage : $obj->save_tempfiles($newval)
+ Function: Get/set the choice of if tempfiles in the temp dir (see tempdir())
+ are kept or cleaned up. Default is '0', ie. delete temp files.
+ NB:ÊThis must be set to the desired value PRIOR to first creating
+ a temp dir with tempdir().
+ Returns : boolean
+ Args : none to get, boolean to set
+
+=cut
+
+sub save_tempfiles{
+ my $self = shift;
+ return $self->io->save_tempfiles(@_);
+}
+
+=head2 outfile_name
+
+ Title : outfile_name
+ Usage : my $outfile = $wrapper->outfile_name();
+ Function: Get/Set the name of the output file for this run
+ (if you wanted to do something special)
+ Returns : string
+ Args : [optional] string to set value to
+
+
+=cut
+
+sub outfile_name{
+ my ($self,$nm) = @_;
+ if( defined $nm || ! defined $self->{'_outfilename'} ) {
+ $nm = 'mlc' unless defined $nm;
+ $self->{'_outfilename'} = $nm;
+ }
+ return $self->{'_outfilename'};
+}
+
+
+=head2 tempdir
+
+ Title : tempdir
+ Usage : my $tmpdir = $self->tempdir();
+ Function: Retrieve a temporary directory name (which is created)
+ Returns : string which is the name of the temporary directory
+ Args : none
+ Note : directory created with mode $Bio::Tools::Run::WrapperBase::TMPMODE
+ which defaults to 0777
+
+=cut
+
+sub tempdir{
+ my ($self) = shift;
+
+ $self->{'_tmpdir'} = shift if @_;
+ unless( $self->{'_tmpdir'} ) {
+ $self->{'_tmpdir'} = $self->io->tempdir(CLEANUP => ! $self->save_tempfiles );
+ }
+ unless( -d $self->{'_tmpdir'} ) {
+ mkdir($self->{'_tmpdir'},$TMPMODE);
+ }
+ return $self->{'_tmpdir'};
+}
+
+=head2 cleanup
+
+ Title : cleanup
+ Usage : $wrapper->cleanup();
+ Function: Will cleanup the tempdir directory
+ Returns : none
+ Args : none
+
+
+=cut
+
+sub cleanup{
+ my ($self) = @_;
+ $self->io->_io_cleanup();
+ if( defined $self->{'_tmpdir'} && -d $self->{'_tmpdir'} ) {
+ my $verbose = ($self->verbose >= 1) ? 1 : 0;
+ File::Path::rmtree( $self->{'_tmpdir'}, $verbose);
+ }
+}
+
+=head2 io
+
+ Title : io
+ Usage : $obj->io($newval)
+ Function: Gets a Bio::Root::IO object
+ Returns : Bio::Root::IO object
+ Args : none
+
+
+=cut
+
+sub io{
+ my ($self) = @_;
+ unless( defined $self->{'io'} ) {
+ $self->{'io'} = Bio::Root::IO->new(-verbose => $self->verbose);
+ }
+ return $self->{'io'};
+}
+
+=head2 version
+
+ Title : version
+ Usage : $version = $wrapper->version()
+ Function: Returns the program version (if available)
+ Returns : string representing version of the program
+ Args : [Optional] value to (re)set version string
+
+
+=cut
+
+sub version{
+ my ($self,@args) = @_;
+ return;
+}
+
+=head2 executable
+
+ Title : executable
+ Usage : my $exe = $factory->executable();
+ Function: Finds the full path to the executable
+ Returns : string representing the full path to the exe
+ Args : [optional] name of executable to set path to
+ [optional] boolean flag whether or not warn when exe is not found
+
+=cut
+
+sub executable {
+ my ($self, $exe, $warn) = @_;
+
+ if (defined $exe) {
+ $self->{'_pathtoexe'} = $exe;
+ }
+
+ unless( defined $self->{'_pathtoexe'} ) {
+ my $prog_path = $self->program_path;
+
+ if ($prog_path) {
+ if (-f $prog_path && -x $prog_path) {
+ $self->{'_pathtoexe'} = $prog_path;
+ }
+ elsif ($self->program_dir) {
+ $self->warn("executable not found in $prog_path, trying system path...") if $warn;
+ }
+ }
+ unless ($self->{'_pathtoexe'}) {
+ my $exe;
+ if ( $exe = $self->io->exists_exe($self->program_name) ) {
+ $self->{'_pathtoexe'} = $exe;
+ }
+ else {
+ $self->warn("Cannot find executable for ".$self->program_name) if $warn;
+ $self->{'_pathtoexe'} = undef;
+ }
+ }
+ }
+ return $self->{'_pathtoexe'};
+}
+
+=head2 program_path
+
+ Title : program_path
+ Usage : my $path = $factory->program_path();
+ Function: Builds path for executable
+ Returns : string representing the full path to the exe
+ Args : none
+
+=cut
+
+sub program_path {
+ my ($self) = @_;
+ my @path;
+ push @path, $self->program_dir if $self->program_dir;
+ push @path, $self->program_name.($^O =~ /mswin/i ? '.exe' : '') if $self->program_name;
+ return File::Spec->catfile(@path);
+}
+
+=head2 program_dir
+
+ Title : program_dir
+ Usage : my $dir = $factory->program_dir();
+ Function: Abstract get method for dir of program. To be implemented
+ by wrapper.
+ Returns : string representing program directory
+ Args : none
+
+=cut
+
+sub program_dir {
+ my ($self) = @_;
+ $self->throw_not_implemented();
+}
+
+=head2 program_name
+
+ Title : program_name
+ Usage : my $name = $factory->program_name();
+ Function: Abstract get method for name of program. To be implemented
+ by wrapper.
+ Returns : string representing program name
+ Args : none
+
+=cut
+
+sub program_name {
+ my ($self) = @_;
+ $self->throw_not_implemented();
+}
+
+=head2 quiet
+
+ Title : quiet
+ Usage : $factory->quiet(1);
+ if ($factory->quiet()) { ... }
+ Function: Get/set the quiet state. Can be used by wrappers to control if
+ program output is printed to the console or not.
+ Returns : boolean
+ Args : none to get, boolean to set
+
+=cut
+
+sub quiet {
+ my $self = shift;
+ if (@_) { $self->{quiet} = shift }
+ return $self->{quiet} || 0;
+}
+
+=head2 _setparams()
+
+ Title : _setparams
+ Usage : $params = $self->_setparams(-params => [qw(window evalue_cutoff)])
+ Function: For internal use by wrapper modules to build parameter strings
+ suitable for sending to the program being wrapped. For each method
+ name supplied, calls the method and adds the method name (as modified
+ by optional things) along with its value (unless a switch) to the
+ parameter string
+ Example : $params = $self->_setparams(-params => [qw(window evalue_cutoff)],
+ -switches => [qw(simple large all)],
+ -double_dash => 1,
+ -underscore_to_dash => 1);
+ If window() and simple() had not been previously called, but
+ evalue_cutoff(0.5), large(1) and all(0) had been called, $params
+ would be ' --evalue-cutoff 0.5 --large'
+ Returns : parameter string
+ Args : -params => [] or {} # array ref of method names to call,
+ or hash ref where keys are method names and
+ values are how those names should be output
+ in the params string
+ -switches => [] or {}# as for -params, but no value is printed for
+ these methods
+ -join => string # define how parameters and their values are
+ joined, default ' '. (eg. could be '=' for
+ param=value)
+ -lc => boolean # lc() method names prior to output in string
+ -dash => boolean # prefix all method names with a single dash
+ -double_dash => bool # prefix all method names with a double dash
+ -mixed_dash => bool # prefix single-character method names with a
+ # single dash, and multi-character method names
+ # with a double-dash
+ -underscore_to_dash => boolean # convert all underscores in method
+ names to dashes
+
+=cut
+
+sub _setparams {
+ my ($self, @args) = @_;
+
+ my ($params, $switches, $join, $lc, $d, $dd, $md, $utd) =
+ $self->_rearrange([qw(PARAMS
+ SWITCHES
+ JOIN
+ LC
+ DASH
+ DOUBLE_DASH
+ MIXED_DASH
+ UNDERSCORE_TO_DASH)], @args);
+ $self->throw('at least one of -params or -switches is required') unless ($params || $switches);
+ $self->throw("-dash, -double_dash and -mixed_dash are mutually exclusive") if (defined($d) + defined($dd) + defined($md) > 1);
+ $join ||= ' ';
+
+ my %params = ref($params) eq 'HASH' ? %{$params} : map { $_ => $_ } @{$params};
+ my %switches = ref($switches) eq 'HASH' ? %{$switches} : map { $_ => $_ } @{$switches};
+
+ my $param_string = '';
+ for my $hash_ref (\%params, \%switches) {
+ while (my ($method, $method_out) = each %{$hash_ref}) {
+ my $value = $self->$method();
+ next unless (defined $value);
+ next if (exists $switches{$method} && ! $value);
+
+ $method_out = lc($method_out) if $lc;
+ my $method_length = length($method_out) if $md;
+ $method_out = '-'.$method_out if ($d || ($md && ($method_length == 1)));
+ $method_out = '--'.$method_out if ($dd || ($md && ($method_length > 1)));
+ $method_out =~ s/_/-/g if $utd;
+
+ # quote values that contain spaces
+ if (exists $params{$method} && $value =~ /^[^'"\s]+\s+[^'"\s]+$/) {
+ $value = '"'.$value.'"';
+ }
+
+ $param_string .= ' '.$method_out.(exists $switches{$method} ? '' : $join.$value);
+ }
+ }
+
+ return $param_string;
+}
+
+sub DESTROY {
+ my $self= shift;
+ unless ( $self->save_tempfiles ) {
+ $self->cleanup();
+ }
+ $self->SUPER::DESTROY();
+}
+
+
+1;
View
1,397 Bio/Tools/Run/WrapperBase/CommandExts.pm
@@ -0,0 +1,1397 @@
+# $Id$
+#
+# BioPerl module for Bio::Tools::Run::WrapperBase::CommandExts
+#
+# Please direct questions and support issues to <bioperl-l@bioperl.org>
+#
+# Cared for by Mark A. Jensen <maj -at- fortinbras -dot- us>
+#
+# Copyright Mark A. Jensen
+#
+# You may distribute this module under the same terms as perl itself
+
+# POD documentation - main docs before the code
+
+=head1 NAME
+
+Bio::Tools::Run::WrapperBase::CommandExts - Extensions to WrapperBase for handling programs with commands *BETA*
+
+=head1 SYNOPSIS
+
+Users, see L</USER INTERFACE>.
+Devs, see L</DEVELOPER INTERFACE>.
+
+=head1 DESCRIPTION
+
+The main idea of this module is to extend
+L<Bio::Tools::Run::WrapperBase> to make it relatively easy to create
+run wrappers around I<suites> of related programs, like C<samtools> or
+C<blast+>.
+
+Some definitions:
+
+=over
+
+=item * program
+
+The program is the command-line frontend application. C<samtools>, for example, is run from the command line as follows:
+
+ $ samtools view -bS in.bam > out.sam
+ $ samtools faidx
+
+=item * command
+
+The command is the specific component of a suite run by executing the
+program. In the example above, C<view> and C<faidx> are commands.
+
+=item * command prefix
+
+The command prefix is an abbreviation of the command name used
+internally by C<CommandExts> method, and sometimes by the user of the
+factory for specifying command line parameters to subcommands of
+composite commands.
+
+=item * composite command
+
+A composite command is a pipeline or script representing a series of
+separate executions of different commands. Composite commands can be
+specified by configuring C<CommandExts> appropriately; the composite
+command can be run by the user from a factory in the same way as
+ordinary commands.
+
+=item * options, parameters, switches and filespecs
+
+An option is any command-line option; i.e., a specification set off by
+a command-line by a specifier (like C<-v> or C<--outfile>). Parameters
+are command-line options that accept a value (C<-title mydb>);
+switches are boolean flags (C<--no-filter>). Filespecs are barewords
+at the end of the command line that usually indicate input or output
+files. In this module, this includes files that capture STDIN, STDOUT,
+or STDERR via redirection.
+
+=item * pseudo-program
+
+A "pseudo-program" is a way to refer to a collection of related
+applications that are run independently from the command line, rather
+than via a frontend program. The C<blast+> suite of programs is an
+example: C<blastn>, C<makeblastdb>, etc. C<CommandExts> can be
+configured to create a single factory for a suite of related,
+independent programs that treats each independent program as a
+"pseudo-program" command.
+
+=back
+
+This module essentially adds the non-assembler-specific wrapper
+machinery of fangly's L<Bio::Tools::Run::AssemblerBase> to the
+L<Bio::Tools::Run::WrapperBase> namespace, adding the general
+command-handling capability of L<Bio::Tools::Run::BWA>. It creates run
+factories that are automatically Bio::ParameterBaseI compliant,
+meaning that C<available_parameters()>, C<set_parameters()>,
+C<get_parameters>, C<reset_parameters()>, and C<parameters_changed()>
+are available.
+
+=head1 USER INTERFACE
+
+Using a wrapper created with C<Bio::Tools::Run::WrapperBase::CommandExts>:
+
+=over
+
+=item * Getting a list of available commands, parameters, and filespecs:
+
+To get a list of commands, simply:
+
+ @commands = Bio::Tools::Run::ThePkg->available_commands;
+
+The wrapper will generally have human-readable aliases for each of the
+command-line options for the wrapped program and commands. To obtain a
+list of the parameters and switches available for a particular
+command, do
+
+ $factory = Bio::Tools::Run::ThePkg->new( -command => 'glurb' );
+ @params = $factory->available_parameters('params');
+ @switches = $factory->available_parameters('switches');
+ @filespec = $factory->available_parameters('filespec');
+ @filespec = $factory->filespec; # alias
+
+=item * Create factories
+
+The factory is a handle on the program and command you wish to
+run. Create a factory using C<new> to set command-line parameters:
+
+ $factory = Bio::Tools::Run::ThePkg->new( -command => 'glurb',
+ -freen => 1,
+ -furschlugginer => 'vreeble' );
+
+A shorthand for this is:
+
+ $factory = Bio::Tools::Run::ThePkg->new_glurb(
+ -freen => 1,
+ -furschlugginer => 'vreeble' );
+
+=item * Running programs
+
+To run the program, use the C<_run> method, providing filespecs as arguments
+
+ $factory = Bio::Tools::Run::ThePkg->new_assemble( -min_qual => 63 );
+ $factory->_run( -faq1 => 'read1.fq', -faq2 => 'read2.fq',
+ -ref => 'refseq.fas', -out => 'new.sam' );
+ # do another
+ $factory->_run( -faq1 => 'read-old1.fq', -faq2 => 'read-old2.fq',
+ -ref => 'refseq.fas', -out => 'old.sam' );
+
+Messages on STDOUT and STDERR are dumped into their respective attributes:
+
+ $stdout = $factory->stdout;
+ $stderr = $factory->stderr;
+
+unless STDOUT and/or STDERR are part of the named files in the filespec.
+
+=item * Setting/getting/resetting/polling parameters.
+
+A C<CommandExts>-based factory is always L<Bio::ParameterBaseI>
+compliant. That means that you may set, get, and reset parameters
+using C<set_parameters()>, C<get_parameters()>, and
+C<reset_parameters>. You can ask whether parameters have changed since
+they were last accessed by using the predicate
+C<parameters_changed>. See L<Bio::ParameterBaseI> for more details.
+
+Once set, parameters become attributes of the factory. Thus, you can get their values as follows:
+
+ if ($factory->freen) {
+ $furs = $factory->furshlugginer;
+ #...
+ }
+
+=back
+
+=head1 DEVELOPER INTERFACE
+
+C<CommandExts> is currently set up to read particular package globals
+which define the program, the commands available, command-line options
+for those commands, and human-readable aliases for those options.
+
+The easiest way to use C<CommandExts> is probably to create two modules:
+
+ Bio::Tools::Run::YourRunPkg
+ Bio::Tools::Run::YourRunPkg::Config
+
+The package globals should be defined in the C<Config> module, and the
+run package itself should begin with the following mantra:
+
+ use YourRunPkg::Config;
+ use Bio::Tools::Run::WrapperBase;
+ use Bio::Tools::Run::WrapperBase::CommandExts;
+ sub new {
+ my $class = shift;
+ my @args = @_;
+ my $self = $class->SUPER::new(@args);
+ ...
+ return $self;
+ }
+
+The following globals can/should be defined in the C<Config> module:
+
+ $program_name
+ $program_dir
+ $use_dash
+ $join
+ @program_commands
+ %command_prefixes
+ @program_params
+ @program_switches
+ %param_translation
+ %composite_commands
+ %command_files
+
+See L</Config Globals> for detailed descriptions.
+
+The work of creating a run wrapper with C<CommandExts> lies mainly in
+setting up the globals. The key methods for the developer interface are:
+
+=over
+
+=item * program_dir($path_to_programs)
+
+Set this to point the factory to the executables.
+
+=item * _run(@file_args)
+
+Runs an instantiated factory with the given file args. Use in the
+ C<run()> method override.
+
+=item * _create_factory_set()
+
+Returns a hash of instantiated factories for each true command from a
+composite command factory. The hash keys are the true command names, so
+you could do
+
+ $cmds = $composite_fac->_create_factory_set;
+ for (@true_commands) {
+ $cmds->{$_}->_run(@file_args);
+ }
+
+=item * executables($cmd,[$fullpath])
+
+For pseudo-programs, this gets/sets the full path to the executable of
+the true program corresponding to the command C<$cmd>.
+
+=back
+
+=head2 Implementing Composite Commands
+
+=head2 Implementing Pseudo-programs
+
+To indicate that a package wraps disparate programs under a single pseudo program, use an asterisk before the program name:
+
+ package Bio::Tools::Run::YourPkg::Config;
+ ...
+ our $program_name = '*blast+';
+
+and C<_run> will know what to do. Specify the rest of the globals as
+if the desired programs were commands. Use the basename of the
+programs for the command names.
+
+If all the programs can be found in a single directory, just specify
+that directory in C<program_dir()>. If not, use C<executables()> to set the paths to each program explicitly:
+
+ foreach (keys %cmdpaths) {
+ $self->executables($_, $cmdpaths{$_});
+ }
+
+=head2 Config Globals
+
+Here is an example config file. Further details in prose are below.
+
+ package Dummy::Config;
+ use strict;
+ use warnings;
+ no warnings qw(qw);
+ use Exporter;
+ our (@ISA, @EXPORT, @EXPORT_OK);
+ push @ISA, 'Exporter';
+ @EXPORT = qw(
+ $program_name
+ $program_dir
+ $use_dash
+ $join
+ @program_commands
+ %command_prefixes
+ @program_params
+ @program_switches
+ %param_translation
+ %command_files
+ %composite_commands
+ );
+
+ our $program_name = '*flurb';
+ our $program_dir = 'C:\cygwin\usr\local\bin';
+ our $use_dash = 'mixed';
+ our $join = ' ';
+
+ our @program_commands = qw(
+ rpsblast
+ cat
+ goob
+ blorb
+ multiglob
+ );
+
+ our %command_prefixes = (
+ blastp => 'blp',
+ tblastn => 'tbn',
+ goob => 'g',
+ blorb => 'b',
+ multiglob => 'm'
+ );
+
+ our @program_params = qw(
+ command
+ g|narf
+ g|schlurb
+ b|scroob
+ b|frelb
+ m|trud
+ );
+
+ our @program_switches = qw(
+ g|freen
+ b|klep
+ );
+
+ our %param_translation = (
+ 'g|narf' => 'n',
+ 'g|schlurb' => 'schlurb',
+ 'g|freen' => 'f',
+ 'b|scroob' => 's',
+ 'b|frelb' => 'frelb'
+ );
+
+ our %command_files = (
+ 'goob' => [qw( fas faq )],
+ );
+
+ our %composite_commands = (
+ 'multiglob' => [qw( blorb goob )]
+ );
+ 1;
+
+C<$use_dash> can be one of C<single>, C<double>, or C<mixed>. See L<Bio::Tools::Run::WrapperBase>.
+
+There is a syntax for the C<%command_files> specification. The token
+matching C<[a-zA-Z0-9_]+> in each element of each arrayref becomes the
+named filespec parameter for the C<_run()> method in the wrapper
+class. Additional symbols surrounding this token indicate how this
+argument should be handled. Some examples:
+
+ >out : stdout is redirected into the file
+ specified by (..., -out => $file,... )
+ <in : stdin is accepted from the file
+ specified by (..., -in => $file,... )
+ 2>log : stderr is redirected into the file
+ specified by (..., -log => $file,... )
+ #opt : this filespec argument is optional
+ (no throw if -opt => $option is missing)
+ 2>#log: if -log is not specified in the arguments, the stderr()
+ method will capture stderr
+ *lst : this filespec can take multiple arguments,
+ specify using an arrayref (..., -lst => [$file1, $file2], ...)
+ *#lst : an optional list
+
+The tokens above are examples; they can be anything matching the above regexp.
+
+=head1 FEEDBACK
+
+=head2 Mailing Lists
+
+User feedback is an integral part of the evolution of this and other
+Bioperl modules. Send your comments and suggestions preferably to
+the Bioperl mailing list. Your participation is much appreciated.
+
+ bioperl-l@bioperl.org - General discussion
+http://bioperl.org/wiki/Mailing_lists - About the mailing lists
+
+=head2 Support
+
+Please direct usage questions or support issues to the mailing list:
+
+L<bioperl-l@bioperl.org>
+
+rather than to the module maintainer directly. Many experienced and
+reponsive experts will be able look at the problem and quickly
+address it. Please include a thorough description of the problem
+with code and data examples if at all possible.
+
+=head2 Reporting Bugs
+
+Report bugs to the Bioperl bug tracking system to help us keep track
+of the bugs and their resolution. Bug reports can be submitted via
+the web:
+
+ http://bugzilla.open-bio.org/
+
+=head1 AUTHOR - Mark A. Jensen
+
+Email maj -at- fortinbras -dot- us
+
+Describe contact details here
+
+=head1 CONTRIBUTORS
+
+Dan Kortschak ( dan -dot- kortschak -at- adelaide -dot- edu -dot- au )
+
+=head1 APPENDIX
+
+The rest of the documentation details each of the object methods.
+Internal methods are usually preceded with a _
+
+=cut
+
+# Let the code begin...
+
+package Bio::Tools::Run::WrapperBase; # need these methods in WrapperBase/maj
+use strict;
+use warnings;
+no warnings qw(redefine);
+
+use Bio::Root::Root;
+use File::Spec;
+use IPC::Run;
+use base qw(Bio::Root::Root Bio::ParameterBaseI);
+
+our $AUTOLOAD;
+
+=head2 new()
+
+ Title : new
+ Usage :
+ Function: constructor for WrapperBase::CommandExts ;
+ correctly binds configuration variables
+ to the WrapperBase object
+ Returns : Bio::Tools::Run::WrapperBase object with command extensions
+ Args :
+ Note : this method subsumes the old _register_program_commands and
+ _set_program_options, leaving out the assembler-specific
+ parms ($qual_param and out_type())
+
+=cut
+
+sub new {
+ my ($class, @args) = @_;
+ my $self = bless ({}, $class);
+ # pull in *copies* of the Config variables from the caller namespace:
+ my ($pkg, @goob) = caller();
+ my ($commands,
+ $default_command,
+ $prefixes,
+ $params,
+ $switches,
+ $translation,
+ $use_dash,
+ $join,
+ $name,
+ $dir,
+ $composite_commands,
+ $files);
+ for (qw( @program_commands
+ %command_prefixes
+ @program_params
+ @program_switches
+ %param_translation
+ $use_dash
+ $join
+ $program_name
+ $program_dir
+ %composite_commands
+ %command_files ) ) {
+ my ($sigil, $var) = m/(.)(.*)/;
+ my $qualvar = "${sigil}${pkg}::${var}";
+ for ($sigil) {
+ /\@/ && do { $qualvar = "\[$qualvar\]" };
+ /\%/ && do { $qualvar = "\{$qualvar\}" };
+ }
+ my $locvar = "\$${var}";
+ $locvar =~ s/program_|command_|param_//g;
+ eval "$locvar = $qualvar";
+ }
+ # set up the info registry hash
+ my %registry;
+ if ($composite_commands) {
+ $self->_register_composite_commands($composite_commands,
+ $params,
+ $switches,
+ $prefixes);
+ }
+ if (!$commands || !@$commands) {
+ $default_command = '_self';
+ }
+ else {
+ for (@$commands) { s/^\*// && ($default_command = $_); }
+ }
+ @registry{qw( _commands _default_command _prefixes _files
+ _params _switches _translation
+ _composite_commands )} =
+ ($commands, $default_command, $prefixes, $files,
+ $params, $switches, $translation,
+ $composite_commands);
+ $self->{_options} = \%registry;
+ if (not defined $use_dash) {
+ $self->{'_options'}->{'_dash'} = 1;
+ } else {
+ $self->{'_options'}->{'_dash'} = $use_dash;
+ }
+ if (not defined $join) {
+ $self->{'_options'}->{'_join'} = ' ';
+ } else {
+ $self->{'_options'}->{'_join'} = $join;
+ }
+ if ($name =~ /^\*/) {
+ $self->is_pseudo(1);
+ $name =~ s/^\*//;
+ }
+ $self->program_name($name) if not defined $self->program_name();
+ $self->program_dir($dir) if not defined $self->program_dir();
+ $self->parameters_changed(
+ $self->set_parameters(@args)
+ ); # set on instantiation, per Bio::ParameterBaseI
+ return $self;
+}
+
+=head2 program_name
+
+ Title : program_name
+ Usage : $factory->program_name($name)
+ Function: get/set the executable name
+ Returns: string
+ Args : string
+
+=cut
+
+sub program_name {
+ my ($self, $val) = @_;
+ $self->{'_program_name'} = $val if $val;
+ return $self->{'_program_name'};
+}
+
+=head2 program_dir
+
+ Title : program_dir
+ Usage : $factory->program_dir($dir)
+ Function: get/set the program dir
+ Returns: string
+ Args : string
+
+=cut
+
+sub program_dir {
+ my ($self, $val) = @_;
+ $self->{'_program_dir'} = $val if $val;
+ return $self->{'_program_dir'};
+}
+
+=head2 _translate_params
+
+ Title : _translate_params
+ Usage : @options = $assembler->_translate_params( );
+ Function: Translate the Bioperl arguments into the arguments to pass to the
+ program on the command line
+ Returns : Arrayref of arguments
+ Args : none
+
+=cut
+
+sub _translate_params {
+ my ($self) = @_;
+ # Get option string
+ my ($params, $switches, $join, $dash, $translat) =
+ @{$self->{_options}}{qw(_params _switches _join _dash _translation)};
+
+ # access the multiple dash choices of _setparams...
+ my @dash_args;
+ $dash ||= 1; # default as advertised
+ for ($dash) {
+ $_ eq '1' && do {
+ @dash_args = ( -dash => 1 );
+ last;
+ };
+ /^s/ && do { #single dash only
+ @dash_args = ( -dash => 1);
+ last;
+ };
+ /^d/ && do { # double dash only
+ @dash_args = ( -double_dash => 1);
+ last;
+ };
+ /^m/ && do { # mixed dash: one-letter opts get -,
+ # long opts get --
+ @dash_args = ( -mixed_dash => 1);
+ last;
+ };
+ do {
+ $self->warn( "Dash spec '$dash' not recognized; using 'single'" );
+ @dash_args = ( -dash => 1 );
+ };
+ }
+ my $options = $self->_setparams(
+ -params => $params,
+ -switches => $switches,
+ -join => $join,
+ @dash_args
+ );
+
+ # Translate options
+ my @options = split(/(\s|$join)/, $options);
+ for (my $i = 0; $i < scalar @options; $i++) {
+ my ($prefix, $name) = ( $options[$i] =~ m/^(-{0,2})(.+)$/ );
+ if (defined $name) {
+ if ($name =~ /command/i) {
+ $name = $options[$i+2]; # get the command
+ splice @options, $i, 4;
+ $i--;
+ # don't add the command if this is a pseudo-program
+ unshift @options, $name unless ($self->is_pseudo); # put command first
+ }
+ elsif (defined $$translat{$name}) {
+ $options[$i] = $prefix.$$translat{$name};
+ }
+ }
+ else {
+ splice @options, $i, 1;
+ $i--;
+ }
+ }
+ # special : the command '_self' indicates
+ # the program should be run without an
+ # intervening command
+ shift @options if $options[0] eq '_self';
+
+ $options = join('', @options);
+
+ # this is a kludge for mixed options: the reason mixed doesn't
+ # work right on the pass through _setparams is that the
+ # *aliases* and not the actual params are passed to it.
+ # here we just rejigger the dashes
+ if ($dash =~ /^m/) {
+ $options =~ s/--([a-z0-9](?:\s|$))/-$1/gi;
+ }
+
+ # Now arrayify the options
+ @options = split(' ', $options);
+
+ return \@options;
+}
+
+=head2 executable()
+
+ Title : executable
+ Usage :
+ Function: find the full path to the main executable,
+ or to the command executable for pseudo-programs
+ Returns : full path, if found
+ Args : [optional] explicit path to the executable
+ (will set the appropriate command exec if
+ applicable)
+ [optional] boolean flag whether or not to warn when exe no found
+ Note : overrides WrapperBase.pm
+
+=cut
+
+sub executable {
+ my $self = shift;
+ my ($exe, $warn) = @_;
+ if ($self->is_pseudo) {
+ return $self->{_pathtoexe} = $self->executables($self->command,$exe);
+ }
+
+ # otherwise
+ # setter
+ if (defined $exe) {
+ $self->throw("binary '$exe' does not exist") unless -e $exe;
+ $self->throw("'$exe' is not executable") unless -x $exe;
+ return $self->{_pathtoexe} = $exe;
+ }
+
+ # getter
+ return $self->{_pathtoexe} if defined $self->{_pathstoexe};
+
+ # finder
+ return $self->{_pathtoexe} = $self->_find_executable($exe, $warn);
+}
+
+=head2 executables()
+
+ Title : executables
+ Usage :
+ Function: find the full path to a command's executable
+ Returns : full path (scalar string)
+ Args : command (scalar string),
+ [optional] explicit path to this command exe
+ [optional] boolean flag whether or not to warn when exe no found
+
+=cut
+
+sub executables {
+ my $self = shift;
+ my ($cmd, $exe, $warn) = @_;
+ # for now, barf if this is not a pseudo program
+ $self->throw("This wrapper represents a single program with commands, not multiple programs; can't use executables()") unless $self->is_pseudo;
+ $self->throw("Command name required at arg 1") unless defined $cmd;
+ $self->throw("The desired executable '$cmd' is not registered as a command") unless grep /^$cmd$/, @{$self->{_options}->{_commands}};
+
+ # setter
+ if (defined $exe) {
+ $self->throw("binary '$exe' does not exist") unless -e $exe;
+ $self->throw("'$exe' is not executable") unless -x $exe;
+ $self->{_pathstoexe} = {} unless defined $self->{_pathstoexe};
+ return $self->{_pathstoexe}->{$cmd} = $exe;
+ }
+
+ # getter
+ return $self->{_pathstoexe}->{$cmd} if defined $self->{_pathstoexe}->{$cmd};
+
+ # finder
+ return $self->{_pathstoexe}->{$cmd} = $self->_find_executable($exe, $warn);
+}
+
+=head2 _find_executable()
+
+ Title : _find_executable
+ Usage : my $exe_path = $fac->_find_executable($exe, $warn);
+ Function: find the full path to a named executable,
+ Returns : full path, if found
+ Args : name of executable to find
+ [optional] boolean flag whether or not to warn when exe no found
+ Note : differs from executable and executables in not
+ setting any object attributes
+
+=cut
+
+sub _find_executable {
+ my $self = shift;
+ my ($exe, $warn) = @_;
+
+ if ($self->is_pseudo && !$exe) {
+ if (!$self->command) {
+ # this throw probably appropriate
+ # the rest are now warns if $warn.../maj
+ $self->throw(
+ "The ".__PACKAGE__." wrapper represents several different programs;".
+ "arg1 to _find_executable must be specified explicitly,".
+ "or the command() attribute set");
+ }
+ else {
+ $exe = $self->command;
+ }
+ }
+ $exe ||= $self->program_path;
+
+ my $path;
+ if ($self->program_dir) {
+ $path = File::Spec->catfile($self->program_dir, $exe);
+ } else {
+ $path = $exe;
+ $self->warn('Program directory not specified; use program_dir($path).') if $warn;
+ }
+
+ # use provided info - we are allowed to follow symlinks, but refuse directories
+ map { return $path.$_ if ( -x $path.$_ && !(-d $path.$_) ) } ('', '.exe') if defined $path;
+
+ # couldn't get path to executable from provided info, so use system path
+ $path = $path ? " in $path" : undef;
+ $self->warn("Executable $exe not found$path, trying system path...") if $warn;
+ if ($path = $self->io->exists_exe($exe)) {
+ return $path;
+ } else {
+ $self->warn("Cannot find executable for program '".($self->is_pseudo ? $self->command : $self->program_name)."'") if $warn;
+ return;
+ }
+}
+
+=head2 _register_composite_commands()
+
+ Title : _register_composite_commands
+ Usage :
+ Function: adds subcomand params and switches for composite commands
+ Returns : true on success
+ Args : \%composite_commands,
+ \@program_params,
+ \@program_switches
+
+=cut
+
+sub _register_composite_commands {
+ my $self = shift;
+ my ($composite_commands, $program_params,
+ $program_switches, $command_prefixes) = @_;
+ my @sub_params;
+ my @sub_switches;
+ foreach my $cmd (keys %$composite_commands) {
+ my $pfx = $command_prefixes->{$cmd} || $cmd;
+ foreach my $subcmd ( @{$$composite_commands{$cmd}} ) {
+ my $spfx = $command_prefixes->{$subcmd} || $subcmd;
+ my @sub_program_params = grep /^$spfx\|/, @$program_params;
+ my @sub_program_switches = grep /^$spfx\|/, @$program_switches;
+ for (@sub_program_params) {
+ m/^$spfx\|(.*)/;
+ push @sub_params, "$pfx\|${spfx}_".$1;
+ }
+ for (@sub_program_switches) {
+ m/^$spfx\|(.*)/;
+ push @sub_switches, "$pfx\|${spfx}_".$1;
+ }
+ }
+ }
+ push @$program_params, @sub_params;
+ push @$program_switches, @sub_switches;
+ # translations for subcmd params/switches not necessary
+ return 1;
+}
+
+=head2 _create_factory_set()
+
+ Title : _create_factory_set
+ Usage : @facs = $self->_create_factory_set
+ Function: instantiate a set of individual command factories for
+ a given composite command
+ Factories will have the correct parameter fields set for
+ their own subcommand
+ Returns : hash of factories: ( $subcmd_prefix => $subcmd_factory, ... )
+ Args : none
+
+=cut
+
+sub _create_factory_set {
+ my $self = shift;
+ $self->throw('command not set') unless $self->command;
+ my $cmd = $self->command;
+ $self->throw('_create_factory_set only works on composite commands')
+ unless grep /^$cmd$/, keys %{$self->{_options}->{_composite_commands}};
+ my %ret;
+ my $class = ref $self;
+ my $subargs_hash = $self->_collate_subcmd_args($cmd);
+ for (keys %$subargs_hash) {
+ $ret{$_} = $class->new( -command => $_, @{$$subargs_hash{$_}} );
+ }
+ return %ret;
+}
+
+=head2 _collate_subcmd_args()
+
+ Title : _collate_subcmd_args
+ Usage : $args_hash = $self->_collate_subcmd_args
+ Function: collate parameters and switches into command-specific
+ arg lists for passing to new()
+ Returns : hash of named argument lists
+ Args : [optional] composite cmd prefix (scalar string)
+ [default is 'run']
+
+=cut
+
+sub _collate_subcmd_args {
+ my $self = shift;
+ my $cmd = shift;
+ my %ret;
+ # default command is 'run'
+ $cmd ||= 'run';
+ return unless $self->{'_options'}->{'_composite_commands'};
+ return unless $self->{'_options'}->{'_composite_commands'}->{$cmd};
+ my @subcmds = @{$self->{'_options'}->{'_composite_commands'}->{$cmd}};
+
+ my $cur_options = $self->{'_options'};
+ # collate
+ foreach my $subcmd (@subcmds) {
+ # find the composite cmd form of the argument in
+ # the current params and switches
+ # e.g., map_max_mismatches
+ my $pfx = $self->{_options}->{_prefixes}->{$subcmd} || $subcmd;
+ my @params = grep /^${pfx}_/, @{$$cur_options{'_params'}};
+ my @switches = grep /^${pfx}_/, @{$$cur_options{'_switches'}};
+ $ret{$subcmd} = [];
+ # create an argument list suitable for passing to new() of
+ # the subcommand factory...
+ foreach my $opt (@params, @switches) {
+ my $subopt = $opt;
+ $subopt =~ s/^${pfx}_//;
+ push(@{$ret{$subcmd}}, '-'.$subopt => $self->$opt) if defined $self->$opt;
+ }
+ }
+ return \%ret;
+}
+
+=head2 _run
+
+ Title : _run
+ Usage : $fac->_run( @file_args )
+ Function: Run a command as specified during object contruction
+ Returns : true on success
+ Args : a specification of the files to operate on according
+ to the filespec
+
+=cut
+
+sub _run {
+ my ($self, @args) = @_;
+ # _translate_params will provide an array of command/parameters/switches
+ # -- these are set at object construction
+ # to set up the run, need to add the files to the call
+ # -- provide these as arguments to this function
+ my $cmd = $self->can('command') ? $self->command : $self->default_command;
+ my $opts = $self->{_options};
+ my %args;
+ $self->throw("No command specified for the object and no default available")
+ unless $cmd;
+ # setup files necessary for this command
+ my $filespec = $opts->{'_files'}->{$cmd};
+ my @switches;
+ my ($in, $out, $err);
+ # some applications rely completely on switches
+ if (defined $filespec && @$filespec) {
+ # parse args based on filespec
+ # require named args
+ $self->throw("Named args are required") unless !(@args % 2);
+ s/^-// for @args;
+ %args = @args;
+ # validate
+ my @req = map {
+ my $s = $_;
+ $s =~ s/^-.*\|//;
+ $s =~ s/^[012]?[<>]//;
+ $s =~ s/[^a-zA-Z0-9_]//g;
+ $s
+ } grep !/[#]/, @$filespec;
+ !defined($args{$_}) && $self->throw("Required filearg '$_' not specified") for @req;
+ # set up redirects and file switches
+ for (@$filespec) {
+ m/^1?>#?(.*)/ && do {
+ defined($args{$1}) && ( open($out,">", $args{$1}) or $self->throw("Open for write error : $!"));
+ next;
+ };
+ m/^2>#?(.*)/ && do {
+ defined($args{$1}) && (open($err, ">", $args{$1}) or $self->throw("Open for write error : $!"));
+ next;
+ };
+ m/^<#?(.*)/ && do {
+ defined($args{$1}) && (open($in, "<", $args{$1}) or $self->throw("Open for read error : $!"));
+ next;
+ };
+ if (m/^-(.*)\|/) {
+ push @switches, $self->_dash_switch($1);
+ } else {
+ push @switches, undef;
+ }
+ }
+ }
+ my $dum;
+ $in || ($in = \$dum);
+ $out || ($out = \$self->{'stdout'});
+ $err || ($err = \$self->{'stderr'});
+
+ # Get program executable
+ my $exe = $self->executable;
+ $self->throw("Can't find executable for '".($self->is_pseudo ? $self->command : $self->program_name)."'; can't continue") unless $exe;
+ # Get command-line options
+ my $options = $self->_translate_params();
+ # Get file specs sans redirects in correct order
+ my @specs = map {
+ my $s = $_;
+ $s =~ s/^-.*\|//;
+ $s =~ s/[^a-zA-Z0-9_]//g;
+ $s
+ } grep !/[<>]/, @$filespec;
+ my @files = @args{@specs};
+ # expand arrayrefs
+ my $l = $#files;
+ for (0..$l) {
+ if (ref($files[$_]) eq 'ARRAY') {
+ splice(@files, $_, 1, @{$files[$_]});
+ splice(@switches, $_, 1, ($switches[$_]) x @{$files[$_]});
+ }
+ }
+ @files = map {
+ my $s = shift @switches;
+ defined $_ ? ($s, $_): ()
+ } @files;
+ @files = map { defined $_ ? $_ : () } @files; # squish undefs
+ my @ipc_args = ( $exe, @$options, @files );
+ eval {
+ IPC::Run::run(\@ipc_args, $in, $out, $err) or
+ die ("There was a problem running $exe : ".$$err);
+ };
+
+ if ($@) {
+ $self->throw("$exe call crashed: $@") unless $self->no_throw_on_crash;
+ return 0;
+ }
+
+ return 1;
+}
+
+
+
+=head2 no_throw_on_crash()
+
+ Title : no_throw_on_crash
+ Usage :
+ Function: prevent throw on execution error
+ Returns :
+ Args : [optional] boolean
+
+=cut
+
+sub no_throw_on_crash {
+ my $self = shift;
+ return $self->{'_no_throw'} = shift if @_;
+ return $self->{'_no_throw'};
+}
+
+=head2 _dash_switch()
+
+ Title : _dash_switch
+ Usage : $version = $fac->_dash_switch( $switch )
+ Function: Returns an appropriately dashed switch for the executable
+ Args : A string containing a switch without dashes
+ Returns : string containing an appropriately dashed switch for the current executable
+
+=cut
+
+sub _dash_switch {
+ my ($self, $switch) = @_;
+
+ my $dash = $self->{'_options'}->{'_dash'};
+ for ($dash) {
+ $_ eq '1' && do {
+ $switch = '-'.$switch;
+ last;
+ };
+ /^s/ && do { #single dash only
+ $switch = '-'.$switch;
+ last;
+ };
+ /^d/ && do { # double dash only
+ $switch = '--'.$switch;
+ last;
+ };
+ /^m/ && do { # mixed dash: one-letter opts get -,
+ $switch = '-'.$switch;
+ $switch =~ s/^(-[a-z0-9](?:\w+))$/-$1/i;
+ last;
+ };
+ do {
+ $self->warn( "Dash spec '$dash' not recognized; using 'single'" );
+ $switch = '-'.$switch;
+ };
+ }
+
+ return $switch;
+}
+
+=head2 stdout()
+
+ Title : stdout
+ Usage : $fac->stdout()
+ Function: store the output from STDOUT for the run,
+ if no file specified in _run arguments
+ Example :
+ Returns : scalar string
+ Args : on set, new value (a scalar or undef, optional)
+
+=cut
+
+sub stdout {
+ my $self = shift;
+ return $self->{'stdout'} = shift if @_;
+ return $self->{'stdout'};
+}
+
+=head2 stderr()
+
+ Title : stderr
+ Usage : $fac->stderr()
+ Function: store the output from STDERR for the run,
+ if no file is specified in _run arguments
+ Example :
+ Returns : scalar string
+ Args : on set, new value (a scalar or undef, optional)
+
+=cut
+
+sub stderr {
+ my $self = shift;
+ return $self->{'stderr'} = shift if @_;
+ return $self->{'stderr'};
+}
+
+=head2 is_pseudo()
+
+ Title : is_pseudo
+ Usage : $obj->is_pseudo($newval)
+ Function: returns true if this factory represents
+ a pseudo-program
+ Example :
+ Returns : value of is_pseudo (boolean)
+ Args : on set, new value (a scalar or undef, optional)
+
+=cut
+
+sub is_pseudo {
+ my $self = shift;
+
+ return $self->{'is_pseudo'} = shift if @_;
+ return $self->{'is_pseudo'};
+}
+
+=head2 default_command()
+
+ Title : default_command
+ Usage : $obj->default_command()
+ Function: return the name of the default command, if any
+ Returns : scalar string or undef
+ Args : none
+ Note : defaults to "run", if "run" is present among the
+ registered commands;
+ falls through to "_self" (run the program itself,
+ without any command), if "_self" is present among
+ the registered commands
+
+=cut
+
+sub default_command {
+ my $self = shift;
+ if (my $opts = $self->{_options}) {
+ return $opts->{_default_command} if $opts->{_default_command};
+ return 'run' if grep /^run$/, @{$opts->{_commands}};
+ return '_self' if grep /^_self$/, @{$opts->{_commands}};
+ }
+ return;
+}
+
+=head2 AUTOLOAD
+
+AUTOLOAD permits
+
+ $class->new_yourcommand(@args);
+
+as an alias for
+
+ $class->new( -command => 'yourcommand', @args );
+
+as well as
+
+ $fac->$yourcommand( @args );
+
+as an alias for
+
+ $fac->_run( -command => $your_command, @args );
+
+=cut
+
+sub AUTOLOAD {
+ my $class = shift;
+ my $self = ref($class) ? $class : undef;
+ my $tok = $AUTOLOAD;
+ my @args = @_;
+ $tok =~ s/.*:://;
+ if ($tok eq 'command') {
+ return $self->default_command;
+ }
+ if ($tok =~ /^new_/) {
+ my ($cmd) = $tok =~ m/new_(.*)/;
+ return $class->new( -command => $cmd, @args );
+ }
+ my %args = @args;
+ if ($self && grep(/^$tok$/, $class->available_commands)) {
+ if ( @args{qw( command -command COMMAND -COMMAND)} ) {
+ $self->warn("-command argument ignored in autorun");
+ delete $args{$_} for qw( command -command COMMAND -COMMAND );
+ }
+ # autorun
+ @args = %args;
+ $self->set_parameters( -command => $tok, @args );
+ return $self->_run();
+ }
+ else {
+ $class->throw("Can't locate object method '$tok' via package '".
+ ($self?ref($self):$class)."'");
+ }
+}
+
+=head1 Bio:ParameterBaseI compliance
+
+=head2 set_parameters()
+
+ Title : set_parameters
+ Usage : $pobj->set_parameters(%params);
+ Function: sets the parameters listed in the hash or array
+ Returns : true if any parameters were set, false (0) if not
+ Args : [optional] hash or array of parameter/values.
+
+=cut
+
+sub set_parameters {
+ my ($self, @args) = @_;
+ # currently stored stuff
+ my $opts = $self->{'_options'};
+ my $params = $opts->{'_params'};
+ my $switches = $opts->{'_switches'};
+ my $translation = $opts->{'_translation'};
+ my $use_dash = $opts->{'_dash'};
+ my $join = $opts->{'_join'};
+ unless (($self->can('command') && $self->command)
+ || (grep /command/, @args)) {
+ if ($opts->{'_default_command'}) {
+ push @args, '-command' => $opts->{'_default_command'};
+ }
+ elsif (grep /^run$/, @{$opts->{'_commands'}}) {
+ push @args, '-command' => 'run';
+ }
+ else {
+ return 0; # quietly, but undef, since a command is needed to
+ # route the parameters
+ }
+ }
+ my %args = @args;
+ my $cmd = $args{'-command'} || $args{'command'} || ($self->can('command') && $self->command);
+ if ($cmd) {
+ my (@p,@s, %x);
+ $self->warn('Command present, but no commands registered') unless $self->{'_options'}->{'_commands'};
+ $self->throw("Command '$cmd' not registered") unless grep /^$cmd$/, @{$self->{'_options'}->{'_commands'}};
+ $cmd = $self->{_options}->{_prefixes}->{$cmd} || $cmd;
+
+ @p = (grep(!/^.*?\|/, @$params), grep(/^${cmd}\|/, @$params));
+ @s = (grep(!/^.*?\|/, @$switches), grep(/^${cmd}\|/, @$switches));
+ s/.*?\|// for @p;
+ s/.*?\|// for @s;
+ @x{@p, @s} = @{$translation}{
+ grep( !/^.*?\|/, @$params, @$switches),
+ grep(/^${cmd}\|/, @$params, @$switches) };
+ $opts->{_translation} = $translation = \%x;
+ $opts->{_params} = $params = \@p;
+ $opts->{_switches} = $switches = \@s;
+ }
+ $self->_set_from_args(
+ \@args,
+ -methods => [ @$params, @$switches, 'command', 'program_name', 'program_dir', 'out_type' ],
+ -create => 1,
+ # when our parms are accessed, signal parameters are unchanged for
+ # future reads (until set_parameters is called)
+ -code =>
+ ' my $self = shift;
+ $self->parameters_changed(0);
+ return $self->{\'_\'.$method} = shift if @_;
+ return $self->{\'_\'.$method};'
+ );
+ # the question is, are previously-set parameters left alone when
+ # not specified in @args?
+ $self->parameters_changed(1);
+ return 1;
+}
+
+=head2 reset_parameters()
+
+ Title : reset_parameters
+ Usage : resets values
+ Function: resets parameters to either undef or value in passed hash
+ Returns : none
+ Args : [optional] hash of parameter-value pairs
+
+=cut
+
+sub reset_parameters {
+ my ($self, @args) = @_;
+
+ my @reset_args;
+ # currently stored stuff
+ my $opts = $self->{'_options'};
+ my $params = $opts->{'_params'};
+ my $switches = $opts->{'_switches'};
+ my $translation = $opts->{'_translation'};
+ my $qual_param = $opts->{'_qual_param'};
+ my $use_dash = $opts->{'_dash'};
+ my $join = $opts->{'_join'};
+
+ # handle command name
+ my %args = @args;
+ my $cmd = $args{'-command'} || $args{'command'} || $self->command;
+ $args{'command'} = $cmd;
+ delete $args{'-command'};
+ @args = %args;
+ # don't like this, b/c _set_program_args will create a bunch of
+ # accessors with undef values, but oh well for now /maj
+
+ for my $p (@$params) {
+ push(@reset_args, $p => undef) unless grep /^[-]?$p$/, @args;
+ }
+ for my $s (@$switches) {
+ push(@reset_args, $s => undef) unless grep /^[-]?$s$/, @args;
+ }
+ push @args, @reset_args;
+ $self->set_parameters(@args);
+ $self->parameters_changed(1);
+}
+
+=head2 parameters_changed()
+
+ Title : parameters_changed
+ Usage : if ($pobj->parameters_changed) {...}
+ Function: Returns boolean true (1) if parameters have changed
+ Returns : Boolean (0 or 1)
+ Args : [optional] Boolean
+
+=cut
+
+sub parameters_changed {
+ my $self = shift;
+ return $self->{'_parameters_changed'} = shift if @_;
+ return $self->{'_parameters_changed'};
+}
+
+=head2 available_parameters()
+
+ Title : available_parameters
+ Usage : @params = $pobj->available_parameters()
+ Function: Returns a list of the available parameters
+ Returns : Array of parameters
+ Args : 'params' for settable program paramters
+ 'switches' for boolean program switches
+ default: all
+
+=cut
+
+sub available_parameters {
+ my $self = shift;
+ my $subset = shift;
+ my $opts = $self->{'_options'};
+ my @ret;
+ for ($subset) {
+ (!defined || /^a/) && do {
+ @ret = (@{$opts->{'_params'}}, @{$opts->{'_switches'}});
+ last;
+ };
+ m/^p/i && do {
+ @ret = @{$opts->{'_params'}};
+ last;
+ };
+ m/^s/i && do {
+ @ret = @{$opts->{'_switches'}};
+ last;
+ };
+ m/^c/i && do {
+ @ret = @{$opts->{'_commands'}};
+ last;
+ };
+ m/^f/i && do { # get file spec
+ return @{$opts->{'_files'}->{$self->command}};
+ };
+ do { #fail
+ $self->throw("available_parameters: unrecognized subset");
+ };
+ }
+ return @ret;
+}
+
+sub available_commands { shift->available_parameters('commands') }
+sub filespec { shift->available_parameters('filespec') }
+
+=head2 get_parameters()
+
+ Title : get_parameters
+ Usage : %params = $pobj->get_parameters;
+ Function: Returns list of key-value pairs of parameter => value
+ Returns : List of key-value pairs
+ Args : [optional] A string is allowed if subsets are wanted or (if a
+ parameter subset is default) 'all' to return all parameters
+
+=cut
+
+sub get_parameters {
+ my $self = shift;
+ my $subset = shift;
+ $subset ||= 'all';
+ my @ret;
+ my $opts = $self->{'_options'};
+ for ($subset) {
+ m/^p/i && do { #params only
+ for (@{$opts->{'_params'}}) {
+ push(@ret, $_, $self->$_) if $self->can($_) && defined $self->$_;
+ }
+ last;
+ };
+ m/^s/i && do { #switches only
+ for (@{$opts->{'_switches'}}) {
+ push(@ret, $_, $self->$_) if $self->can($_) && defined $self->$_;
+ }
+ last;
+ };
+ m/^a/i && do { # all
+ for ((@{$opts->{'_params'}},@{$opts->{'_switches'}})) {
+ push(@ret, $_, $self->$_) if $self->can($_) && defined $self->$_;
+ }
+ last;
+ };
+ do {
+ $self->throw("get_parameters: unrecognized subset");
+ };
+ }
+ return @ret;
+}
+
+1;

0 comments on commit 23c5a87

Please sign in to comment.