1 | # ------------------------------------------------------------------------------ |
---|
2 | # Copyright (C) 2006-2021 British Crown (Met Office) & Contributors. |
---|
3 | # |
---|
4 | # This file is part of FCM, tools for managing and building source code. |
---|
5 | # |
---|
6 | # FCM is free software: you can redistribute it and/or modify |
---|
7 | # it under the terms of the GNU General Public License as published by |
---|
8 | # the Free Software Foundation, either version 3 of the License, or |
---|
9 | # (at your option) any later version. |
---|
10 | # |
---|
11 | # FCM is distributed in the hope that it will be useful, |
---|
12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
14 | # GNU General Public License for more details. |
---|
15 | # |
---|
16 | # You should have received a copy of the GNU General Public License |
---|
17 | # along with FCM. If not, see <http://www.gnu.org/licenses/>. |
---|
18 | # ------------------------------------------------------------------------------ |
---|
19 | # NAME |
---|
20 | # FCM1::ConfigSystem |
---|
21 | # |
---|
22 | # DESCRIPTION |
---|
23 | # This is the base class for FCM systems that are based on inherited |
---|
24 | # configuration files, e.g. the extract and the build systems. |
---|
25 | # |
---|
26 | # ------------------------------------------------------------------------------ |
---|
27 | |
---|
28 | package FCM1::ConfigSystem; |
---|
29 | use base qw{FCM1::Base}; |
---|
30 | |
---|
31 | use strict; |
---|
32 | use warnings; |
---|
33 | |
---|
34 | use FCM1::CfgFile; |
---|
35 | use FCM1::CfgLine; |
---|
36 | use FCM1::Dest; |
---|
37 | use FCM1::Util qw{expand_tilde e_report w_report}; |
---|
38 | use Sys::Hostname qw{hostname}; |
---|
39 | |
---|
40 | # List of property methods for this class |
---|
41 | my @scalar_properties = ( |
---|
42 | 'cfg', # configuration file |
---|
43 | 'cfg_methods', # list of sub-methods for parse_cfg |
---|
44 | 'cfg_prefix', # optional prefix in configuration declaration |
---|
45 | 'dest', # destination for output |
---|
46 | 'inherit', # list of inherited configurations |
---|
47 | 'inherited', # list of inheritance hierarchy |
---|
48 | 'type', # system type |
---|
49 | ); |
---|
50 | |
---|
51 | # ------------------------------------------------------------------------------ |
---|
52 | # SYNOPSIS |
---|
53 | # $obj = FCM1::ConfigSystem->new; |
---|
54 | # |
---|
55 | # DESCRIPTION |
---|
56 | # This method constructs a new instance of the FCM1::ConfigSystem class. |
---|
57 | # ------------------------------------------------------------------------------ |
---|
58 | |
---|
59 | sub new { |
---|
60 | my $this = shift; |
---|
61 | my %args = @_; |
---|
62 | my $class = ref $this || $this; |
---|
63 | |
---|
64 | my $self = FCM1::Base->new (%args); |
---|
65 | |
---|
66 | $self->{$_} = undef for (@scalar_properties); |
---|
67 | |
---|
68 | bless $self, $class; |
---|
69 | |
---|
70 | # List of sub-methods for parse_cfg |
---|
71 | $self->cfg_methods ([qw/header inherit dest/]); |
---|
72 | |
---|
73 | return $self; |
---|
74 | } |
---|
75 | |
---|
76 | # ------------------------------------------------------------------------------ |
---|
77 | # SYNOPSIS |
---|
78 | # $value = $obj->X; |
---|
79 | # $obj->X ($value); |
---|
80 | # |
---|
81 | # DESCRIPTION |
---|
82 | # Details of these properties are explained in @scalar_properties. |
---|
83 | # ------------------------------------------------------------------------------ |
---|
84 | |
---|
85 | for my $name (@scalar_properties) { |
---|
86 | no strict 'refs'; |
---|
87 | |
---|
88 | *$name = sub { |
---|
89 | my $self = shift; |
---|
90 | |
---|
91 | # Argument specified, set property to specified argument |
---|
92 | if (@_) { |
---|
93 | $self->{$name} = $_[0]; |
---|
94 | } |
---|
95 | |
---|
96 | # Default value for property |
---|
97 | if (not defined $self->{$name}) { |
---|
98 | if ($name eq 'cfg') { |
---|
99 | # New configuration file |
---|
100 | $self->{$name} = FCM1::CfgFile->new (TYPE => $self->type); |
---|
101 | |
---|
102 | } elsif ($name =~ /^(?:cfg_methods|inherit|inherited)$/) { |
---|
103 | # Reference to an array |
---|
104 | $self->{$name} = []; |
---|
105 | |
---|
106 | } elsif ($name eq 'cfg_prefix' or $name eq 'type') { |
---|
107 | # Reference to an array |
---|
108 | $self->{$name} = ''; |
---|
109 | |
---|
110 | } elsif ($name eq 'dest') { |
---|
111 | # New destination |
---|
112 | $self->{$name} = FCM1::Dest->new (TYPE => $self->type); |
---|
113 | } |
---|
114 | } |
---|
115 | |
---|
116 | return $self->{$name}; |
---|
117 | } |
---|
118 | } |
---|
119 | |
---|
120 | # ------------------------------------------------------------------------------ |
---|
121 | # SYNOPSIS |
---|
122 | # ($rc, $out_of_date) = $obj->check_cache (); |
---|
123 | # |
---|
124 | # DESCRIPTION |
---|
125 | # This method returns $rc = 1 on success or undef on failure. It returns |
---|
126 | # $out_of_date = 1 if current cache file is out of date relative to those in |
---|
127 | # inherited runs or 0 otherwise. |
---|
128 | # ------------------------------------------------------------------------------ |
---|
129 | |
---|
130 | sub check_cache { |
---|
131 | my $self = shift; |
---|
132 | |
---|
133 | my $rc = 1; |
---|
134 | my $out_of_date = 0; |
---|
135 | |
---|
136 | if (@{ $self->inherit } and -f $self->dest->cache) { |
---|
137 | # Get modification time of current cache file |
---|
138 | my $cur_mtime = (stat ($self->dest->cache))[9]; |
---|
139 | |
---|
140 | # Compare with modification times of inherited cache files |
---|
141 | for my $use (@{ $self->inherit }) { |
---|
142 | next unless -f $use->dest->cache; |
---|
143 | my $use_mtime = (stat ($use->dest->cache))[9]; |
---|
144 | $out_of_date = 1 if $use_mtime > $cur_mtime; |
---|
145 | } |
---|
146 | } |
---|
147 | |
---|
148 | return ($rc, $out_of_date); |
---|
149 | } |
---|
150 | |
---|
151 | # ------------------------------------------------------------------------------ |
---|
152 | # SYNOPSIS |
---|
153 | # $rc = $obj->check_lock (); |
---|
154 | # |
---|
155 | # DESCRIPTION |
---|
156 | # This method returns true if no lock is found in the destination or if the |
---|
157 | # locks found are allowed. |
---|
158 | # ------------------------------------------------------------------------------ |
---|
159 | |
---|
160 | sub check_lock { |
---|
161 | my $self = shift; |
---|
162 | |
---|
163 | # Check all types of locks |
---|
164 | for my $method (@FCM1::Dest::lockfiles) { |
---|
165 | my $lock = $self->dest->$method; |
---|
166 | |
---|
167 | # Check whether lock exists |
---|
168 | next unless -e $lock; |
---|
169 | |
---|
170 | # Check whether this lock is allowed |
---|
171 | next if $self->check_lock_is_allowed ($lock); |
---|
172 | |
---|
173 | # Throw error if a lock exists |
---|
174 | w_report 'ERROR: ', $lock, ': lock file exists,'; |
---|
175 | w_report ' ', $self->dest->rootdir, ': destination is busy.'; |
---|
176 | return; |
---|
177 | } |
---|
178 | |
---|
179 | return 1; |
---|
180 | } |
---|
181 | |
---|
182 | # ------------------------------------------------------------------------------ |
---|
183 | # SYNOPSIS |
---|
184 | # $rc = $self->check_lock_is_allowed ($lock); |
---|
185 | # |
---|
186 | # DESCRIPTION |
---|
187 | # This method returns true if it is OK for $lock to exist in the destination. |
---|
188 | # ------------------------------------------------------------------------------ |
---|
189 | |
---|
190 | sub check_lock_is_allowed { |
---|
191 | my ($self, $lock) = @_; |
---|
192 | |
---|
193 | # Disallow all types of locks by default |
---|
194 | return 0; |
---|
195 | } |
---|
196 | |
---|
197 | # ------------------------------------------------------------------------------ |
---|
198 | # SYNOPSIS |
---|
199 | # $rc = $self->compare_setting ( |
---|
200 | # METHOD_LIST => \@method_list, |
---|
201 | # [METHOD_ARGS => \@method_args,] |
---|
202 | # [CACHEBASE => $cachebase,] |
---|
203 | # ); |
---|
204 | # |
---|
205 | # DESCRIPTION |
---|
206 | # This method gets settings from the previous cache and updates the current. |
---|
207 | # |
---|
208 | # METHOD |
---|
209 | # The method returns true on success. @method_list must be a list of method |
---|
210 | # names for processing the cached lines in the previous run. If an existing |
---|
211 | # cache exists, its content is read into $old_lines, which is a list of |
---|
212 | # FCM1::CfgLine objects. Otherwise, $old_lines is set to undef. If $cachebase |
---|
213 | # is set, it is used for as the cache basename. Otherwise, the default for |
---|
214 | # the current system is used. It calls each method in the @method_list using |
---|
215 | # $self->$method ($old_lines, @method_args), which should return a |
---|
216 | # two-element list. The first element should be a return code (1 for out of |
---|
217 | # date, 0 for up to date and undef for failure). The second element should be |
---|
218 | # a reference to a list of FCM1::CfgLine objects for the output. |
---|
219 | # ------------------------------------------------------------------------------ |
---|
220 | |
---|
221 | sub compare_setting { |
---|
222 | my ($self, %args) = @_; |
---|
223 | |
---|
224 | my @method_list = exists ($args{METHOD_LIST}) ? @{ $args{METHOD_LIST} } : (); |
---|
225 | my @method_args = exists ($args{METHOD_ARGS}) ? @{ $args{METHOD_ARGS} } : (); |
---|
226 | my $cachebase = exists ($args{CACHEBASE}) ? $args{CACHEBASE} : undef; |
---|
227 | |
---|
228 | my $rc = 1; |
---|
229 | |
---|
230 | # Read cache if the file exists |
---|
231 | # ---------------------------------------------------------------------------- |
---|
232 | my $cache = $cachebase |
---|
233 | ? File::Spec->catfile ($self->dest->cachedir, $cachebase) |
---|
234 | : $self->dest->cache; |
---|
235 | my @in_caches = (); |
---|
236 | if (-f $cache) { |
---|
237 | push @in_caches, $cache; |
---|
238 | |
---|
239 | } else { |
---|
240 | for my $use (@{ $self->inherit }) { |
---|
241 | my $use_cache = $cachebase |
---|
242 | ? File::Spec->catfile ($use->dest->cachedir, $cachebase) |
---|
243 | : $use->dest->cache; |
---|
244 | push @in_caches, $use_cache if -f $use_cache; |
---|
245 | } |
---|
246 | } |
---|
247 | |
---|
248 | my $old_lines = undef; |
---|
249 | for my $in_cache (@in_caches) { |
---|
250 | next unless -f $in_cache; |
---|
251 | my $cfg = FCM1::CfgFile->new (SRC => $in_cache); |
---|
252 | |
---|
253 | if ($cfg->read_cfg) { |
---|
254 | $old_lines = [] if not defined $old_lines; |
---|
255 | push @$old_lines, @{ $cfg->lines }; |
---|
256 | } |
---|
257 | } |
---|
258 | |
---|
259 | # Call methods in @method_list to see if cache is out of date |
---|
260 | # ---------------------------------------------------------------------------- |
---|
261 | my @new_lines = (); |
---|
262 | my $out_of_date = 0; |
---|
263 | for my $method (@method_list) { |
---|
264 | my ($return, $lines); |
---|
265 | ($return, $lines) = $self->$method ($old_lines, @method_args) if $rc; |
---|
266 | |
---|
267 | if (defined $return) { |
---|
268 | # Method succeeded |
---|
269 | push @new_lines, @$lines; |
---|
270 | $out_of_date = 1 if $return; |
---|
271 | |
---|
272 | } else { |
---|
273 | # Method failed |
---|
274 | $rc = $return; |
---|
275 | last; |
---|
276 | } |
---|
277 | } |
---|
278 | |
---|
279 | # Update the cache in the current run |
---|
280 | # ---------------------------------------------------------------------------- |
---|
281 | if ($rc) { |
---|
282 | if (@{ $self->inherited } and $out_of_date) { |
---|
283 | # If this is an inherited configuration, the cache must not be changed |
---|
284 | w_report 'ERROR: ', $self->cfg->src, |
---|
285 | ': inherited configuration does not match with its cache.'; |
---|
286 | $rc = undef; |
---|
287 | |
---|
288 | } elsif ((not -f $cache) or $out_of_date) { |
---|
289 | my $cfg = FCM1::CfgFile->new; |
---|
290 | $cfg->lines ([sort {$a->label cmp $b->label} @new_lines]); |
---|
291 | $rc = $cfg->print_cfg ($cache, 1); |
---|
292 | } |
---|
293 | } |
---|
294 | |
---|
295 | return $rc; |
---|
296 | } |
---|
297 | |
---|
298 | # ------------------------------------------------------------------------------ |
---|
299 | # SYNOPSIS |
---|
300 | # ($changed_hash_ref, $new_lines_array_ref) = |
---|
301 | # $self->compare_setting_in_config($prefix, \@old_lines); |
---|
302 | # |
---|
303 | # DESCRIPTION |
---|
304 | # This method compares old and current settings for a specified item. |
---|
305 | # |
---|
306 | # METHOD |
---|
307 | # This method does two things. |
---|
308 | # |
---|
309 | # It uses the current configuration for the $prefix item to generate a list of |
---|
310 | # new FCM1::CfgLine objects (which is returned as a reference in the second |
---|
311 | # element of the returned list). |
---|
312 | # |
---|
313 | # The values of the old lines are then compared with those of the new lines. |
---|
314 | # Any settings that are changed are stored in a hash, which is returned as a |
---|
315 | # reference in the first element of the returned list. The key of the hash is |
---|
316 | # the name of the changed setting, and the value is the value of the new |
---|
317 | # setting or undef if the setting no longer exists. |
---|
318 | # |
---|
319 | # ARGUMENTS |
---|
320 | # $prefix - the name of an item in FCM1::Config to be compared |
---|
321 | # @old_lines - a list of FCM1::CfgLine objects containing the old settings |
---|
322 | # ------------------------------------------------------------------------------ |
---|
323 | |
---|
324 | sub compare_setting_in_config { |
---|
325 | my ($self, $prefix, $old_lines_ref) = @_; |
---|
326 | |
---|
327 | my %changed = %{$self->setting($prefix)}; |
---|
328 | my (@new_lines, %new_val_of); |
---|
329 | while (my ($key, $val) = each(%changed)) { |
---|
330 | $new_val_of{$key} = (ref($val) eq 'ARRAY' ? join(q{ }, sort(@{$val})) : $val); |
---|
331 | push(@new_lines, FCM1::CfgLine->new( |
---|
332 | LABEL => $prefix . $FCM1::Config::DELIMITER . $key, |
---|
333 | VALUE => $new_val_of{$key}, |
---|
334 | )); |
---|
335 | } |
---|
336 | |
---|
337 | if (defined($old_lines_ref)) { |
---|
338 | my %old_val_of |
---|
339 | = map {($_->label_from_field(1), $_->value())} # converts into a hash |
---|
340 | grep {$_->label_starts_with($prefix)} # gets relevant lines |
---|
341 | @{$old_lines_ref}; |
---|
342 | |
---|
343 | while (my ($key, $val) = each(%old_val_of)) { |
---|
344 | if (exists($changed{$key})) { |
---|
345 | if ($val eq $new_val_of{$key}) { # no change from old to new |
---|
346 | delete($changed{$key}); |
---|
347 | } |
---|
348 | } |
---|
349 | else { # exists in old but not in new |
---|
350 | $changed{$key} = undef; |
---|
351 | } |
---|
352 | } |
---|
353 | } |
---|
354 | |
---|
355 | return (\%changed, \@new_lines); |
---|
356 | } |
---|
357 | |
---|
358 | # ------------------------------------------------------------------------------ |
---|
359 | # SYNOPSIS |
---|
360 | # $rc = $obj->invoke ([CLEAN => 1, ]%args); |
---|
361 | # |
---|
362 | # DESCRIPTION |
---|
363 | # This method invokes the system. If CLEAN is set to true, it will only parse |
---|
364 | # the configuration and set up the destination, but will not invoke the |
---|
365 | # system. See the invoke_setup_dest and the invoke_system methods for list of |
---|
366 | # other arguments in %args. |
---|
367 | # ------------------------------------------------------------------------------ |
---|
368 | |
---|
369 | sub invoke { |
---|
370 | my $self = shift; |
---|
371 | my %args = @_; |
---|
372 | |
---|
373 | # Print diagnostic at beginning of run |
---|
374 | # ---------------------------------------------------------------------------- |
---|
375 | # Name of the system |
---|
376 | (my $name = ref ($self)) =~ s/^FCM1:://; |
---|
377 | |
---|
378 | # Print start time on system run, if verbose is true |
---|
379 | my $date = localtime; |
---|
380 | print $name, ' command started on ', $date, '.', "\n" |
---|
381 | if $self->verbose; |
---|
382 | |
---|
383 | # Start time (seconds since epoch) |
---|
384 | my $otime = time; |
---|
385 | |
---|
386 | # Parse the configuration file |
---|
387 | my $rc = $self->invoke_stage ('Parse configuration', 'parse_cfg'); |
---|
388 | |
---|
389 | # Set up the destination |
---|
390 | $rc = $self->invoke_stage ('Setup destination', 'invoke_setup_dest', %args) |
---|
391 | if $rc; |
---|
392 | |
---|
393 | # Invoke the system |
---|
394 | # ---------------------------------------------------------------------------- |
---|
395 | $rc = $self->invoke_system (%args) if $rc and not $args{CLEAN}; |
---|
396 | |
---|
397 | # Remove empty directories |
---|
398 | $rc = $self->dest->clean (MODE => 'EMPTY') if $rc; |
---|
399 | |
---|
400 | # Print diagnostic at end of run |
---|
401 | # ---------------------------------------------------------------------------- |
---|
402 | # Print lapse time at the end, if verbose is true |
---|
403 | if ($self->verbose) { |
---|
404 | my $total = time - $otime; |
---|
405 | my $s_str = $total > 1 ? 'seconds' : 'second'; |
---|
406 | print '->TOTAL: ', $total, ' ', $s_str, "\n"; |
---|
407 | } |
---|
408 | |
---|
409 | # Report end of system run |
---|
410 | $date = localtime; |
---|
411 | if ($rc) { |
---|
412 | # Success |
---|
413 | print $name, ' command finished on ', $date, '.', "\n" |
---|
414 | if $self->verbose; |
---|
415 | |
---|
416 | } else { |
---|
417 | # Failure |
---|
418 | e_report $name, ' failed on ', $date, '.'; |
---|
419 | } |
---|
420 | |
---|
421 | return $rc; |
---|
422 | } |
---|
423 | |
---|
424 | # ------------------------------------------------------------------------------ |
---|
425 | # SYNOPSIS |
---|
426 | # $rc = $obj->invoke_setup_dest ([CLEAN|FULL => 1], [IGNORE_LOCK => 1]); |
---|
427 | # |
---|
428 | # DESCRIPTION |
---|
429 | # This method sets up the destination and returns true on success. |
---|
430 | # |
---|
431 | # ARGUMENTS |
---|
432 | # CLEAN|FULL - If set to "true", set up the system in "clean|full" mode. |
---|
433 | # Sub-directories and files in the root directory created by |
---|
434 | # the previous invocation of the system will be removed. If |
---|
435 | # not set, the default is to run in "incremental" mode. |
---|
436 | # IGNORE_LOCK - If set to "true", it ignores any lock files that may exist in |
---|
437 | # the destination root directory. |
---|
438 | # ------------------------------------------------------------------------------ |
---|
439 | |
---|
440 | sub invoke_setup_dest { |
---|
441 | my $self = shift; |
---|
442 | my %args = @_; |
---|
443 | |
---|
444 | # Set up destination |
---|
445 | # ---------------------------------------------------------------------------- |
---|
446 | # Print destination in verbose mode |
---|
447 | if ($self->verbose()) { |
---|
448 | printf( |
---|
449 | "Destination: %s@%s:%s\n", |
---|
450 | scalar(getpwuid($<)), |
---|
451 | hostname(), |
---|
452 | $self->dest()->rootdir(), |
---|
453 | ); |
---|
454 | } |
---|
455 | |
---|
456 | my $rc = 1; |
---|
457 | my $out_of_date = 0; |
---|
458 | |
---|
459 | # Check whether lock exists in the destination root |
---|
460 | $rc = $self->check_lock if $rc and not $args{IGNORE_LOCK}; |
---|
461 | |
---|
462 | # Check whether current cache is out of date relative to the inherited ones |
---|
463 | ($rc, $out_of_date) = $self->check_cache if $rc; |
---|
464 | |
---|
465 | # Remove sub-directories and files in destination in "full" mode |
---|
466 | $rc = $self->dest->clean (MODE => 'ALL') |
---|
467 | if $rc and ($args{FULL} or $args{CLEAN} or $out_of_date); |
---|
468 | |
---|
469 | # Create build root directory if necessary |
---|
470 | $rc = $self->dest->create if $rc; |
---|
471 | |
---|
472 | # Set a lock in the destination root |
---|
473 | $rc = $self->dest->set_lock if $rc; |
---|
474 | |
---|
475 | # Generate an as-parsed configuration file |
---|
476 | $self->cfg->print_cfg ($self->dest->parsedcfg); |
---|
477 | |
---|
478 | return $rc; |
---|
479 | } |
---|
480 | |
---|
481 | # ------------------------------------------------------------------------------ |
---|
482 | # SYNOPSIS |
---|
483 | # $rc = $self->invoke_stage ($name, $method, @args); |
---|
484 | # |
---|
485 | # DESCRIPTION |
---|
486 | # This method invokes a named stage of the system, where $name is the name of |
---|
487 | # the stage, $method is the name of the method for invoking the stage and |
---|
488 | # @args are the arguments to the &method. |
---|
489 | # ------------------------------------------------------------------------------ |
---|
490 | |
---|
491 | sub invoke_stage { |
---|
492 | my ($self, $name, $method, @args) = @_; |
---|
493 | |
---|
494 | # Print diagnostic at beginning of a stage |
---|
495 | print '->', $name, ': start', "\n" if $self->verbose; |
---|
496 | my $stime = time; |
---|
497 | |
---|
498 | # Invoke the stage |
---|
499 | my $rc = $self->$method (@args); |
---|
500 | |
---|
501 | # Print diagnostic at end of a stage |
---|
502 | my $total = time - $stime; |
---|
503 | my $s_str = $total > 1 ? 'seconds' : 'second'; |
---|
504 | print '->', $name, ': ', $total, ' ', $s_str, "\n"; |
---|
505 | |
---|
506 | return $rc; |
---|
507 | } |
---|
508 | |
---|
509 | # ------------------------------------------------------------------------------ |
---|
510 | # SYNOPSIS |
---|
511 | # $rc = $self->invoke_system (%args); |
---|
512 | # |
---|
513 | # DESCRIPTION |
---|
514 | # This is a prototype method for invoking the system. |
---|
515 | # ------------------------------------------------------------------------------ |
---|
516 | |
---|
517 | sub invoke_system { |
---|
518 | my $self = shift; |
---|
519 | my %args = @_; |
---|
520 | |
---|
521 | print "Dummy code.\n"; |
---|
522 | |
---|
523 | return 0; |
---|
524 | } |
---|
525 | |
---|
526 | # ------------------------------------------------------------------------------ |
---|
527 | # SYNOPSIS |
---|
528 | # $rc = $obj->parse_cfg($is_for_inheritance); |
---|
529 | # |
---|
530 | # DESCRIPTION |
---|
531 | # This method calls other methods to parse the configuration file. |
---|
532 | # ------------------------------------------------------------------------------ |
---|
533 | |
---|
534 | sub parse_cfg { |
---|
535 | my ($self, $is_for_inheritance) = @_; |
---|
536 | |
---|
537 | # Read config file |
---|
538 | # ---------------------------------------------------------------------------- |
---|
539 | if (!$self->cfg()->src() || !$self->cfg()->read_cfg($is_for_inheritance)) { |
---|
540 | return; |
---|
541 | } |
---|
542 | |
---|
543 | if ($self->cfg->type ne $self->type) { |
---|
544 | w_report 'ERROR: ', $self->cfg->src, ': not a ', $self->type, |
---|
545 | ' config file.'; |
---|
546 | return; |
---|
547 | } |
---|
548 | |
---|
549 | # Strip out optional prefix from all labels |
---|
550 | # ---------------------------------------------------------------------------- |
---|
551 | if ($self->cfg_prefix) { |
---|
552 | for my $line (@{ $self->cfg->lines }) { |
---|
553 | $line->prefix ($self->cfg_prefix); |
---|
554 | } |
---|
555 | } |
---|
556 | |
---|
557 | # Filter lines from the configuration file |
---|
558 | # ---------------------------------------------------------------------------- |
---|
559 | my @cfg_lines = grep { |
---|
560 | $_->slabel and # ignore empty/comment lines |
---|
561 | index ($_->slabel, '%') != 0 and # ignore user variable |
---|
562 | not $_->slabel_starts_with_cfg ('INC') # ignore INC line |
---|
563 | } @{ $self->cfg->lines }; |
---|
564 | |
---|
565 | # Parse the lines to read in the various settings, by calling the methods: |
---|
566 | # $self->parse_cfg_XXX, where XXX is: header, inherit, dest, and the values |
---|
567 | # in the list @{ $self->cfg_methods }. |
---|
568 | # ---------------------------------------------------------------------------- |
---|
569 | my $rc = 1; |
---|
570 | for my $name (@{ $self->cfg_methods }) { |
---|
571 | my $method = 'parse_cfg_' . $name; |
---|
572 | $self->$method (\@cfg_lines) or $rc = 0; |
---|
573 | } |
---|
574 | |
---|
575 | # Report warnings/errors |
---|
576 | # ---------------------------------------------------------------------------- |
---|
577 | for my $line (@cfg_lines) { |
---|
578 | $rc = 0 if not $line->parsed; |
---|
579 | my $mesg = $line->format_error; |
---|
580 | w_report $mesg if $mesg; |
---|
581 | } |
---|
582 | |
---|
583 | return ($rc); |
---|
584 | } |
---|
585 | |
---|
586 | # ------------------------------------------------------------------------------ |
---|
587 | # SYNOPSIS |
---|
588 | # $rc = $self->parse_cfg_dest (\@cfg_lines); |
---|
589 | # |
---|
590 | # DESCRIPTION |
---|
591 | # This method parses the destination settings in the @cfg_lines. |
---|
592 | # ------------------------------------------------------------------------------ |
---|
593 | |
---|
594 | sub parse_cfg_dest { |
---|
595 | my ($self, $cfg_lines) = @_; |
---|
596 | |
---|
597 | my $rc = 1; |
---|
598 | |
---|
599 | # DEST/DIR declarations |
---|
600 | # ---------------------------------------------------------------------------- |
---|
601 | my @lines = grep { |
---|
602 | $_->slabel_starts_with_cfg ('DEST') or $_->slabel_starts_with_cfg ('DIR') |
---|
603 | } @$cfg_lines; |
---|
604 | |
---|
605 | # Only ROOTDIR declarations are accepted |
---|
606 | for my $line (@lines) { |
---|
607 | my ($d, $method) = $line->slabel_fields; |
---|
608 | $d = lc $d; |
---|
609 | if ($method) { |
---|
610 | $method = lc($method); |
---|
611 | } |
---|
612 | |
---|
613 | # Backward compatibility |
---|
614 | $d = 'dest' if $d eq 'dir'; |
---|
615 | |
---|
616 | # Default to "rootdir" |
---|
617 | $method = 'rootdir' if (not $method) or $method eq 'root'; |
---|
618 | |
---|
619 | # Only "rootdir" can be set |
---|
620 | next unless $method eq 'rootdir'; |
---|
621 | |
---|
622 | $self->$d->$method (&expand_tilde ($line->value)); |
---|
623 | $line->parsed (1); |
---|
624 | } |
---|
625 | |
---|
626 | # Make sure root directory is set |
---|
627 | # ---------------------------------------------------------------------------- |
---|
628 | if (not $self->dest->rootdir) { |
---|
629 | w_report 'ERROR: ', $self->cfg->actual_src, |
---|
630 | ': destination root directory not set.'; |
---|
631 | $rc = 0; |
---|
632 | } |
---|
633 | |
---|
634 | # Inherit destinations |
---|
635 | # ---------------------------------------------------------------------------- |
---|
636 | @{$self->dest()->inherit()} = (); |
---|
637 | my @nodes = @{$self->inherit()}; |
---|
638 | while (my $node = pop(@nodes)) { |
---|
639 | push(@nodes, @{$node->inherit()}); |
---|
640 | push(@{$self->dest()->inherit()}, $node->dest()); |
---|
641 | } |
---|
642 | @{$self->dest()->inherit()} = reverse(@{$self->dest()->inherit()}); |
---|
643 | |
---|
644 | return $rc; |
---|
645 | } |
---|
646 | |
---|
647 | # ------------------------------------------------------------------------------ |
---|
648 | # SYNOPSIS |
---|
649 | # $rc = $self->parse_cfg_header (\@cfg_lines); |
---|
650 | # |
---|
651 | # DESCRIPTION |
---|
652 | # This method parses the header setting in the @cfg_lines. |
---|
653 | # ------------------------------------------------------------------------------ |
---|
654 | |
---|
655 | sub parse_cfg_header { |
---|
656 | my ($self, $cfg_lines) = @_; |
---|
657 | |
---|
658 | # Set header lines as "parsed" |
---|
659 | map {$_->parsed (1)} grep {$_->slabel_starts_with_cfg ('CFGFILE')} @$cfg_lines; |
---|
660 | |
---|
661 | return 1; |
---|
662 | } |
---|
663 | |
---|
664 | # ------------------------------------------------------------------------------ |
---|
665 | # SYNOPSIS |
---|
666 | # $rc = $self->parse_cfg_inherit (\@cfg_lines); |
---|
667 | # |
---|
668 | # DESCRIPTION |
---|
669 | # This method parses the inherit setting in the @cfg_lines. |
---|
670 | # ------------------------------------------------------------------------------ |
---|
671 | |
---|
672 | sub parse_cfg_inherit { |
---|
673 | my ($self, $cfg_lines) = @_; |
---|
674 | |
---|
675 | # USE declaration |
---|
676 | # ---------------------------------------------------------------------------- |
---|
677 | my @lines = grep {$_->slabel_starts_with_cfg ('USE')} @$cfg_lines; |
---|
678 | |
---|
679 | # Check for cyclic dependency |
---|
680 | if (@lines and grep {$_ eq $self->cfg->actual_src} @{ $self->inherited }) { |
---|
681 | # Error if current configuration file is in its own inheritance hierarchy |
---|
682 | w_report 'ERROR: ', $self->cfg->actual_src, ': attempt to inherit itself.'; |
---|
683 | $_->error ($_->label . ': ignored due to cyclic dependency.') for (@lines); |
---|
684 | return 0; |
---|
685 | } |
---|
686 | |
---|
687 | my $rc = 1; |
---|
688 | |
---|
689 | for my $line (@lines) { |
---|
690 | # Invoke new instance of the current class |
---|
691 | my $use = ref ($self)->new; |
---|
692 | |
---|
693 | # Set configuration file, inheritance hierarchy |
---|
694 | # and attempt to parse the configuration |
---|
695 | $use->cfg->src (&expand_tilde ($line->value)); |
---|
696 | $use->inherited ([$self->cfg->actual_src, @{ $self->inherited }]); |
---|
697 | $use->parse_cfg(1); # 1 = is for inheritance |
---|
698 | |
---|
699 | # Add to list of inherit configurations |
---|
700 | push @{ $self->inherit }, $use; |
---|
701 | |
---|
702 | $line->parsed (1); |
---|
703 | } |
---|
704 | |
---|
705 | # Check locks in inherited destination |
---|
706 | # ---------------------------------------------------------------------------- |
---|
707 | for my $use (@{ $self->inherit }) { |
---|
708 | $rc = 0 unless $use->check_lock; |
---|
709 | } |
---|
710 | |
---|
711 | return $rc; |
---|
712 | } |
---|
713 | |
---|
714 | # ------------------------------------------------------------------------------ |
---|
715 | # SYNOPSIS |
---|
716 | # @cfglines = $obj->to_cfglines (); |
---|
717 | # |
---|
718 | # DESCRIPTION |
---|
719 | # This method returns the configuration lines of this object. |
---|
720 | # ------------------------------------------------------------------------------ |
---|
721 | |
---|
722 | sub to_cfglines { |
---|
723 | my ($self) = @_; |
---|
724 | |
---|
725 | my @inherited_dests = map { |
---|
726 | FCM1::CfgLine->new ( |
---|
727 | label => $self->cfglabel ('USE'), value => $_->dest->rootdir |
---|
728 | ); |
---|
729 | } @{ $self->inherit }; |
---|
730 | |
---|
731 | return ( |
---|
732 | FCM1::CfgLine::comment_block ('File header'), |
---|
733 | FCM1::CfgLine->new ( |
---|
734 | label => $self->cfglabel ('CFGFILE') . $FCM1::Config::DELIMITER . 'TYPE', |
---|
735 | value => $self->type, |
---|
736 | ), |
---|
737 | FCM1::CfgLine->new ( |
---|
738 | label => $self->cfglabel ('CFGFILE') . $FCM1::Config::DELIMITER . 'VERSION', |
---|
739 | value => '1.0', |
---|
740 | ), |
---|
741 | FCM1::CfgLine->new (), |
---|
742 | |
---|
743 | @inherited_dests, |
---|
744 | |
---|
745 | FCM1::CfgLine::comment_block ('Destination'), |
---|
746 | ($self->dest->to_cfglines()), |
---|
747 | ); |
---|
748 | } |
---|
749 | |
---|
750 | # ------------------------------------------------------------------------------ |
---|
751 | |
---|
752 | 1; |
---|
753 | |
---|
754 | __END__ |
---|