File Coverage

blib/lib/Bio/Tools/Run/WrapperBase.pm
Criterion Covered Total %
statement 94 121 77.6
branch 50 86 58.1
condition 21 41 51.2
subroutine 16 21 76.1
pod 15 15 100.0
total 196 284 69.0


line stmt bran cond sub pod time code
1             #
2             # BioPerl module for Bio::Tools::Run::WrapperBase
3             #
4             # Please direct questions and support issues to
5             #
6             # Cared for by Jason Stajich
7             #
8             # Copyright Jason Stajich
9             #
10             # You may distribute this module under the same terms as perl itself
11              
12             # POD documentation - main docs before the code
13              
14             =head1 NAME
15              
16             Bio::Tools::Run::WrapperBase - A Base object for wrappers around executables
17              
18             =head1 SYNOPSIS
19              
20             # do not use this object directly, it provides the following methods
21             # for its subclasses
22              
23             my $errstr = $obj->error_string();
24             my $exe = $obj->executable();
25             $obj->save_tempfiles($booleanflag)
26             my $outfile= $obj->outfile_name();
27             my $tempdir= $obj->tempdir(); # get a temporary dir for executing
28             my $io = $obj->io; # Bio::Root::IO object
29             my $cleanup= $obj->cleanup(); # remove tempfiles
30              
31             $obj->run({-arg1 => $value});
32              
33             =head1 DESCRIPTION
34              
35             This is a basic module from which to build executable wrapper modules.
36             It has some basic methods to help when implementing new modules.
37              
38             =head1 FEEDBACK
39              
40             =head2 Mailing Lists
41              
42             User feedback is an integral part of the evolution of this and other
43             Bioperl modules. Send your comments and suggestions preferably to
44             the Bioperl mailing list. Your participation is much appreciated.
45              
46             bioperl-l@bioperl.org - General discussion
47             http://bioperl.org/wiki/Mailing_lists - About the mailing lists
48              
49             =head2 Support
50              
51             Please direct usage questions or support issues to the mailing list:
52              
53             I
54              
55             rather than to the module maintainer directly. Many experienced and
56             reponsive experts will be able look at the problem and quickly
57             address it. Please include a thorough description of the problem
58             with code and data examples if at all possible.
59              
60             =head2 Reporting Bugs
61              
62             Report bugs to the Bioperl bug tracking system to help us keep track of
63             the bugs and their resolution. Bug reports can be submitted via the
64             web:
65              
66             https://github.com/bioperl/bioperl-live/issues
67              
68             =head1 AUTHOR - Jason Stajich
69              
70             Email jason-at-bioperl.org
71              
72             =head1 CONTRIBUTORS
73              
74             Sendu Bala, bix@sendu.me.uk
75              
76             =head1 APPENDIX
77              
78             The rest of the documentation details each of the object methods.
79             Internal methods are usually preceded with a _
80              
81             =cut
82              
83              
84             # Let the code begin...
85              
86              
87             package Bio::Tools::Run::WrapperBase;
88 74     74   38114 use strict;
  74         112  
  74         1984  
89              
90             # Object preamble - inherits from Bio::Root::Root
91              
92 74     74   301 use base qw(Bio::Root::Root);
  74         89  
  74         4380  
93              
94 74     74   329 use File::Spec;
  74         98  
  74         1198  
95 74     74   441 use File::Path qw(); # don't import anything
  74         86  
  74         75583  
96              
97             =head2 run
98              
99             Title : run
100             Usage : $wrapper->run({ARGS HERE});
101             Function: Support generic running with args passed in
102             as a hashref
103             Returns : Depends on the implementation, status OR data
104             Args : hashref of named arguments
105              
106              
107             =cut
108              
109             sub run {
110 0     0 1 0 my ($self,@args) = @_;
111 0         0 $self->throw_not_implemented();
112             }
113              
114              
115             =head2 error_string
116              
117             Title : error_string
118             Usage : $obj->error_string($newval)
119             Function: Where the output from the last analysis run is stored.
120             Returns : value of error_string
121             Args : newvalue (optional)
122              
123              
124             =cut
125              
126             sub error_string{
127 2     2 1 4 my ($self,$value) = @_;
128 2 50       6 if( defined $value) {
129 0         0 $self->{'_error_string'} = $value;
130             }
131 2   50     15 return $self->{'_error_string'} || '';
132             }
133              
134             =head2 arguments
135              
136             Title : arguments
137             Usage : $obj->arguments($newval)
138             Function: Commandline parameters
139             Returns : value of arguments
140             Args : newvalue (optional)
141              
142              
143             =cut
144              
145             sub arguments {
146 1     1 1 2 my ($self,$value) = @_;
147 1 50       2 if(defined $value) {
148 1         3 $self->{'_arguments'} = $value;
149             }
150 1   50     5 return $self->{'_arguments'} || '';
151             }
152              
153              
154             =head2 no_param_checks
155              
156             Title : no_param_checks
157             Usage : $obj->no_param_checks($newval)
158             Function: Boolean flag as to whether or not we should
159             trust the sanity checks for parameter values
160             Returns : value of no_param_checks
161             Args : newvalue (optional)
162              
163              
164             =cut
165              
166             sub no_param_checks{
167 4     4 1 3 my ($self,$value) = @_;
168 4 100 66     17 if( defined $value || ! defined $self->{'no_param_checks'} ) {
169 1 50       4 $value = 0 unless defined $value;
170 1         1 $self->{'no_param_checks'} = $value;
171             }
172 4         17 return $self->{'no_param_checks'};
173             }
174              
175             =head2 save_tempfiles
176              
177             Title : save_tempfiles
178             Usage : $obj->save_tempfiles($newval)
179             Function: Get/set the choice of if tempfiles in the temp dir (see tempdir())
180             are kept or cleaned up. Default is '0', ie. delete temp files.
181             NB: This must be set to the desired value PRIOR to first creating
182             a temp dir with tempdir(). Any attempt to set this after tempdir creation will get a warning.
183             Returns : boolean
184             Args : none to get, boolean to set
185              
186             =cut
187              
188             sub save_tempfiles{
189 21     21 1 32 my $self = shift;
190 21         39 my @args = @_;
191 21 0 33     77 if (($args[0]) && (exists ($self->{'_tmpdir'}))) {
192 0         0 $self->warn ("Tempdir already created; setting save_tempfiles will not affect cleanup behavior.");
193             }
194 21         52 return $self->io->save_tempfiles(@_);
195             }
196              
197             =head2 outfile_name
198              
199             Title : outfile_name
200             Usage : my $outfile = $wrapper->outfile_name();
201             Function: Get/Set the name of the output file for this run
202             (if you wanted to do something special)
203             Returns : string
204             Args : [optional] string to set value to
205              
206              
207             =cut
208              
209             sub outfile_name{
210 9     9 1 18 my ($self,$nm) = @_;
211 9 50 66     47 if( defined $nm || ! defined $self->{'_outfilename'} ) {
212 9 100       74 $nm = 'mlc' unless defined $nm;
213 9         49 $self->{'_outfilename'} = $nm;
214             }
215 9         41 return $self->{'_outfilename'};
216             }
217              
218              
219             =head2 tempdir
220              
221             Title : tempdir
222             Usage : my $tmpdir = $self->tempdir();
223             Function: Retrieve a temporary directory name (which is created)
224             Returns : string which is the name of the temporary directory
225             Args : none
226              
227              
228             =cut
229              
230             sub tempdir{
231 0     0 1 0 my ($self) = shift;
232              
233 0 0       0 $self->{'_tmpdir'} = shift if @_;
234 0 0       0 unless( $self->{'_tmpdir'} ) {
235 0         0 $self->{'_tmpdir'} = $self->io->tempdir(CLEANUP => ! $self->save_tempfiles );
236             }
237 0 0       0 unless( -d $self->{'_tmpdir'} ) {
238 0         0 mkdir($self->{'_tmpdir'},0777);
239             }
240 0         0 return $self->{'_tmpdir'};
241             }
242              
243             =head2 cleanup
244              
245             Title : cleanup
246             Usage : $wrapper->cleanup();
247             Function: Will cleanup the tempdir directory
248             Returns : none
249             Args : none
250              
251              
252             =cut
253              
254             sub cleanup{
255 21     21 1 32 my ($self) = @_;
256 21         44 $self->io->_io_cleanup();
257 21 50 33     669 if( defined $self->{'_tmpdir'} && -d $self->{'_tmpdir'} ) {
258 0 0       0 my $verbose = ($self->verbose >= 1) ? 1 : 0;
259 0         0 File::Path::rmtree( $self->{'_tmpdir'}, $verbose);
260             }
261             }
262              
263             =head2 io
264              
265             Title : io
266             Usage : $obj->io($newval)
267             Function: Gets a Bio::Root::IO object
268             Returns : Bio::Root::IO object
269             Args : none
270              
271              
272             =cut
273              
274             sub io{
275 154     154 1 224 my ($self) = @_;
276 154 100       383 unless( defined $self->{'io'} ) {
277 70         349 $self->{'io'} = Bio::Root::IO->new(-verbose => $self->verbose);
278             }
279 154         7381 return $self->{'io'};
280             }
281              
282             =head2 version
283              
284             Title : version
285             Usage : $version = $wrapper->version()
286             Function: Returns the program version (if available)
287             Returns : string representing version of the program
288             Args : [Optional] value to (re)set version string
289              
290              
291             =cut
292              
293             sub version{
294 0     0 1 0 my ($self,@args) = @_;
295 0         0 return;
296             }
297              
298             =head2 executable
299              
300             Title : executable
301             Usage : my $exe = $factory->executable();
302             Function: Finds the full path to the executable
303             Returns : string representing the full path to the exe
304             Args : [optional] name of executable to set path to
305             [optional] boolean flag whether or not warn when exe is not found
306              
307             =cut
308              
309             sub executable {
310 61     61 1 41869 my ($self, $exe, $warn) = @_;
311              
312 61 50       230 if (defined $exe) {
313 0         0 $self->{'_pathtoexe'} = $exe;
314             }
315              
316 61 50       224 unless( defined $self->{'_pathtoexe'} ) {
317 61         348 my $prog_path = $self->program_path;
318              
319 61 50       187 if ($prog_path) {
320 61 50 33     1843 if (-f $prog_path && -x $prog_path) {
    100          
321 0         0 $self->{'_pathtoexe'} = $prog_path;
322             }
323             elsif ($self->program_dir) {
324 6 50       20 $self->warn("executable not found in $prog_path, trying system path...") if $warn;
325             }
326             }
327 61 50       230 unless ($self->{'_pathtoexe'}) {
328 61         66 my $exe;
329 61 50       364 if ( $exe = $self->io->exists_exe($self->program_name) ) {
330 0         0 $self->{'_pathtoexe'} = $exe;
331             }
332             else {
333 61 50       10094 $self->warn("Cannot find executable for ".$self->program_name) if $warn;
334 61         170 $self->{'_pathtoexe'} = undef;
335             }
336             }
337             }
338              
339             # bail if we never found the executable
340 61 50       214 unless ( defined $self->{'_pathtoexe'}) {
341 61         195 $self->throw("Cannot find executable for ".$self->program_name .
342             ". path=\"".$self->program_path."\"");
343             }
344 0         0 return $self->{'_pathtoexe'};
345             }
346              
347             =head2 program_path
348              
349             Title : program_path
350             Usage : my $path = $factory->program_path();
351             Function: Builds path for executable
352             Returns : string representing the full path to the exe
353             Args : none
354              
355             =cut
356              
357             sub program_path {
358 122     122 1 467 my ($self) = @_;
359 122         122 my @path;
360 122 100       387 push @path, $self->program_dir if $self->program_dir;
361 122 50       334 push @path, $self->program_name.($^O =~ /mswin/i ? '.exe' : '') if $self->program_name;
    50          
362 122         1228 return File::Spec->catfile(@path);
363             }
364              
365             =head2 program_dir
366              
367             Title : program_dir
368             Usage : my $dir = $factory->program_dir();
369             Function: Abstract get method for dir of program. To be implemented
370             by wrapper.
371             Returns : string representing program directory
372             Args : none
373              
374             =cut
375              
376             sub program_dir {
377 0     0 1 0 my ($self) = @_;
378 0         0 $self->throw_not_implemented();
379             }
380              
381             =head2 program_name
382              
383             Title : program_name
384             Usage : my $name = $factory->program_name();
385             Function: Abstract get method for name of program. To be implemented
386             by wrapper.
387             Returns : string representing program name
388             Args : none
389              
390             =cut
391              
392             sub program_name {
393 0     0 1 0 my ($self) = @_;
394 0         0 $self->throw_not_implemented();
395             }
396              
397             =head2 quiet
398              
399             Title : quiet
400             Usage : $factory->quiet(1);
401             if ($factory->quiet()) { ... }
402             Function: Get/set the quiet state. Can be used by wrappers to control if
403             program output is printed to the console or not.
404             Returns : boolean
405             Args : none to get, boolean to set
406              
407             =cut
408              
409             sub quiet {
410 22     22 1 37133 my $self = shift;
411 22 100       68 if (@_) { $self->{quiet} = shift }
  18         63  
412 22   100     93 return $self->{quiet} || 0;
413             }
414              
415             =head2 _setparams()
416              
417             Title : _setparams
418             Usage : $params = $self->_setparams(-params => [qw(window evalue_cutoff)])
419             Function: For internal use by wrapper modules to build parameter strings
420             suitable for sending to the program being wrapped. For each method
421             name supplied, calls the method and adds the method name (as modified
422             by optional things) along with its value (unless a switch) to the
423             parameter string
424             Example : $params = $self->_setparams(-params => [qw(window evalue_cutoff)],
425             -switches => [qw(simple large all)],
426             -double_dash => 1,
427             -underscore_to_dash => 1);
428             If window() and simple() had not been previously called, but
429             evalue_cutoff(0.5), large(1) and all(0) had been called, $params
430             would be ' --evalue-cutoff 0.5 --large'
431             Returns : parameter string
432             Args : -params => [] or {} # array ref of method names to call,
433             or hash ref where keys are method names and
434             values are how those names should be output
435             in the params string
436             -switches => [] or {}# as for -params, but no value is printed for
437             these methods
438             -join => string # define how parameters and their values are
439             joined, default ' '. (eg. could be '=' for
440             param=value)
441             -lc => boolean # lc() method names prior to output in string
442             -dash => boolean # prefix all method names with a single dash
443             -double_dash => bool # prefix all method names with a double dash
444             -mixed_dash => bool # prefix single-character method names with a
445             # single dash, and multi-character method names
446             # with a double-dash
447             -underscore_to_dash => boolean # convert all underscores in method
448             names to dashes
449              
450             =cut
451              
452             sub _setparams {
453 3     3   8 my ($self, @args) = @_;
454              
455 3         19 my ($params, $switches, $join, $lc, $d, $dd, $md, $utd) =
456             $self->_rearrange([qw(PARAMS
457             SWITCHES
458             JOIN
459             LC
460             DASH
461             DOUBLE_DASH
462             MIXED_DASH
463             UNDERSCORE_TO_DASH)], @args);
464 3 50 33     94 $self->throw('at least one of -params or -switches is required') unless ($params || $switches);
465 3 50       11 $self->throw("-dash, -double_dash and -mixed_dash are mutually exclusive") if (defined($d) + defined($dd) + defined($md) > 1);
466 3   50     8 $join ||= ' ';
467              
468 3 50       10 my %params = ref($params) eq 'HASH' ? %{$params} : map { $_ => $_ } @{$params};
  0         0  
  44         57  
  3         4  
469 3 50       13 my %switches = ref($switches) eq 'HASH' ? %{$switches} : map { $_ => $_ } @{$switches};
  0         0  
  39         65  
  3         6  
470              
471 3         8 my $param_string = '';
472 3         7 for my $hash_ref (\%params, \%switches) {
473 6         7 while (my ($method, $method_out) = each %{$hash_ref}) {
  89         197  
474 83         1200 my $value = $self->$method();
475 83 100       384 next unless (defined $value);
476 12 50 66     37 next if (exists $switches{$method} && ! $value);
477              
478 12 50       17 $method_out = lc($method_out) if $lc;
479 12 100       19 my $method_length = length($method_out) if $md;
480 12 100 33     42 $method_out = '-'.$method_out if ($d || ($md && ($method_length == 1)));
      66        
481 12 100 66     54 $method_out = '--'.$method_out if ($dd || ($md && ($method_length > 1)));
      33        
482 12 50       17 $method_out =~ s/_/-/g if $utd;
483              
484 12 100       17 if ( exists $params{$method} ) {
485             # if value are quoted with " or ', re-quote it
486 8 50       41 if ( $value =~ m{^[\'\"]+(.+)[\'\"]+$} ) {
    50          
487 0         0 $value = '"'. $1 . '"';
488             }
489             # quote values that contain spaces
490             elsif ( $value =~ m{\s+} ) {
491 0         0 $value = '"'. $value . '"';
492             }
493             }
494              
495 12 100       37 $param_string .= ' '.$method_out.(exists $switches{$method} ? '' : $join.$value);
496             }
497             }
498              
499 3         23 return $param_string;
500             }
501              
502             sub DESTROY {
503 15     15   96083 my $self= shift;
504 15 50       114 unless ( $self->save_tempfiles ) {
505 15         431 $self->cleanup();
506             }
507 15         89 $self->SUPER::DESTROY();
508             }
509              
510              
511             1;