|
0
|
1 package CPT::Parameter;
|
|
|
2 use Moose::Role;
|
|
|
3 use strict;
|
|
|
4 use warnings;
|
|
|
5 use autodie;
|
|
|
6 use Carp;
|
|
|
7
|
|
|
8 #requires 'galaxy_command';
|
|
|
9 requires 'galaxy_input';
|
|
|
10 requires 'galaxy_output';
|
|
|
11 requires 'validate_individual';
|
|
|
12 requires 'getopt_format';
|
|
|
13
|
|
|
14 # Long name for this parameter (mandatory)
|
|
|
15 has 'name' => ( is => 'rw', isa => 'Str' );
|
|
|
16
|
|
|
17 # Short name for this paramter (optional)
|
|
|
18 has 'short' => ( is => 'rw', isa => 'Str' );
|
|
|
19 has 'multiple' => ( is => 'rw', isa => 'Bool' );
|
|
|
20 has 'description' => ( is => 'rw', isa => 'Str' );
|
|
|
21
|
|
|
22 # Attr
|
|
|
23 # Default supplied parameters
|
|
|
24 has 'default' => ( is => 'rw', isa => 'Any' );
|
|
|
25 # User supplied values
|
|
|
26 has 'value' => ( is => 'rw', isa => 'Any' );
|
|
|
27 has 'required' => ( is => 'rw', isa => 'Bool' );
|
|
|
28 has 'hidden' => ( is => 'rw', isa => 'Bool' );
|
|
|
29
|
|
|
30 # Set of error messages to be returned
|
|
|
31 has 'errors' => ( is => 'rw', isa => 'ArrayRef', default => sub { [] } );
|
|
|
32
|
|
|
33 # Unimplemented
|
|
|
34 # Are there any implications of setting this
|
|
|
35 has 'implies' => ( is => 'rw', isa => 'ArrayRef' );
|
|
|
36
|
|
|
37 # Internal
|
|
|
38 has '_index' => ( is => 'rw', isa => 'Int', default => 0 );
|
|
|
39
|
|
|
40 # Galaxy Specific
|
|
|
41 has '_galaxy_specific' => (is => 'rw', isa => 'Bool', default => 0);
|
|
|
42 # implies option is somehow intertwined with whether or not this is being produced for use in galaxy.
|
|
|
43 has '_show_in_galaxy' => (is => 'rw', isa => 'Bool', default => 1);
|
|
|
44 # This is a custom override. If the object is hidden by default, it will causae it to be shown. If the object is visible by default, it can cause it to be hidden.
|
|
|
45
|
|
|
46
|
|
|
47
|
|
|
48 sub galaxy_command {
|
|
|
49 my ($self) = @_;
|
|
|
50 my $value = $self->get_galaxy_command_identifier();
|
|
|
51
|
|
|
52 # If it's hidden, specific to galaxy, and hidden from galaxy users,
|
|
|
53 # then it is safe to assume we've specified a SANE default.
|
|
|
54 if($self->hidden() && $self->_galaxy_specific()){
|
|
|
55 $value = $self->default();
|
|
|
56 }
|
|
|
57 my $string;
|
|
|
58
|
|
|
59 # If it's a repeat, we handle that
|
|
|
60 $string .= $self->handle_possible_galaxy_command_repeat_start();
|
|
|
61 # If it's required we set it to a value IF we have one. Otherwise value
|
|
|
62 # will be the galaxy_identifier.
|
|
|
63 if($self->required()){
|
|
|
64 $string .= sprintf( '--%s "${%s}"' . "\n",
|
|
|
65 $self->get_galaxy_cli_identifier(), $value
|
|
|
66 );
|
|
|
67 }else{
|
|
|
68 # If
|
|
|
69 # This code is only relevant if we're multiple, otherwise the loop will
|
|
|
70 # not pass here
|
|
|
71 if ( !$self->multiple() ){
|
|
|
72 $string .= sprintf('#if $%s and $%s is not "None":' . "\n",
|
|
|
73 $self->get_galaxy_cli_identifier(),
|
|
|
74 $self->get_galaxy_cli_identifier()
|
|
|
75 );
|
|
|
76 }
|
|
|
77 # Flag
|
|
|
78 $string .= sprintf( '--%s "${%s}"'."\n",
|
|
|
79 $self->get_galaxy_cli_identifier(),
|
|
|
80 $value
|
|
|
81 );
|
|
|
82 # End
|
|
|
83 if ( !$self->multiple() ){
|
|
|
84 $string .= "#end if\n";
|
|
|
85 }
|
|
|
86 }
|
|
|
87 $string .= $self->handle_possible_galaxy_command_repeat_end();
|
|
|
88 return $string;
|
|
|
89 }
|
|
|
90
|
|
|
91
|
|
|
92
|
|
|
93 sub getOptionsArray {
|
|
|
94 my ($self) = @_;
|
|
|
95 my @getoptions;
|
|
|
96 push( @getoptions, $self->getopt_identifier() );
|
|
|
97
|
|
|
98 my $mod_desc = $self->description();
|
|
|
99 if(defined $self->default()){
|
|
|
100 if(ref $self->default() eq 'ARRAY'){
|
|
|
101 $mod_desc .= sprintf(" (Default: %s)", join(",",@{$self->default()}));
|
|
|
102 }else{
|
|
|
103 $mod_desc .= sprintf(" (Default: %s)", $self->default());
|
|
|
104 }
|
|
|
105 }
|
|
|
106 if(substr(blessed($self),0,22) eq 'CPT::Parameter::Option'){
|
|
|
107 my %kv = %{$self->options()};
|
|
|
108 my @k = keys(%kv);
|
|
|
109 $mod_desc .= sprintf(" (Options: %s)",
|
|
|
110 join(
|
|
|
111 ", ",
|
|
|
112 map { $kv{$_} . " [$_]" } @k
|
|
|
113 )
|
|
|
114 );
|
|
|
115 }else{
|
|
|
116 }
|
|
|
117
|
|
|
118 push( @getoptions, $mod_desc );
|
|
|
119
|
|
|
120 # Values to copy over: required, hidden, default, values
|
|
|
121 my %attr = ();
|
|
|
122 if ( $self->required() ) {
|
|
|
123 $attr{required} = $self->required();
|
|
|
124 }
|
|
|
125 if ( $self->hidden() ) {
|
|
|
126 $attr{hidden} = $self->hidden();
|
|
|
127 }
|
|
|
128 if ( $self->default() ) {
|
|
|
129 $attr{default} = $self->default();
|
|
|
130 }
|
|
|
131 push( @getoptions, \%attr );
|
|
|
132 return \@getoptions;
|
|
|
133 }
|
|
|
134
|
|
|
135
|
|
|
136 sub getopt_identifier {
|
|
|
137 my ($self) = @_;
|
|
|
138 if ( defined( $self->short() ) && length($self->short()) > 0 ) {
|
|
|
139 return sprintf( "%s|%s%s%s", $self->name(), $self->short(), $self->getopt_format(), ( $self->multiple() ? '@' : '' ), );
|
|
|
140 }
|
|
|
141 else {
|
|
|
142 return sprintf( "%s%s%s", $self->name(), $self->getopt_format(), ( $self->multiple() ? '@' : '' ), )
|
|
|
143
|
|
|
144 }
|
|
|
145 }
|
|
|
146
|
|
|
147
|
|
|
148 sub get_galaxy_command_identifier {
|
|
|
149 my ($self) = @_;
|
|
|
150 if($self->multiple()){
|
|
|
151 return sprintf('%s.%s', $self->get_repeat_idx_name(), $self->get_galaxy_cli_identifier());
|
|
|
152 }else{
|
|
|
153 return $self->get_galaxy_cli_identifier();
|
|
|
154 }
|
|
|
155 }
|
|
|
156
|
|
|
157
|
|
|
158 sub get_galaxy_cli_identifier {
|
|
|
159 my ($self) = @_;
|
|
|
160 return $self->name();
|
|
|
161 }
|
|
|
162
|
|
|
163
|
|
|
164 sub is_optional {
|
|
|
165 my ($self) = @_;
|
|
|
166 # Want coerced to int.
|
|
|
167 #return !$self->required();
|
|
|
168 if($self->required()){
|
|
|
169 return 0;
|
|
|
170 }else{
|
|
|
171 return 1;
|
|
|
172 }
|
|
|
173 }
|
|
|
174
|
|
|
175
|
|
|
176 sub is_optional_galaxy {
|
|
|
177 my ($self) = @_;
|
|
|
178 return $self->is_optional() ? "True" : "False";
|
|
|
179 }
|
|
|
180
|
|
|
181
|
|
|
182 sub update_index {
|
|
|
183 my ($self) = @_;
|
|
|
184 if($self->multiple()){
|
|
|
185 my $size = scalar( @{ $self->value() } );
|
|
|
186 # E.g:
|
|
|
187 # [1,2,3] , size = 3
|
|
|
188 # index = 3
|
|
|
189 # size = 3-1 = 2
|
|
|
190 # index -> 0
|
|
|
191 if ( $self->_index() ge $size - 1 ) {
|
|
|
192 $self->_index(0);
|
|
|
193 }
|
|
|
194 else {
|
|
|
195 $self->_index( $self->_index() + 1 );
|
|
|
196 }
|
|
|
197 }
|
|
|
198 }
|
|
|
199
|
|
|
200
|
|
|
201 sub reset_index {
|
|
|
202 my ($self) = @_;
|
|
|
203 $self->_index(0);
|
|
|
204 }
|
|
|
205
|
|
|
206
|
|
|
207 sub get_value {
|
|
|
208 my ($self) = @_;
|
|
|
209 if ( defined $self->value() ) {
|
|
|
210 if ( $self->multiple ) {
|
|
|
211 my @data = @{ $self->value() };
|
|
|
212 return $data[ $self->_index() ];
|
|
|
213 }
|
|
|
214 else {
|
|
|
215 return $self->value();
|
|
|
216 }
|
|
|
217 }else{
|
|
|
218 return;
|
|
|
219 }
|
|
|
220 }
|
|
|
221
|
|
|
222
|
|
|
223 sub get_default {
|
|
|
224 my ($self) = @_;
|
|
|
225 if ( defined $self->default() ) {
|
|
|
226 if ( $self->multiple ) {
|
|
|
227 my @data = @{ $self->default() };
|
|
|
228 return $data[ $self->_index() ];
|
|
|
229 }
|
|
|
230 else {
|
|
|
231 return $self->default();
|
|
|
232 }
|
|
|
233 }else{
|
|
|
234 return;
|
|
|
235 }
|
|
|
236 }
|
|
|
237
|
|
|
238
|
|
|
239
|
|
|
240 sub validate {
|
|
|
241 my ($self) = @_;
|
|
|
242 if ( $self->multiple() ) {
|
|
|
243 my $errors = 0;
|
|
|
244 if( ref($self->value()) ne 'ARRAY' ){
|
|
|
245 carp "Author specified a non-array default value for " . $self->name() . ", which allows multiple values. Script author should modify the default value to be an ArrayRef.";
|
|
|
246 }
|
|
|
247 for my $val ( @{ $self->value() } ) {
|
|
|
248 if($self->validate_individual($val) == 0){
|
|
|
249 $errors++;
|
|
|
250 }
|
|
|
251 }
|
|
|
252 # Must cast to number otherwise it returns "" which is bad since I use
|
|
|
253 # 1/0 as T/F (true = good, false = bad)
|
|
|
254 return 0+($errors == 0);
|
|
|
255 }
|
|
|
256 else {
|
|
|
257 return 0+$self->validate_individual($self->value());
|
|
|
258 }
|
|
|
259 }
|
|
|
260
|
|
|
261
|
|
|
262 sub get_repeat_idx_name {
|
|
|
263 my ($self) = @_;
|
|
|
264 return 'item';
|
|
|
265 }
|
|
|
266
|
|
|
267
|
|
|
268 sub get_repeat_name {
|
|
|
269 my ($self) = @_;
|
|
|
270 if($self->multiple()){
|
|
|
271 return sprintf('repeat_%s', $self->get_galaxy_cli_identifier());
|
|
|
272 }else{
|
|
|
273 confess "Tried to get repeat name for non-multiple item";
|
|
|
274 }
|
|
|
275 }
|
|
|
276
|
|
|
277
|
|
|
278 sub handle_possible_galaxy_input_repeat_start {
|
|
|
279 my ($self, $xml_writer ) = @_;
|
|
|
280 if ( $self->multiple() ) {
|
|
|
281 my $title = $self->get_galaxy_cli_identifier();
|
|
|
282 $title =~ s/_/ /g;
|
|
|
283 # Convert To Title Case (http://www.davekb.com/browse_programming_tips:perl_title_case:txt)
|
|
|
284 $title =~ s/(\w+)/\u\L$1/g;
|
|
|
285 $xml_writer->startTag(
|
|
|
286 'repeat',
|
|
|
287 'name' => $self->get_repeat_name(),
|
|
|
288 'title' => $title,
|
|
|
289 );
|
|
|
290 }
|
|
|
291 }
|
|
|
292
|
|
|
293
|
|
|
294 sub handle_possible_galaxy_input_repeat_end {
|
|
|
295 my ($self, $xml_writer ) = @_;
|
|
|
296 if ( $self->multiple() ) {
|
|
|
297 $xml_writer->endTag('repeat');
|
|
|
298 }
|
|
|
299 }
|
|
|
300
|
|
|
301
|
|
|
302
|
|
|
303 sub handle_possible_galaxy_command_repeat_start {
|
|
|
304 my ( $self ) = @_;
|
|
|
305 if($self->multiple()){
|
|
|
306 return sprintf("#for \$%s in \$%s:\n",
|
|
|
307 $self->get_repeat_idx_name(),
|
|
|
308 $self->get_repeat_name()
|
|
|
309 );
|
|
|
310 }else{
|
|
|
311 return '';
|
|
|
312 }
|
|
|
313 }
|
|
|
314
|
|
|
315
|
|
|
316 sub handle_possible_galaxy_command_repeat_end {
|
|
|
317 my ( $self ) = @_;
|
|
|
318 if($self->multiple()){
|
|
|
319 return "#end for\n";
|
|
|
320 }else{
|
|
|
321 return '';
|
|
|
322 }
|
|
|
323 }
|
|
|
324
|
|
|
325 sub get_default_input_parameters {
|
|
|
326 my ( $self, $type ) = @_;
|
|
|
327 my %params = (
|
|
|
328 name => $self->get_galaxy_cli_identifier(),
|
|
|
329 optional => $self->is_optional_galaxy(),
|
|
|
330 label => $self->get_galaxy_cli_identifier(),
|
|
|
331 help => $self->description(),
|
|
|
332 type => $type,
|
|
|
333 );
|
|
|
334
|
|
|
335 # Multiple values would return ARRAY(0xAAAAAAA) locations, so we have to
|
|
|
336 # handle those semi-intelligently until galaxy can handle default values
|
|
|
337 # for repeats
|
|
|
338 if($self->multiple() && defined $self->default()){
|
|
|
339 if(ref($self->default()) ne 'ARRAY'){
|
|
|
340 carp "Author specified a non-array default value for " . $self->name() . ", which allows multiple values. Script author should modify the default value to be an ArrayRef.";
|
|
|
341 }
|
|
|
342 $params{value} = ${$self->default}[0];
|
|
|
343 }elsif(!$self->multiple() && defined $self->default()){
|
|
|
344 $params{value} = $self->default();
|
|
|
345 }
|
|
|
346
|
|
|
347 return %params;
|
|
|
348 }
|
|
|
349
|
|
|
350 no Moose::Role;
|
|
|
351
|
|
|
352 1;
|
|
|
353
|
|
|
354 __END__
|
|
|
355
|
|
|
356 =pod
|
|
|
357
|
|
|
358 =encoding UTF-8
|
|
|
359
|
|
|
360 =head1 NAME
|
|
|
361
|
|
|
362 CPT::Parameter
|
|
|
363
|
|
|
364 =head1 VERSION
|
|
|
365
|
|
|
366 version 1.99.4
|
|
|
367
|
|
|
368 =head2 galaxy_command
|
|
|
369
|
|
|
370 $file_param->galaxy_command(); # where $file_param is a CPT::Parameter::*
|
|
|
371
|
|
|
372 Returns the portion of the command used in the <command/> block in galaxy XML files
|
|
|
373
|
|
|
374 =head2 getOptionsArray
|
|
|
375
|
|
|
376 When called on a CPT::Parameter::* object, it will collapse the object into a GetOpt::Long compatible array
|
|
|
377
|
|
|
378 =head2 getopt_identifier
|
|
|
379
|
|
|
380 Used for backwards compatability with existing defaults => { 'file|f=s' => "Blah" } format
|
|
|
381
|
|
|
382 =head2 get_galaxy_identifier
|
|
|
383
|
|
|
384 Returns the identifier associated with a given variable. This identifier is what the Cheetah template knows the variable as (given the correct context).
|
|
|
385
|
|
|
386 For non-multiple variables it should be the name of the variable.
|
|
|
387
|
|
|
388 For multiple variables it will reference the repeat item name and then the variable name (e.g., C< $item.label >)
|
|
|
389
|
|
|
390 =head2 get_galaxy_cli_identifier
|
|
|
391
|
|
|
392 Returns the command line identifier (i.e., the command line flag) associated
|
|
|
393 with a given parameter. For a `--format` flag, this would return "format".
|
|
|
394 This should work out of the box, as CLI parameters have the same name as we
|
|
|
395 specify them with (even if they're repeated)
|
|
|
396
|
|
|
397 =head2 is_optional
|
|
|
398
|
|
|
399 If required, it is NOT optional; If not reqiured, it IS optional
|
|
|
400
|
|
|
401 =head2 is_optional_galaxy
|
|
|
402
|
|
|
403 Returns is_optional() as "True" or "False" for convenience and reduced code duplication
|
|
|
404
|
|
|
405 =head2 update_index
|
|
|
406
|
|
|
407 Convenience method to increment the index. This wraps around.
|
|
|
408
|
|
|
409 =head2 reset_index
|
|
|
410
|
|
|
411 convenience method to zero the index (i.e., the next get_value request will start at the beginning again)
|
|
|
412
|
|
|
413 =head2 get_value
|
|
|
414
|
|
|
415 Returns the value in the current index.
|
|
|
416
|
|
|
417 =head2 get_default
|
|
|
418
|
|
|
419 Returns the default in the current index. Something to note, please bear in
|
|
|
420 mind this you are trying to access an array based on an index which wraps
|
|
|
421 according to value() not according to default(). This means you may not reach
|
|
|
422 the end of default/reach over the end of default depending on how many values
|
|
|
423 the user actually passes
|
|
|
424
|
|
|
425 =head2 validate
|
|
|
426
|
|
|
427 Validation logic was eventually moved out here, as the logic for validaton is
|
|
|
428 identical everywhere, and requires slightly different behaviour based on
|
|
|
429 wheterh or not it's a single/multiple valued item.
|
|
|
430
|
|
|
431 =head2 get_repeat_idx_name
|
|
|
432
|
|
|
433 Function to obtain the name of the item as it is called inside the repeat. This
|
|
|
434 is necessary to know which variable we are referring to within a loop.
|
|
|
435
|
|
|
436 =head2 get_repeat_name
|
|
|
437
|
|
|
438 Function to obtain the name of the repeat. It is necessary that this is used
|
|
|
439 identically in the command section as well as in the input section.
|
|
|
440
|
|
|
441 =head2 handle_possible_galaxy_input_repeat_start
|
|
|
442
|
|
|
443 If the feature is repeated, this should automatically handle the start of that
|
|
|
444 repeat
|
|
|
445
|
|
|
446 =head2 handle_possible_galaxy_input_repeat_end
|
|
|
447
|
|
|
448 If the feature is repeated, this should automatically handle the end of that
|
|
|
449 repeat
|
|
|
450
|
|
|
451 =head2 handle_possible_galaxy_command_repeat_start
|
|
|
452
|
|
|
453 If the feature is repeated, this should automatically handle the start of that
|
|
|
454 repeat with a
|
|
|
455
|
|
|
456 #for $item in $repeat_name:
|
|
|
457
|
|
|
458 =head2 handle_possible_galaxy_command_repeat_end
|
|
|
459
|
|
|
460 If the feature is repeated, this should automatically handle the end of that
|
|
|
461 repeat with
|
|
|
462
|
|
|
463 #end for
|
|
|
464
|
|
|
465 =head1 AUTHOR
|
|
|
466
|
|
|
467 Eric Rasche <rasche.eric@yandex.ru>
|
|
|
468
|
|
|
469 =head1 COPYRIGHT AND LICENSE
|
|
|
470
|
|
|
471 This software is Copyright (c) 2014 by Eric Rasche.
|
|
|
472
|
|
|
473 This is free software, licensed under:
|
|
|
474
|
|
|
475 The GNU General Public License, Version 3, June 2007
|
|
|
476
|
|
|
477 =cut
|
