9 A parser
for PipeConfig files that understands how and when to substitute $self->
o() expressions.
13 Copyright [1999-2015] Wellcome Trust Sanger Institute and the EMBL-European Bioinformatics Institute
14 Copyright [2016-2022] EMBL-European Bioinformatics Institute
16 Licensed under the Apache License,
Version 2.0 (the
"License"); you may not use
this file except in compliance with the License.
17 You may obtain a copy of the License at
21 Unless required by applicable law or agreed to in writing, software distributed under the License
22 is distributed on an
"AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
23 See the License
for the specific language governing permissions and limitations under the License.
27 Please subscribe to the
Hive mailing list: http:
32 package Bio::EnsEMBL::Hive::DependentOptions;
36 use Getopt::Long qw(:config pass_through no_auto_abbrev);
44 my $self = bless { @_ }, $class;
50 sub use_cases { # getter/setter
for the list of methods from where $self->o() is called
54 $self->{_use_cases} = shift @_;
56 return $self->{_use_cases} || die
"use_cases() has to be set before using";
60 sub load_cmdline_options {
62 my $expected = shift @_;
63 my $target = shift @_ || {};
64 my $check_extra = shift @_;
66 local @ARGV = @ARGV; # make
this function reenterable by forbidding it to modify the original parameters
68 # Enable passing of long commandline options by file. 69 # Example: perl init_pipeline.pl B::E::H::P::Whaterver_conf @my_file.conf 70 # See CPAN Getopt::ArgvFile for more info. 71 my $getopt_argvfile_loaded = 0;
72 eval {require Getopt::ArgvFile; Getopt::ArgvFile::argvFile(); $getopt_argvfile_loaded = 1; };
75 map { my $ref_type = ref($expected->{$_}); $_=~m{\!$} ? $_ : ($ref_type eq
'HASH') ?
"$_=s%" : ($ref_type eq
'ARRAY') ?
"$_=s@" :
"$_=s" } keys %$expected
78 if ($check_extra && scalar(@ARGV)) {
79 warn
"These command-line arguments were not used: ", join(
" ", @ARGV),
"\n";
80 if (!$getopt_argvfile_loaded && scalar(grep {$_ =~ /^@/} @ARGV)) {
81 die
"Getopt:ArgvFile is not installed on your system. Arguments starting with '\@' could not be processed.\n";
89 sub root { # getter/setter
for the root
93 $self->{_root} = shift @_;
95 return $self->{_root} ||= {};
99 sub is_fully_substituted_string {
101 my $input = shift @_;
103 return (!defined($input) || $input !~ /#\:.+?\:#/);
107 sub is_fully_substituted_structure {
109 my $input = shift @_;
111 unless(my $ref_type = ref($input)) {
113 return $self->is_fully_substituted_string($input);
115 } elsif($ref_type eq
'HASH') {
116 foreach my $value (values %$input) {
117 unless($self->is_fully_substituted_structure($value)) {
121 } elsif($ref_type eq
'ARRAY') {
122 foreach my $element (@$input) {
123 unless($self->is_fully_substituted_structure($element)) {
133 my ($self, $hash_to, $source, $prefix) = @_;
135 if(ref($source) eq
'HASH') {
136 while(my ($key, $value) = each %$source) {
137 my $hash_element_prefix = ($prefix ?
"$prefix->" :
'') .
"{'$key'}";
139 $self->hash_leaves($hash_to, $value, $hash_element_prefix);
141 } elsif(ref($source) eq
'ARRAY') {
142 foreach my $index (0..scalar(@$source)-1) {
143 my $element = $source->[$index];
144 my $array_element_prefix = ($prefix ?
"$prefix->" :
'') .
"[$index]";
146 $self->hash_leaves($hash_to, $element, $array_element_prefix);
148 } elsif(!$self->is_fully_substituted_string($source)) {
149 $source =~ m/#\:subst (.+?)\:#/;
150 $hash_to->{$prefix} = $prefix =~ /
'$1'/ ? undef : $1;
160 my $ptr = $self->root();
164 while(defined(my $option_syll = shift @_)) {
165 push @syll_seen, $option_syll;
167 if( exists($ptr->{$option_syll})
168 and ((ref($ptr->{$option_syll}) eq
'HASH') or $self->is_fully_substituted_string( $ptr->{$option_syll} ))
170 $ptr = $ptr->{$option_syll}; # just descend one level
172 $ptr = $ptr->{$option_syll} = {}; # force intermediate level vivification, even
if it overwrites a fully_substituted_string
174 $ptr = $ptr->{$option_syll} =
"#:subst ".join(
'->',@syll_seen).
":#"; # force leaf level vivification
185 my $ref_type = ref($$ref);
187 if($ref_type eq
'HASH') {
188 foreach my $value (values %$$ref) {
189 $self->substitute( \$value );
191 } elsif($ref_type eq
'ARRAY') {
192 foreach my $value (@$$ref) {
193 $self->substitute( \$value );
195 } elsif( !$ref_type and defined($$ref) ) {
197 if($$ref =~ /^#\:subst ([^:]+)\:#$/) { #
if the given
string is one complete substitution, we don
't want to force the output into a string 198 $$ref = $self->o(split/->/,$1); 200 $$ref =~ s{(?:#\:subst (.+?)\:#)}{$self->o(split(/->/,$1))}eg; 207 sub merge_from_rules { 212 my $ref_type = ref($$top); 216 } elsif($ref_type eq 'HASH
') { 217 foreach my $key (keys %$from) { 218 $self->merge_from_rules( $from->{$key}, \$$top->{$key} ); 223 sub process_options { 226 my $definitely_used_options = $self->root(); 228 # dry-run of these methods allows us to collect definitely_used_options 229 foreach my $method (@{ $self->use_cases() }) { 233 my $possibly_used_options = { 'ENV
' => \%ENV }; 234 $self->root( $possibly_used_options ); 236 # the first run of this method allows us to collect possibly_used_options 237 my $rules = $self->default_options(); 239 $self->load_cmdline_options( { %$definitely_used_options, %$possibly_used_options }, $rules, "check_extra" ); 241 $self->root( $definitely_used_options ); 248 foreach my $key (keys %$definitely_used_options) { 249 if(exists $rules->{$key}) { 250 my $value = $self->substitute( \$rules->{$key} ); 252 # it has to be intelligently (recursively, on by-element basis) merged back into the tree under $self->o($key): 253 $self->merge_from_rules( $value, \$self->root->{$key} ); 255 if($self->is_fully_substituted_structure($value)) { 256 #warn "Resolved rule: $key -> ".stringify($value)."\n"; 258 #warn "Unresolved rule: $key -> ".stringify($value)."\n"; 264 #warn "=======================[$rules_to_go rules to go; $attempts attempts to go]=================\n\n"; 265 #warn " definitely_used_options{} contains: ".stringify($definitely_used_options)."\n"; 266 } while($rules_to_go and $attempts); 268 #warn "=======================[out of the substitution loop]=================\n\n"; 270 my $missing_options = $self->hash_leaves( {}, $self->root, '' ); 272 if(scalar(keys %$missing_options)) { 273 my @missing_keys = grep {!defined $missing_options->{$_}} (keys %$missing_options); 274 my @incomplete_keys = grep {defined $missing_options->{$_}} (keys %$missing_options); 276 warn "The following options are missing:\n"; 277 print "\t$_\n" for sort @missing_keys; 279 if (@incomplete_keys) { 280 warn "The following options are incomplete:\n"; 281 print "\t$_ needs '".($missing_options->{$_})."'\n" for sort @incomplete_keys; 285 #warn "Done parsing options!\n";