File Coverage

blib/lib/Config/IOD.pm

Criterion	Covered	Total	%
statement	75	77	97.4
branch	43	46	93.4
condition	5	9	55.5
subroutine	6	6	100.0
pod			n/a
total	129	138	93.4

package Config::IOD;

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'; # DIST
our $VERSION = '0.353'; # VERSION

sub _init_read {
    my $self = shift;

    $self->{_cur_section} = $self->{default_section};

    # for checking when allow_duplicate_key=0
    $self->{_key_mem} = {}; # key=section name, value=hash of key->1

    $self->SUPER::_init_read;
}

our $re_directive_abo =
    qr/^(;?)(\s*)!
       (\s*)(\w+)(\s*)(.*)
       (\R?)\z/x;
our $re_directive =
    qr/^(;)(\s*)!
       (\s*)(\w+)(\s*)(.*)
       (\R?)\z/x;

sub _read_string {
    my ($self, $str) = @_;

    my $res = [];

    my $directive_re = $self->{allow_bang_only} ?
        $re_directive_abo : $re_directive;

    my @lines = split /^/, $str;
    local $self->{_linum} = 0;
  LINE:
    for my $line (@lines) {
        $self->{_linum}++;

        # blank line
        if ($line !~ /\S/) {
            push @$res, [
                'B',
                $line, # RAW
            ];
            next LINE;
        }

        # section line
        if ($line =~ /^(\s*)\[(\s*)(.+?)(\s*)\]
                      (?: (\s*)([;#])(.*))?
                      (\R?)\z/x) {
            push @$res, [
                'S',
                $1, # COL_S_WS1
                $2, # COL_S_WS2
                $3, # COL_S_SECTION
                $4, # COL_S_WS3
                $5, # COL_S_WS4
                $6, # COL_S_COMMENT_CHAR
                $7, # COL_S_COMMENT
                $8, # COL_S_NL
            ];
            $self->{_cur_section} = $3;
            next LINE;
        }

        # directive line
        my $line0 = $line;
        if ($self->{enable_directive} && $line =~ s/$directive_re//) {
            push @$res, [
                'D',
                $1, # COL_D_COMMENT_CHAR
                $2, # COL_D_WS1
                $3, # COL_D_WS2
                $4, # COL_D_DIRECTIVE
                $5, # COL_D_WS3
                $6, # COL_D_ARGS_RAW
                $7, # COL_D_NL
            ];
            my $directive = $4;
            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($6);
            if (!defined($args)) {
                $self->_err("Invalid arguments syntax '$6'");
            }
            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));
                $self->_pop_include_stack;
            } elsif ($directive eq 'merge') {
            } elsif ($directive eq 'noop') {
            } else {
                if ($self->{ignore_unknown_directive}) {
                } else {
                    $self->_err("Unknown directive '$directive'");
                }
            }
            next LINE;
        }

      L1:
        # comment line
        if ($line =~ /^(\s*)([;#])(.*?)
                      (\R?)\z/x) {
            push @$res, [
                'C',
                $1, # COL_C_WS1
                $2, # COL_C_COMMENT_CHAR
                $3, # COL_C_COMMENT
                $4, # COL_C_NL
            ];
            next LINE;
        }

        # key line
        if ($line =~ /^(\s*)([^=]+?)(\s*)=
                      (\s*)(.*?)
                      (\R?)\z/x) {
            push @$res, [
                'K',
                $1, # COL_K_WS1
                $2, # COL_K_KEY
                $3, # COL_K_WS2
                $4, # COL_K_WS3
                $5, # COL_K_VALUE_RAW
                $6, # COL_K_NL
            ];

            if ($self->{warn_perl} && !$4 && substr($5, 0, 1) eq '>') {
                $self->_warn("Probably using Perl syntax instead of INI: $line");
            }

            if (!$self->{allow_duplicate_key}) {
                my $kmem = $self->{_key_mem};
                if ($kmem->{$self->{_cur_section}}{$2}) {
                    $self->_err(
                        "Duplicate key: $2 (section $self->{_cur_section})");
                }
                $kmem->{$self->{_cur_section}}{$2} = 1;
            }
            next LINE;
        }

        $self->_err("Invalid syntax");
    }

    # make sure we always end with newline
    if (@$res) {
        $res->[-1][-1] .= "\n"
            unless $res->[-1][-1] =~ /\R\z/;
    }

    require Config::IOD::Document;
    Config::IOD::Document->new(_parser=>$self, _parsed=>$res);
}

1;
# ABSTRACT: Read and write IOD/INI configuration files

__END__