source: LMDZ6/branches/Amaury_dev/tools/fcm/lib/FCM/Util/ConfigReader.pm @ 5475

Last change on this file since 5475 was 5129, checked in by abarral, 18 months ago

Re-add removed by mistake fcm
File size: 20.3 KB
Line 
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# ------------------------------------------------------------------------------
19use strict;
20use warnings;
21
22# ------------------------------------------------------------------------------
23package FCM::Util::ConfigReader;
24use base qw{FCM::Class::CODE};
25
26use FCM::Context::ConfigEntry;
27use FCM::Context::Event;
28use FCM::Context::Locator;
29use FCM::Util::Exception;
30use File::Spec::Functions qw{file_name_is_absolute};
31use Text::Balanced   qw{extract_bracketed};
32use Text::ParseWords qw{parse_line shellwords};
33
34# Alias
35our $UTIL;
36# Alias to exception class
37my $E = 'FCM::Util::Exception';
38# The variable name, which means the container of the current configuration file
39my $HERE = 'HERE';
40# Element indices in a stack item
41my ($I_LOCATOR, $I_LINE_NUM, $I_HANDLE, $I_HERE_LOCATOR) = (0 .. 3);
42# Patterns for extracting/matching strings
43my %PATTERN_OF = (
44    # Config: comment delimiter, e.g. "... #comment"
45    comment => qr/\s+ \#/xms,
46    # Config: continue, start of next line
47    cont_next => qr/
48        \A (.*?)        (?# start and capture 1, shortest of anything)
49        (\\*)           (?# capture 2, a number of backslashes)
50        \s* \z          (?# optional space until the end)
51    /xms,
52    # Config: continue, end of previous line
53    cont_prev => qr/\A \s* \\? (.*) \z/xms,
54    # Config: removal of the assignment operator at start of string
55    fcm2_equal => qr/
56        \A \s*          (?# start and optional spaces)
57        (=)             (?# capture 1, equal sign)
58        (.*) \z         (?# capture 2, rest of string)
59    /xms,
60    # Config: label of an inc statement
61    fcm1_include => qr/\Ainc\z/ixms,
62    # Config: label of an include statement
63    fcm2_include => qr/\Ainclude\z/ixms,
64    # Config: label of an include-path statement
65    fcm2_include_path => qr/\Ainclude-path\z/ixms,
66    # Config: label
67    fcm2_label => qr/
68        \A \s*          (?# start and optional spaces)
69        (\$?[\w\-\.]+)  (?# capture 1, optional dollar, then valid label)
70        (.*) \z         (?# capture 2, rest of string)
71    /xms,
72    # Config: a variable identifier in a value, e.g. "... ${var}", "$var"
73    fcm1_var => qr/
74        \A              (?# start)
75        (.*?)           (?# capture 1, shortest of anything)
76        ([\$\%])        (?# capture 2, variable sigil, dollar or percent)
77        (\{)?           (?# capture 3, curly brace start, optional)
78        ([A-z]\w+(?:::[A-z]\w+)*) (?# capture 4, variable name)
79        ((?(3)\}))      (?# capture 5, curly brace end, if started in capture 4)
80        (.*)            (?# capture 6, rest of string)
81        \z              (?# end)
82    /xms,
83    # Config: a variable identifier in a value, e.g. "... ${var}", "$var"
84    fcm2_var => qr/
85        \A              (?# start)
86        (.*?)           (?# capture 1, shortest of anything)
87        (\\*)           (?# capture 2, escapes)
88        (\$)            (?# capture 3, variable sigil, dollar)
89        (\{)?           (?# capture 4, curly brace start, optional)
90        ([A-z]\w+)      (?# capture 5, variable name)
91        ((?(4)\}))      (?# capture 6, curly brace end, if started in capture 4)
92        (.*)            (?# capture 7, rest of string)
93        \z              (?# end)
94    /xms,
95    # Config: a $HERE, ${HERE} in the beginning of a string
96    here => qr/
97        \A                  (?# start)
98        (\$HERE|\$\{HERE\}) (?# capture 1, \$HERE)
99        (\/.*)?             (?# capture 2, rest of string)
100        \z                  (?# end)
101    /xms,
102    # Config: an empty or comment line
103    ignore => qr/\A \s* (?:\#|\z)/xms,
104    # Config: comma separator
105    delim_csv => qr/\s*,\s*/xms,
106    # Config: modifier key:value separator
107    delim_mod => qr/\s*:\s*/xms,
108    # A variable name
109    var_name => qr/\A [A-Za-z_]\w* \z/xms,
110    # Config: trim value
111    trim => qr/\A \s* (.*?) \s* \z/xms,
112    # Config: trim value within braces
113    trim_brace => qr/\A [\[\{] \s* (.*?) \s* [\]\}] \z/xms,
114);
115# Default (post-)processors for a configuration entry
116our %FCM1_ATTRIB = (
117    parser    => _parse_func(\&_parse_fcm1_label, \&_parse_fcm1_var),
118    processor => sub {
119        _process_assign_func('%')->(@_)
120        ||
121        _process_include_func('fcm1_include')->(@_)
122        ||
123        _process_fcm1_label(@_)
124        ;
125    },
126);
127# Default (post-)processors for a configuration entry
128our %FCM2_ATTRIB = (
129    parser    => _parse_func(\&_parse_fcm2_label, \&_parse_fcm2_var),
130    processor => sub {
131        _process_assign_func('$', '?')->(@_)
132        ||
133        _process_include_path_func('fcm2_include_path')->(@_)
134        ||
135        _process_include_func('fcm2_include')->(@_)
136        ;
137    },
138);
139
140# Creates the class.
141__PACKAGE__->class(
142    {   event_level => '$',
143        parser      => {isa => '&', default => sub {$FCM2_ATTRIB{parser}}   },
144        processor   => {isa => '&', default => sub {$FCM2_ATTRIB{processor}}},
145        util        => '&',
146    },
147    {action_of => {main => \&_main}},
148);
149
150# Returns a configuration reader.
151sub _main {
152    my ($attrib_ref, $locator, $reader_attrib_ref) = @_;
153    if (!defined($locator)) {
154        return;
155    }
156    my %reader_attrib
157        = defined($reader_attrib_ref) ? %{$reader_attrib_ref} : ();
158    my @include_paths = exists($reader_attrib{include_paths})
159        ?  @{$reader_attrib{include_paths}} : ();
160    my %state = (
161        cont  => undef,
162        ctx   => undef,
163        line  => undef,
164        include_paths => \@include_paths,
165        stack => [[$locator, 0]],
166        var   => {},
167    );
168    my %attrib = (%{$attrib_ref}, %reader_attrib);
169    sub {_read(\%attrib, \%state)};
170}
171
172# Returns a parser for a configuration line (FCM 1 or FCM 2 format).
173sub _parse_func {
174    my ($parse_label_func, $parse_var_func) = @_;
175    sub {
176        my ($state_ref) = @_;
177        my $line
178            = $state_ref->{cont} ? $state_ref->{line}
179            :                      $parse_label_func->($state_ref)
180            ;
181        my $value
182            = $parse_var_func->($state_ref, _parse_value($state_ref, $line));
183        if ($state_ref->{ctx}->get_value()) {
184            $value = $state_ref->{ctx}->get_value() . $value;
185        }
186        $state_ref->{ctx}->set_value($value);
187        if (!$state_ref->{cont}) {
188            _parse_var_here($state_ref);
189        }
190    };
191}
192
193# Parses a configuration line label (FCM 1 format).
194sub _parse_fcm1_label {
195    my ($state_ref) = @_;
196    my ($label, $line) = split(qr{\s+}xms, $state_ref->{line}, 2);
197    $state_ref->{ctx}->set_label($label);
198    return $line;
199}
200
201# Parses a configuration line label (FCM 2 format).
202sub _parse_fcm2_label {
203    my ($state_ref) = @_;
204    my %EXTRACTOR_OF = (
205        equal    => sub {($_[0] =~ $PATTERN_OF{fcm2_equal})},
206        label    => sub {($_[0] =~ $PATTERN_OF{fcm2_label})},
207        modifier => sub {extract_bracketed($_[0], '{}')} ,
208        ns       => sub {extract_bracketed($_[0], '["]')},
209    );
210    my %ACTION_OF = (
211        equal    => sub {$_[1] || $E->throw($E->CONFIG_SYNTAX, $_[0])},
212        label    => sub {$_[0]->set_label($_[1])},
213        modifier => \&_parse_fcm2_label_modifier,
214        ns       => \&_parse_fcm2_label_ns,
215    );
216    my %EXPAND_VAR_IN = (modifier => 1, ns => 1);
217    my $line = $state_ref->{line};
218    for my $key (qw{label modifier ns equal}) {
219        $line ||= q{};
220        (my $content, $line) = $EXTRACTOR_OF{$key}->($line);
221        if ($EXPAND_VAR_IN{$key}) {
222            $content = _parse_fcm2_var($state_ref, $content);
223        }
224        $ACTION_OF{$key}->($state_ref->{ctx}, $content);
225    }
226    return $line;
227}
228
229# Parses the modifier part in a configuration line label (FCM 2 format).
230sub _parse_fcm2_label_modifier {
231    my ($ctx, $content) = @_;
232    if ($content) {
233        my ($str) = $content =~ $PATTERN_OF{trim_brace};
234        my %hash;
235        for my $item (parse_line($PATTERN_OF{delim_csv}, 0, $str)) {
236            my ($key, $value) = split($PATTERN_OF{delim_mod}, $item, 2);
237            # Note: "key1, key2: value2, ..." == "key1: 1, key2: value2, ..."
238            $hash{$key} = ($value ? $value : 1);
239        }
240        $ctx->set_modifier_of(\%hash);
241    }
242}
243
244# Parses the ns part in a configuration line label (FCM 2 format).
245sub _parse_fcm2_label_ns {
246    my ($ctx, $content) = @_;
247    if ($content) {
248        my ($str) = $content =~ $PATTERN_OF{trim_brace};
249        my @ns = map {$_ eq q{/} ? q{} : $_} parse_line(q{ }, 0, $str);
250        $ctx->set_ns_list(\@ns);
251    }
252}
253
254# Expands variables in a string in a FCM 1 configuration file.
255sub _parse_fcm1_var {
256    my ($state_ref, $value) = @_;
257    my %V = %{$state_ref->{var}};
258    my $lead = q{};
259    my $tail = $value;
260    MATCH:
261    while (defined($tail) && length($tail) > 0) {
262        my ($pre, $sigil, $br_open, $name, $br_close, $post)
263            = map {defined($_) ? $_ : q{}} ($tail =~ $PATTERN_OF{fcm1_var});
264        if (!$name) {
265            return $lead . $tail;
266        }
267        $tail = $post;
268        my $symbol = $sigil . $br_open . $name . $br_close;
269        my $substitute
270            = $name eq $HERE                       ? $symbol
271            : $sigil eq '$' && exists($ENV{$name}) ? $ENV{$name}
272            : $sigil eq '%' && exists($V{$name})   ? $V{$name}
273            :                                        undef
274            ;
275        if (!defined($substitute)) {
276            $UTIL->event(
277                FCM::Context::Event->CONFIG_VAR_UNDEF,
278                $state_ref->{ctx},
279                $symbol,
280            );
281        }
282        $substitute ||= $symbol;
283        $lead .= $pre . $substitute;
284    }
285    return $lead;
286}
287
288# Expands variables in a string in a FCM 2 configuration file.
289sub _parse_fcm2_var {
290    my ($state_ref, $value) = @_;
291    my %V = (%ENV, %{$state_ref->{var}});
292    my $lead = q{};
293    my $tail = $value;
294    while (defined($tail) && length($tail) > 0) {
295        my ($pre, $esc, $sigil, $br_open, $name, $br_close, $post)
296            = map {defined($_) ? $_ : q{}} ($tail =~ $PATTERN_OF{fcm2_var});
297        if (!$name) {
298            return $lead . $tail;
299        }
300        $tail = $post;
301        my $symbol = $sigil . $br_open . $name . $br_close;
302        my $substitute
303            = $name eq $HERE           ? $symbol
304            : $esc && length($esc) % 2 ? $symbol
305            : exists($V{$name})        ? $V{$name}
306            :                            undef
307            ;
308        if (!defined($substitute)) {
309            return $E->throw(
310                $E->CONFIG_VAR_UNDEF, $state_ref->{ctx}, "undef($symbol)",
311            );
312        }
313        $lead .= $pre . substr($esc, 0, length($esc) / 2) . $substitute;
314    }
315    return $lead;
316}
317
318# Parses the value part of a configuration line.
319sub _parse_value {
320    my ($state_ref, $line) = @_;
321    $line ||= q{};
322    my ($value) = parse_line($PATTERN_OF{comment}, 1, $line);
323    $value ||= q{};
324    chomp($value);
325    ($value) = $value =~ $PATTERN_OF{$state_ref->{cont} ? 'cont_prev' : 'trim'};
326    $state_ref->{cont} = q{};
327    if ($value) {
328        my ($lead, $tail) = $value =~ $PATTERN_OF{cont_next};
329        if ($tail && length($tail) % 2) {
330            $value = $lead;
331            $state_ref->{cont} = $tail;
332        }
333    }
334    return $value;
335}
336
337# Expands the leading $HERE variable in the value of a configuration entry.
338sub _parse_var_here {
339    my ($state_ref) = @_;
340    my @values = shellwords($state_ref->{ctx}->get_value());
341    if (!grep {$_ =~ $PATTERN_OF{here}} @values) {
342        return;
343    }
344    VALUE:
345    for my $value (@values) {
346        my ($head, $tail)
347            = map {defined($_) ? $_ : q{}} $value =~ $PATTERN_OF{here};
348        if (!$head) {
349            next VALUE;
350        }
351        $tail = index($tail, '/') == 0 ? substr($tail, 1) : q{}; # FIXME
352        my $here = $state_ref->{stack}->[-1]->[$I_HERE_LOCATOR];
353        $value = $UTIL->loc_cat($here, $tail)->get_value();
354    }
355    $state_ref->{ctx}->set_value(join(
356        q{ },
357        map {my $s = $_; $s =~ s{(['"\s])}{\\$1}gmsx; $s} @values,
358    ));
359}
360
361# Returns a function to process a variable assignment. If
362# $assign_if_undef_modifier is specified and is present in the declaration, only
363# assign a variable if it is not yet defined.
364sub _process_assign_func {
365    my ($sigil, $assign_if_undef_modifier) = @_;
366    sub {
367        my ($state_ref) = @_;
368        my $ctx = $state_ref->{ctx};
369        if (index($ctx->get_label(), $sigil) != 0) { # not a variable assignment
370            return;
371        }
372        my $name = substr($ctx->get_label(), length($sigil));
373        if ($name !~ $PATTERN_OF{var_name}) {
374            return $E->throw($E->CONFIG_SYNTAX, $state_ref->{ctx});
375        }
376        if ($name eq $HERE) {
377            return $E->throw($E->CONFIG_USAGE, $state_ref->{ctx});
378        }
379        if (    !$assign_if_undef_modifier
380            ||  !exists($ctx->get_modifier_of()->{$assign_if_undef_modifier})
381            ||  !exists($ENV{$name}) && !exists($state_ref->{var}{$name})
382        ) {
383            $state_ref->{var}{$name} = $ctx->get_value();
384        }
385        return 1;
386    }
387}
388
389# Processes a FCM 1 label.
390sub _process_fcm1_label {
391    my ($state_ref) = @_;
392    $state_ref->{var}{$state_ref->{ctx}->get_label()}
393        = $state_ref->{ctx}->get_value();
394    return;
395}
396
397# Processes an include-path declaration.
398sub _process_include_path_func {
399    my ($key) = @_;
400    my $PATTERN = $PATTERN_OF{$key};
401    sub {
402        my ($state_ref) = @_;
403        if ($state_ref->{ctx}->get_label() !~ $PATTERN) {
404            return;
405        }
406        my $M = $state_ref->{ctx}->get_modifier_of();
407        my $type = exists($M->{type}) ? $M->{type} : undef;
408        if (exists($M->{'+'})) {
409            push(@{$state_ref->{include_paths}}, (
410                map {
411                    FCM::Context::Locator->new($_, {type => $type});
412                } shellwords($state_ref->{ctx}->get_value()),
413            )),
414        }
415        else {
416            $state_ref->{include_paths} = [
417                map {
418                    FCM::Context::Locator->new($_, {type => $type});
419                } shellwords($state_ref->{ctx}->get_value())
420            ],
421        }
422        return 1;
423    };
424}
425
426# Processes an include declaration.
427sub _process_include_func {
428    my ($key) = @_;
429    my $PATTERN = $PATTERN_OF{$key};
430    sub {
431        my ($state_ref) = @_;
432        if ($state_ref->{ctx}->get_label() !~ $PATTERN) {
433            return;
434        }
435        my $M = $state_ref->{ctx}->get_modifier_of();
436        my $type = exists($M->{type}) ? $M->{type} : undef;
437        push(@{$state_ref->{stack}}, (map {
438            my $name = $_;
439            my $locator;
440            if (    $UTIL->uri_match($name)
441                ||  file_name_is_absolute($name)
442            ) {
443                $locator = FCM::Context::Locator->new($name, {type => $type});
444            }
445            if (!defined($locator)) {
446                HEAD:
447                for my $head (
448                    $state_ref->{stack}->[-1]->[$I_HERE_LOCATOR],
449                    @{$state_ref->{include_paths}},
450                ) {
451                    my $locator_at_head = $UTIL->loc_cat($head, $name);
452                    if ($UTIL->loc_exists($locator_at_head)) {
453                        $locator = $locator_at_head;
454                        last HEAD;
455                    }
456                }
457            }
458            if (!defined($locator)) {
459                return $E->throw(
460                    $E->CONFIG_LOAD, $state_ref->{stack}, "include=$name",
461                );
462            }
463            [$locator, 0, undef, undef];
464        } shellwords($state_ref->{ctx}->get_value())));
465        return 1;
466    };
467}
468
469# Reads the next entry of a configuration file.
470sub _read {
471    my ($attrib_ref, $state_ref) = @_;
472    local($UTIL) = $attrib_ref->{util};
473    STACK:
474    while (@{$state_ref->{stack}}) {
475        my $S = $state_ref->{stack}->[-1];
476        # Open a file handle for the top of the stack, if necessary
477        if (!defined($S->[$I_HANDLE])) {
478            eval {
479                # Check for cyclic dependency
480                for my $i (-scalar(@{$state_ref->{stack}}) .. -2) {
481                    my $value = $UTIL->loc_as_invariant(
482                        $state_ref->{stack}->[$i]->[$I_LOCATOR],
483                    );
484                    if ($value eq $UTIL->loc_as_invariant($S->[$I_LOCATOR])) {
485                        return $E->throw($E->CONFIG_CYCLIC, $state_ref->{stack});
486                    }
487                }
488                $S->[$I_HANDLE] = $UTIL->loc_reader($S->[$I_LOCATOR]);
489                $S->[$I_HERE_LOCATOR] = $UTIL->loc_dir($S->[$I_LOCATOR]);
490            };
491            if (my $e = $@) {
492                if ($E->caught($e) && $e->get_code() eq $E->CONFIG_CYCLIC) {
493                    die($e);
494                }
495                return $E->throw($E->CONFIG_LOAD, $state_ref->{stack}, $e);
496            }
497            $UTIL->event(
498                FCM::Context::Event->CONFIG_OPEN,
499                _stack_cp($state_ref->{stack}),
500                $attrib_ref->{event_level},
501            );
502        }
503        # Read a line and parse it
504        LINE:
505        while ($state_ref->{line} = readline($S->[$I_HANDLE])) {
506            if ($state_ref->{line} =~ $PATTERN_OF{ignore}) {
507                next LINE;
508            }
509            $S->[$I_LINE_NUM] = $.;
510            if (!$state_ref->{cont}) {
511                $state_ref->{ctx} = FCM::Context::ConfigEntry->new({
512                    stack => _stack_cp($state_ref->{stack}),
513                });
514            }
515            $attrib_ref->{parser}->($state_ref);
516            if (!$state_ref->{cont}) {
517                if ($attrib_ref->{processor}->($state_ref)) {
518                    next STACK;
519                }
520                return $state_ref->{ctx};
521            }
522        }
523        # At end of file
524        if ($state_ref->{cont}) {
525            return $E->throw($E->CONFIG_CONT_EOF, $state_ref->{ctx});
526        }
527        close($state_ref->{stack}->[-1]->[$I_HANDLE]);
528        $state_ref->{stack}->[-1]->[$I_HANDLE] = undef; # free the memory
529        pop(@{$state_ref->{stack}});
530    }
531    return;
532}
533
534# Copies a stack, selecting only the and the line number.
535sub _stack_cp {
536    [map {[@{$_}[$I_LOCATOR, $I_LINE_NUM]]} @{$_[0]}];
537}
538
539# ------------------------------------------------------------------------------
5401;
541__END__
542
543=head1 NAME
544
545FCM::Util::Config
546
547=head1 SYNOPSIS
548
549    use FCM::Util;
550    my $util = FCM::Util->new(\%attrib);
551    # ... time passes, and now we want to read a FCM 1 config
552    my ($locator, $reader);
553    $locator = FCM::Context::Locator->new($path_to_an_fcm1_config);
554    $reader
555        = $util->config_reader($locator, \%FCM::Util::ConfigReader::FCM1_ATTRIB);
556    while (my $entry = $reader->()) {
557        # ...
558    }
559    # ... time passes, and now we want to read a FCM 2 config
560    $locator = FCM::Context::Locator->new($path_to_an_fcm2_config);
561    $reader = $util->config_reader($locator);
562    while (my $entry = $reader->()) {
563        # ...
564    }
565
566=head1 DESCRIPTION
567
568This module is part of L<FCM::Util|FCM::Util>. Provides a function to generate
569configuration file readers.
570
571=head1 METHODS
572
573=over 4
574
575=item $class->new(\%attrib)
576
577Returns a new new instance. The %attrib must contain the following:
578
579=over 4
580
581=item {parser}
582
583A CODE reference to parse the lines in a configuration file into entry contexts.
584It should have a calling interface $f->(\%state). (See L</STATE> for a
585description of %state.) The return value is ignored.
586
587=item {processor}
588
589A CODE reference to post-process each entry context. It should have a calling
590interface $f->(\%state). (See L</STATE> for a description of %state.) The
591processor should return true if the current entry has been processed and is no
592longer considered useful for the user.
593
594=item {util}
595
596The L<FCM::Util|FCM::Util> object, which initialises this class.
597
598=back
599
600=back
601
602See the description of the config_reader() method in L<FCM::Util|FCM::Util> for
603detail.
604
605=head1 COPYRIGHT
606
607Copyright (C) 2006-2021 British Crown (Met Office) & Contributors.
608
609=cut
Note: See TracBrowser for help on using the repository browser.