—

              
package Config::IOD::Reader;
use 5.010001;
use strict;
use warnings;
use parent qw(Config::IOD::Base);
our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2022-05-02'; # DATE
our $DIST = 'Config-IOD-Reader'; # DIST
our $VERSION = '0.345'; # VERSION
sub _merge {
    my ($self, $section) = @_;
    my $res = $self->{_res};
    for my $msect (@{ $self->{_merge} }) {
        if ($msect eq $section) {
            # ignore merging self
            next;
            #local $self->{_linum} = $self->{_linum}-1;
            #$self->_err("Can't merge section '$msect' to '$section': ".
            #                "Same section");
        }
        if (!exists($res->{$msect})) {
            local $self->{_linum} = $self->{_linum}-1;
            $self->_err("Can't merge section '$msect' to '$section': ".
                            "Section '$msect' not seen yet");
        }
        for my $k (keys %{ $res->{$msect} }) {
            $res->{$section}{$k} //= $res->{$msect}{$k};
        }
    }
}
sub _init_read {
    my $self = shift;
    $self->SUPER::_init_read;
    $self->{_res} = {};
    $self->{_merge} = undef;
    $self->{_num_seen_section_lines} = 0;
    $self->{_cur_section} = $self->{default_section};
    $self->{_arrayified} = {};
}
sub _read_string {
    my ($self, $str, $cb) = @_;
    my $res = $self->{_res};
    my $cur_section = $self->{_cur_section};
    my $directive_re = $self->{allow_bang_only} ?
        qr/^;?\s*!\s*(\w+)\s*/ :
        qr/^;\s*!\s*(\w+)\s*/;
    my $_raw_val; # only to provide to callback
    my @lines = split /^/, $str;
    local $self->{_linum} = 0;
  LINE:
    for my $line (@lines) {
        $self->{_linum}++;
        # blank line
        if ($line !~ /\S/) {
            next LINE;
        }
        # directive line
        if ($self->{enable_directive} && $line =~ s/$directive_re//) {
            my $directive = $1;
            if ($self->{allow_directives}) {
                $self->_err("Directive '$directive' is not in ".
                                "allow_directives list")
                    unless grep { $_ eq $directive }
                        @{$self->{allow_directives}};
            }
            if ($self->{disallow_directives}) {
                $self->_err("Directive '$directive' is in ".
                                "disallow_directives list")
                    if grep { $_ eq $directive }
                        @{$self->{disallow_directives}};
            }
            my $args = $self->_parse_command_line($line);
            if (!defined($args)) {
                $self->_err("Invalid arguments syntax '$line'");
            }
            if ($cb) {
                $cb->(
                    event => 'directive',
                    linum=>$self->{_linum}, line=>$line, cur_section=>$self->{_cur_section},
                    directive => $directive,
                    args => $args,
                );
            }
            if ($directive eq 'include') {
                my $path;
                if (! @$args) {
                    $self->_err("Missing filename to include");
                } elsif (@$args > 1) {
                    $self->_err("Extraneous arguments");
                } else {
                    $path = $args->[0];
                }
                my $res = $self->_push_include_stack($path);
                if ($res->[0] != 200) {
                    $self->_err("Can't include '$path': $res->[1]");
                }
                $path = $res->[2];
                $self->_read_string($self->_read_file($path, $cb), $cb);
                $self->_pop_include_stack;
            } elsif ($directive eq 'merge') {
                $self->{_merge} = @$args ? $args : undef;
            } elsif ($directive eq 'noop') {
            } else {
                if ($self->{ignore_unknown_directive}) {
                    # assume a regular comment
                    next LINE;
                } else {
                    $self->_err("Unknown directive '$directive'");
                }
            }
            next LINE;
        }
        # comment line
        if ($line =~ /^\s*[;#]/) {
            if ($cb) {
                $cb->(
                    event => 'comment',
                    linum=>$self->{_linum}, line=>$line, cur_section=>$self->{_cur_section},
                );
            }
            next LINE;
        }
        # section line
        if ($line =~ /^\s*\[\s*(.+?)\s*\](?: \s*[;#].*)?/) {
            my $prev_section = $self->{_cur_section};
            $self->{_cur_section} = $cur_section = $1;
            $res->{$cur_section} //= {};
            $self->{_num_seen_section_lines}++;
            # previous section exists? do merging for previous section
            if ($self->{_merge} && $self->{_num_seen_section_lines} > 1) {
                $self->_merge($prev_section);
            }
            if ($cb) {
                $cb->(
                    event => 'section',
                    linum=>$self->{_linum}, line=>$line, cur_section=>$self->{_cur_section},
                    section => $cur_section,
                );
            }
            next LINE;
        }
        # key line
        if ($line =~ /^\s*([^=]+?)\s*=(\s*)(.*)/) {
            my $key = $1;
            my $space = $2;
            my $val = $3;
            if ($self->{warn_perl} && !$space && $val =~ /\A>/) {
                $self->_warn("Probably using Perl syntax instead of INI: $line");
            }
            # the common case is that value are not decoded or
            # quoted/bracketed/braced, so we avoid calling _parse_raw_value here
            # to avoid overhead
            if ($val =~ /\A["!\\[\{~]/) {
                $_raw_val = $val if $cb;
                my ($err, $parse_res, $decoded_val) = $self->_parse_raw_value($val);
                $self->_err("Invalid value: " . $err) if $err;
                $val = $decoded_val;
            } else {
                $_raw_val = $val if $cb;
                $val =~ s/\s*[#;].*//; # strip comment
            }
            if (exists $res->{$cur_section}{$key}) {
                if (!$self->{allow_duplicate_key}) {
                    $self->_err("Duplicate key: $key (section $cur_section)");
                } elsif ($self->{_arrayified}{$cur_section}{$key}++) {
                    push @{ $res->{$cur_section}{$key} }, $val;
                } else {
                    $res->{$cur_section}{$key} = [
                        $res->{$cur_section}{$key}, $val];
                }
            } else {
                $res->{$cur_section}{$key} = $val;
            }
            if ($cb) {
                $cb->(
                    event => 'key',
                    linum=>$self->{_linum}, line=>$line, cur_section=>$self->{_cur_section},
                    key => $key,
                    val => $val,
                    raw_val => $_raw_val,
                );
            }
            next LINE;
        }
        $self->_err("Invalid syntax");
    }
    if ($self->{_merge} && $self->{_num_seen_section_lines} > 1) {
        $self->_merge($cur_section);
    }
    $res;
}
1;
# ABSTRACT: Read IOD/INI configuration files
__END__
HideShow 376 lines of Pod
=pod
=encoding UTF-8
=head1 NAME
Config::IOD::Reader - Read IOD/INI configuration files
=head1 VERSION
This document describes version 0.345 of Config::IOD::Reader (from Perl distribution Config-IOD-Reader), released on 2022-05-02.
=head1 SYNOPSIS
 use Config::IOD::Reader;
 my $reader = Config::IOD::Reader->new(
     # list of known attributes, with their default values
     # default_section     => 'GLOBAL',
     # enable_directive    => 1,
     # enable_encoding     => 1,
     # enable_quoting      => 1,
     # enable_backet       => 1,
     # enable_brace        => 1,
     # allow_encodings     => undef, # or ['base64','json',...]
     # disallow_encodings  => undef, # or ['base64','json',...]
     # allow_directives    => undef, # or ['include','merge',...]
     # disallow_directives => undef, # or ['include','merge',...]
     # allow_bang_only     => 1,
     # enable_expr         => 0,
     # allow_duplicate_key => 1,
     # ignore_unknown_directive => 0,
 );
 my $config_hash = $reader->read_file('config.iod');
=head1 DESCRIPTION
This module reads L<IOD> configuration files (IOD is an INI-like format with
more precise specification, some extra features, and 99% compatible with typical
INI format). It is a minimalist alternative to the more fully-featured
L<Config::IOD>. It cannot write IOD files and is optimized for low startup
overhead.
=head1 EXPRESSION
Expression allows you to do things like:
 [section1]
 foo=1
 bar="monkey"
 [section2]
 baz =!e 1+1
 qux =!e "grease" . val("section1.bar")
 quux=!e val("qux") . " " . val('baz')
And the result will be:
 {
     section1 => {foo=>1, bar=>"monkey"},
     section2 => {baz=>2, qux=>"greasemonkey", quux=>"greasemonkey 2"},
 }
For safety, you'll need to set C<enable_expr> attribute to 1 first to enable
this feature.
The syntax of the expression (the C<expr> encoding) is not officially specified
yet in the L<IOD> specification. It will probably be Expr (see
L<Language::Expr::Manual::Syntax>). At the moment, this module implements a very
limited subset that is compatible (lowest common denominator) with Perl syntax
and uses C<eval()> to evaluate the expression. However, only the limited subset
is allowed (checked by Perl 5.10 regular expression).
The supported terms:
 number
 string (double-quoted and single-quoted)
 undef literal
 simple variable ($abc, no namespace, no array/hash sigil, no special variables)
 function call (only the 'val' function is supported)
 grouping (parenthesis)
The supported operators are:
 + - .
 * / % x
 **
 unary -, unary +, !, ~
The C<val()> function refers to the configuration key. If the argument contains
".", it will be assumed as C<SECTIONNAME.KEYNAME>, otherwise it will access the
current section's key. Since parsing is done in a single pass, you can only
refer to the already mentioned key.
Code will be compiled using Perl's C<eval()> in the
C<Config::IOD::Expr::_Compiled> namespace, with C<no strict>, C<no warnings>.
=head1 ATTRIBUTES
=head2 default_section => str (default: C<GLOBAL>)
If a key line is specified before any section line, this is the section that the
key will be put in.
=head2 enable_directive => bool (default: 1)
If set to false, then directives will not be parsed. Lines such as below will be
considered a regular comment:
 ;!include foo.ini
and lines such as below will be considered a syntax error (B<regardless> of the
C<allow_bang_only> setting):
 !include foo.ini
B<NOTE: Turning this setting off violates IOD specification.>
=head2 enable_encoding => bool (default: 1)
If set to false, then encoding notation will be ignored and key value will be
parsed as verbatim. Example:
 name = !json null
With C<enable_encoding> turned off, value will not be undef but will be string
with the value of (as Perl literal) C<"!json null">.
B<NOTE: Turning this setting off violates IOD specification.>
=head2 enable_quoting => bool (default: 1)
If set to false, then quotes on key value will be ignored and key value will be
parsed as verbatim. Example:
 name = "line 1\nline2"
With C<enable_quoting> turned off, value will not be a two-line string, but will
be a one line string with the value of (as Perl literal) C<"line 1\\nline2">.
B<NOTE: Turning this setting off violates IOD specification.>
=head2 enable_bracket => bool (default: 1)
If set to false, then JSON literal array will be parsed as verbatim. Example:
 name = [1,2,3]
With C<enable_bracket> turned off, value will not be a three-element array, but
will be a string with the value of (as Perl literal) C<"[1,2,3]">.
B<NOTE: Turning this setting off violates IOD specification.>
=head2 enable_brace => bool (default: 1)
If set to false, then JSON literal object (hash) will be parsed as verbatim.
Example:
 name = {"a":1,"b":2}
With C<enable_brace> turned off, value will not be a hash with two pairs, but
will be a string with the value of (as Perl literal) C<'{"a":1,"b":2}'>.
B<NOTE: Turning this setting off violates IOD specification.>
=head2 enable_tilde => bool (default: 1)
If set to true (the default), then value that starts with C<~> (tilde) will be
assumed to use !path encoding, unless an explicit encoding has been otherwise
specified.
Example:
 log_dir = ~/logs  ; ~ will be resolved to current user's home directory
With C<enable_tilde> turned off, value will still be literally C<~/logs>.
B<NOTE: Turning this setting off violates IOD specification.>
=head2 allow_encodings => array
If defined, set list of allowed encodings. Note that if C<disallow_encodings> is
also set, an encoding must also not be in that list.
Also note that, for safety reason, if you want to enable C<expr> encoding,
you'll also need to set C<enable_expr> to 1.
=head2 disallow_encodings => array
If defined, set list of disallowed encodings. Note that if C<allow_encodings> is
also set, an encoding must also be in that list.
Also note that, for safety reason, if you want to enable C<expr> encoding,
you'll also need to set C<enable_expr> to 1.
=head2 enable_expr => bool (default: 0)
Whether to enable C<expr> encoding. By default this is turned off, for safety.
Please see L</"EXPRESSION"> for more details.
=head2 allow_directives => array
If defined, only directives listed here are allowed. Note that if
C<disallow_directives> is also set, a directive must also not be in that list.
=head2 disallow_directives => array
If defined, directives listed here are not allowed. Note that if
C<allow_directives> is also set, a directive must also be in that list.
=head2 allow_bang_only => bool (default: 1)
Since the mistake of specifying a directive like this:
 !foo
instead of the correct:
 ;!foo
is very common, the spec allows it. This reader, however, can be configured to
be more strict.
=head2 allow_duplicate_key => bool (default: 1)
If set to 0, you can forbid duplicate key, e.g.:
 [section]
 a=1
 a=2
or:
 [section]
 a=1
 b=2
 c=3
 a=10
In traditional INI file, to specify an array you specify multiple keys. But when
there is only a single key, it is unclear if the value is a single-element array
or a scalar. You can use this setting to avoid this array/scalar ambiguity in
config file and force user to use JSON encoding or bracket to specify array:
 [section]
 a=[1,2]
B<NOTE: Turning this setting off violates IOD specification.>
=head2 ignore_unknown_directive => bool (default: 0)
If set to true, will not die if an unknown directive is encountered. It will
simply be ignored as a regular comment.
B<NOTE: Turning this setting on violates IOD specification.>
=head2 warn_perl => bool (default: 0)
Emit warning if configuration contains key line like these:
 foo=>"bar"
 foo => 123,
which suggest user is assuming configuration is in Perl format instead of INI.
If you enable this option, but happens to have a value that begins with ">", to
avoid this warning you can quote the value first:
 foo=">the value does begins with a greater-than sign"
 bar=">the value does begins with a greater-than sign and ends with a comma,"
=head1 METHODS
=head2 new(%attrs) => obj
=head2 $reader->read_file($filename[ , $callback ]) => hash
Read IOD configuration from a file. Die on errors.
See C<read_string> for more information on C<$callback> argument.
=head2 $reader->read_string($str[ , $callback ]) => hash
Read IOD configuration from a string. Die on errors.
C<$callback> is an optional coderef argument that will be called during various
stages. It can be useful if you want more information (especially ordering). It
will be called with hash argument C<%args>
=over
=item * Found a directive line
Arguments passed: C<event> (str, has the value of 'directive'), C<linum> (int,
line number, starts from 1), C<line> (str, raw line), C<directive> (str,
directive name), C<cur_section> (str, current section name), C<args> (array,
directive arguments).
=item * Found a comment line
Arguments passed: C<event> (str, 'comment'), C<linum>, C<line>, C<cur_section>.
=item * Found a section line
Arguments passed: C<event> (str, 'section'), C<linum>, C<line>, C<cur_section>,
C<section> (str, section name).
=item * Found a key line
Arguments passed: C<event> (str, 'section'), C<linum>, C<line>, C<cur_section>,
C<key> (str, key name), C<val> (any, value name, already decoded if encoded),
C<raw_val> (str, raw value).
=back
TODO: callback when there is merging.
=head1 HOMEPAGE
Please visit the project's homepage at L<https://metacpan.org/release/Config-IOD-Reader>.
=head1 SOURCE
Source repository is at L<https://github.com/perlancar/perl-Config-IOD-Reader>.
=head1 SEE ALSO
L<IOD> - specification
L<Config::IOD> - round-trip parser for reading as well as writing IOD documents
L<IOD::Examples> - sample documents
=head1 AUTHOR
perlancar <perlancar@cpan.org>
=head1 CONTRIBUTOR
=for stopwords Steven Haryanto
Steven Haryanto <stevenharyanto@gmail.com>
=head1 CONTRIBUTING
To contribute, you can send patches by email/via RT, or send pull requests on
GitHub.
Most of the time, you don't need to build the distribution yourself. You can
simply modify the code, then test via:
 % prove -l
If you want to build the distribution (e.g. to try to install it locally on your
system), you can install L<Dist::Zilla>,
L<Dist::Zilla::PluginBundle::Author::PERLANCAR>, and sometimes one or two other
Dist::Zilla plugin and/or Pod::Weaver::Plugin. Any additional steps required
beyond that are considered a bug and can be reported to me.
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2022, 2021, 2019, 2018, 2017, 2016, 2015, 2014 by perlancar <perlancar@cpan.org>.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=head1 BUGS
Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Config-IOD-Reader>
When submitting a bug or request, please include a test-file or a
patch to an existing test-file that illustrates the bug or desired
feature.
=cut